/[cl-l10n]/cl-l10n/locale.lisp
ViewVC logotype

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Nov 29 14:14:41 2004 UTC (9 years, 4 months ago) by sross
Branch: MAIN
Changes since 1.1: +1 -0 lines
Fixed print-time-string to handle double percs
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3
4 ;; TODO
5 ;; README
6 ;; What to do with LC_CTYPE, LC_COLLATE
7 ;; Tests
8 ;; Finish time format directives
9 ;; Test on windows.
10 ;; Merge with property files
11 ;; Cache getters? (reset on reload of locales)
12 ;; Time Zone printing
13 ;; Parsers?
14
15 (in-package :cl-l10n )
16
17 ;; Variables
18 (defvar *locale-path*
19 (let ((path *load-pathname*))
20 (make-pathname :host (pathname-host path)
21 :device (pathname-device path)
22 :directory
23 (append (pathname-directory path)
24 '("locales"))
25 :defaults #P"")))
26
27
28 (defvar *locale* nil)
29
30 (defvar *locales* (make-hash-table :test #'equal))
31
32 ;; Conditions
33 (defun locale-report (obj stream)
34 (format stream "~A" (mesg obj)))
35
36 (define-condition locale-error ()
37 ((mesg :accessor mesg :initarg :mesg :initform "Unknown."))
38 (:report locale-report))
39
40 (defun locale-error (string &rest args)
41 (error 'locale-error :mesg (apply #'format nil string args)))
42
43
44 ;; Classes
45 (defclass locale ()
46 ((locale-name :accessor locale-name :initarg :name
47 :initform (required-arg :name))
48 (title :accessor title :initarg :title :initform nil)
49 (source :accessor source :initarg :source :initform nil)
50 (language :accessor language :initarg :language :initform nil)
51 (territory :accessor territory :initarg :territory :initform nil)
52 (revision :accessor revision :initarg :revision :initform nil)
53 (date :accessor date :initarg :date :initform nil)
54 (categories :accessor categories :initarg :categories
55 :initform (make-hash-table :test #'equal))))
56
57 (defmethod print-object ((obj locale) stream)
58 (print-unreadable-object (obj stream :type t :identity t)
59 (princ (locale-name obj) stream)))
60
61 (defclass category ()
62 ((category-name :accessor category-name :initform (required-arg :name)
63 :initarg :name)
64 (vals :accessor vals :initform (make-hash-table :test #'equal)
65 :initarg :vals)))
66
67 (defmethod print-object ((obj category) stream)
68 (print-unreadable-object (obj stream :type t :identity t)
69 (princ (category-name obj) stream)))
70
71
72 ;; Macros
73 (defmacro get-locale (name)
74 `(gethash ,name *locales*))
75
76 (defmacro get-category (name locale)
77 `(gethash ,name (categories ,locale)))
78
79 (defmacro get-cat-val (value cat)
80 `(gethash ,value (vals ,cat)))
81
82
83 (defun locale-value (locale cat key)
84 (awhen (get-category cat locale)
85 (get-cat-val key it)))
86
87 (defun getenv (word)
88 #+sbcl (sb-ext:posix-getenv word)
89 #+lispworks (hcl:getenv word)
90 #+cmu (cdr (assoc (intern word :keyword) ext:*environment-list*))
91 #+clisp (ext:getenv word))
92
93
94 ;; Getters
95 (defmacro defgetter (key cat &key wrap)
96 (let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
97 `(progn
98 (defun ,name (&optional (locale *locale*))
99 (let ((locale (locale-des->locale locale)))
100 (when locale
101 (awhen (get-category ,cat locale)
102 ,(if wrap
103 `(funcall ,wrap (get-cat-val ,key it))
104 `(get-cat-val ,key it))))))
105 (export ',name))))
106
107 (defun parse-car-or-val (x)
108 (values (parse-integer (if (consp x) (car x) x))))
109
110 (defgetter "int_curr_symbol" "LC_MONETARY")
111 (defgetter "currency_symbol" "LC_MONETARY")
112 (defgetter "mon_decimal_point" "LC_MONETARY")
113 (defgetter "mon_thousands_sep" "LC_MONETARY")
114 (defgetter "mon_grouping" "LC_MONETARY" :wrap 'parse-car-or-val)
115 (defgetter "positive_sign" "LC_MONETARY")
116 (defgetter "negative_sign" "LC_MONETARY")
117 (defgetter "int_frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
118 (defgetter "frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
119 (defgetter "p_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
120 (defgetter "p_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
121 (defgetter "n_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
122 (defgetter "n_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
123 (defgetter "p_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
124 (defgetter "n_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
125 (defgetter "decimal_point" "LC_NUMERIC")
126 (defgetter "thousands_sep" "LC_NUMERIC")
127 (defgetter "grouping" "LC_NUMERIC" :wrap 'parse-car-or-val)
128 (defgetter "abday" "LC_TIME")
129 (defgetter "day" "LC_TIME")
130 (defgetter "abmon" "LC_TIME")
131 (defgetter "mon" "LC_TIME")
132 (defgetter "d_t_fmt" "LC_TIME")
133 (defgetter "d_fmt" "LC_TIME")
134 (defgetter "t_fmt" "LC_TIME")
135 (defgetter "am_pm" "LC_TIME")
136 (defgetter "t_fmt_ampm" "LC_TIME")
137 (defgetter "date_fmt" "LC_TIME")
138 (defgetter "yesexpr" "LC_MESSAGES")
139 (defgetter "noexpr" "LC_MESSAGES")
140 (defgetter "height" "LC_PAPER")
141 (defgetter "width" "LC_PAPER")
142 (defgetter "name_fmt" "LC_NAME")
143 (defgetter "name_gen" "LC_NAME")
144 (defgetter "name_mr" "LC_NAME")
145 (defgetter "name_mrs" "LC_NAME")
146 (defgetter "name_miss" "LC_NAME")
147 (defgetter "name_ms" "LC_NAME")
148 (defgetter "postal_fmt" "LC_ADDRESS")
149 (defgetter "tel_int_fmt" "LC_TELEPHONE")
150 (defgetter "measurement" "LC_MEASUREMENT")
151
152
153
154
155
156 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5