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

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Feb 22 14:18:25 2005 UTC (9 years, 1 month ago) by sross
Branch: MAIN
Changes since 1.7: +1 -0 lines
Changelog 2005-02-22
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3
4 ;; TODO
5 ;; What to do with LC_CTYPE, LC_COLLATE
6 ;; Test on windows.
7 ;; Parsers (money and time)
8 ;; locale aliases
9 ;; Optimizing print-time
10 ;; Thread safety
11
12 (in-package :cl-l10n )
13
14 (defvar *locale-path*
15 (merge-pathnames (make-pathname :directory '(:relative "locales"))
16 (directory-namestring *load-pathname*)))
17
18 (defvar *locale* nil)
19
20 (defvar *locales* (make-hash-table :test #'equal)
21 "Hash table containing all loaded locales keyed on name (eg. \"af_ZA\")")
22
23 ;; Conditions
24 (defun locale-report (obj stream)
25 (cl:format stream "~A" (mesg obj)))
26
27 (define-condition locale-error ()
28 ((mesg :accessor mesg :initarg :mesg :initform "Unknown."))
29 (:report locale-report))
30
31 (defun locale-error (string &rest args)
32 (error 'locale-error :mesg (apply #'cl:format nil string args)))
33
34 ;; Classes
35 (defclass locale ()
36 ((locale-name :accessor locale-name :initarg :name
37 :initform (required-arg :name))
38 (title :accessor title :initarg :title :initform nil)
39 (printers :accessor printers :initarg :printers :initform nil)
40 (source :accessor source :initarg :source :initform nil)
41 (language :accessor language :initarg :language :initform nil)
42 (territory :accessor territory :initarg :territory :initform nil)
43 (revision :accessor revision :initarg :revision :initform nil)
44 (date :accessor date :initarg :date :initform nil)
45 (categories :accessor categories :initarg :categories
46 :initform (make-hash-table :test #'equal))))
47
48 (defmethod print-object ((obj locale) stream)
49 (print-unreadable-object (obj stream :type t :identity t)
50 (princ (locale-name obj) stream)))
51
52 (defclass category ()
53 ((category-name :accessor category-name :initform (required-arg :name)
54 :initarg :name)
55 (vals :accessor vals :initform (make-hash-table :test #'equal)
56 :initarg :vals)))
57
58 (defmethod print-object ((obj category) stream)
59 (print-unreadable-object (obj stream :type t :identity t)
60 (princ (category-name obj) stream)))
61
62
63 (declaim (inline get-locale))
64 (defun get-locale (name)
65 (gethash name *locales*))
66
67 (defun (setf get-locale) (new-val name)
68 (setf (gethash name *locales*)
69 new-val))
70
71 (defgeneric get-category (locale name)
72 (:documentation "Find category called NAME in locale LOCALE.")
73 (:method ((locale locale) (name string))
74 (gethash name (categories locale))))
75
76 (defmethod (setf get-category) ((new-val category) (locale locale) (name string))
77 (setf (gethash name (categories locale))
78 new-val))
79
80 (defgeneric category-value (category key)
81 (:documentation "Lookup attribute named by string KEY in category CATEGORY.")
82 (:method ((category category) (key string))
83 (gethash key (vals category))))
84
85 (defmethod (setf category-value) ((new-val t) (category category) (key string))
86 (setf (gethash key (vals category))
87 new-val))
88
89 (defun locale-value (locale cat key)
90 (awhen (get-category locale cat)
91 (category-value it key)))
92
93 (defun getenv (word)
94 #+sbcl (sb-ext:posix-getenv word)
95 #+lispworks (hcl:getenv word)
96 #+acl (sys:getenv word)
97 #+cmu (cdr (assoc (intern word :keyword) ext:*environment-list*))
98 #+clisp (ext:getenv word)
99 #+ecl (si:getenv word))
100
101 ;; Getters
102 (let ((getter-cache (make-hash-table :test #'equal)))
103 (defun gett-value (locale cat key &optional (wrap #'identity))
104 (let ((lookup-key (list locale cat key)))
105 (multiple-value-bind (val win) (gethash lookup-key getter-cache)
106 (if (or val win)
107 val
108 (setf (gethash lookup-key getter-cache)
109 (funcall wrap (locale-value locale cat key)))))))
110 (defun clear-getter-cache ()
111 (setf getter-cache (make-hash-table :test #'equal))))
112
113 (defmacro defgetter (key cat &key wrap)
114 (let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
115 `(progn
116 (defun ,name (&optional (locale *locale*))
117 (let ((locale (locale-des->locale locale)))
118 (when locale
119 (gett-value locale ,cat ,key ,@(if wrap (list wrap) nil)))))
120 (export ',name))))
121
122 (defun parse-car-or-val (x)
123 (values (parse-integer (if (consp x) (car x) x))))
124
125 (defgetter "int_curr_symbol" "LC_MONETARY")
126 (defgetter "currency_symbol" "LC_MONETARY")
127 (defgetter "mon_decimal_point" "LC_MONETARY")
128 (defgetter "mon_thousands_sep" "LC_MONETARY")
129 (defgetter "mon_grouping" "LC_MONETARY" :wrap 'parse-car-or-val)
130 (defgetter "positive_sign" "LC_MONETARY")
131 (defgetter "negative_sign" "LC_MONETARY")
132 (defgetter "int_frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
133 (defgetter "frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
134 (defgetter "p_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
135 (defgetter "p_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
136 (defgetter "n_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
137 (defgetter "n_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
138 (defgetter "p_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
139 (defgetter "n_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
140 (defgetter "decimal_point" "LC_NUMERIC")
141 (defgetter "thousands_sep" "LC_NUMERIC")
142 (defgetter "grouping" "LC_NUMERIC" :wrap 'parse-car-or-val)
143 (defgetter "abday" "LC_TIME")
144 (defgetter "day" "LC_TIME")
145 (defgetter "abmon" "LC_TIME")
146 (defgetter "mon" "LC_TIME")
147 (defgetter "d_t_fmt" "LC_TIME")
148 (defgetter "d_fmt" "LC_TIME")
149 (defgetter "t_fmt" "LC_TIME")
150 (defgetter "am_pm" "LC_TIME")
151 (defgetter "t_fmt_ampm" "LC_TIME")
152 (defgetter "date_fmt" "LC_TIME")
153 (defgetter "yesexpr" "LC_MESSAGES")
154 (defgetter "noexpr" "LC_MESSAGES")
155 (defgetter "height" "LC_PAPER")
156 (defgetter "width" "LC_PAPER")
157 (defgetter "name_fmt" "LC_NAME")
158 (defgetter "name_gen" "LC_NAME")
159 (defgetter "name_mr" "LC_NAME")
160 (defgetter "name_mrs" "LC_NAME")
161 (defgetter "name_miss" "LC_NAME")
162 (defgetter "name_ms" "LC_NAME")
163 (defgetter "postal_fmt" "LC_ADDRESS")
164 (defgetter "tel_int_fmt" "LC_TELEPHONE")
165 (defgetter "measurement" "LC_MEASUREMENT")
166
167
168 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5