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

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Tue Jan 4 15:32:15 2005 UTC (9 years, 3 months ago) by sross
Branch: MAIN
Changes since 1.6: +30 -19 lines
Changelog 2005-01-04
1 sross 1.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 sross 1.6 ;; Parsers (money and time)
8 sross 1.5 ;; locale aliases
9 sross 1.6 ;; Optimizing print-time
10 sross 1.7 ;; Thread safety
11 sross 1.1
12     (in-package :cl-l10n )
13    
14     (defvar *locale-path*
15 sross 1.7 (merge-pathnames (make-pathname :directory '(:relative "locales"))
16     (directory-namestring *load-pathname*)))
17 sross 1.1
18     (defvar *locale* nil)
19    
20 sross 1.6 (defvar *locales* (make-hash-table :test #'equal)
21     "Hash table containing all loaded locales keyed on name (eg. \"af_ZA\")")
22 sross 1.1
23     ;; Conditions
24     (defun locale-report (obj stream)
25 sross 1.6 (cl:format stream "~A" (mesg obj)))
26 sross 1.1
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 sross 1.6 (error 'locale-error :mesg (apply #'cl:format nil string args)))
33 sross 1.1
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 sross 1.6 (printers :accessor printers :initarg :printers :initform nil)
40 sross 1.1 (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 sross 1.7 (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 sross 1.1
89     (defun locale-value (locale cat key)
90 sross 1.7 (awhen (get-category locale cat)
91     (category-value it key)))
92 sross 1.1
93     (defun getenv (word)
94     #+sbcl (sb-ext:posix-getenv word)
95     #+lispworks (hcl:getenv word)
96     #+cmu (cdr (assoc (intern word :keyword) ext:*environment-list*))
97 sross 1.5 #+clisp (ext:getenv word)
98     #+ecl (si:getenv word))
99 sross 1.1
100 sross 1.6 ;; Getters
101     (let ((getter-cache (make-hash-table :test #'equal)))
102     (defun gett-value (locale cat key &optional (wrap #'identity))
103     (let ((lookup-key (list locale cat key)))
104     (multiple-value-bind (val win) (gethash lookup-key getter-cache)
105     (if (or val win)
106     val
107     (setf (gethash lookup-key getter-cache)
108     (funcall wrap (locale-value locale cat key)))))))
109     (defun clear-getter-cache ()
110     (setf getter-cache (make-hash-table :test #'equal))))
111 sross 1.1
112     (defmacro defgetter (key cat &key wrap)
113     (let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
114     `(progn
115 sross 1.6 (defun ,name (&optional (locale *locale*))
116     (let ((locale (locale-des->locale locale)))
117     (when locale
118     (gett-value locale ,cat ,key ,@(if wrap (list wrap) nil)))))
119     (export ',name))))
120 sross 1.1
121     (defun parse-car-or-val (x)
122     (values (parse-integer (if (consp x) (car x) x))))
123    
124     (defgetter "int_curr_symbol" "LC_MONETARY")
125     (defgetter "currency_symbol" "LC_MONETARY")
126     (defgetter "mon_decimal_point" "LC_MONETARY")
127     (defgetter "mon_thousands_sep" "LC_MONETARY")
128     (defgetter "mon_grouping" "LC_MONETARY" :wrap 'parse-car-or-val)
129     (defgetter "positive_sign" "LC_MONETARY")
130     (defgetter "negative_sign" "LC_MONETARY")
131     (defgetter "int_frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
132     (defgetter "frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
133     (defgetter "p_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
134     (defgetter "p_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
135     (defgetter "n_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
136     (defgetter "n_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
137     (defgetter "p_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
138     (defgetter "n_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
139     (defgetter "decimal_point" "LC_NUMERIC")
140     (defgetter "thousands_sep" "LC_NUMERIC")
141     (defgetter "grouping" "LC_NUMERIC" :wrap 'parse-car-or-val)
142     (defgetter "abday" "LC_TIME")
143     (defgetter "day" "LC_TIME")
144     (defgetter "abmon" "LC_TIME")
145     (defgetter "mon" "LC_TIME")
146     (defgetter "d_t_fmt" "LC_TIME")
147     (defgetter "d_fmt" "LC_TIME")
148     (defgetter "t_fmt" "LC_TIME")
149     (defgetter "am_pm" "LC_TIME")
150     (defgetter "t_fmt_ampm" "LC_TIME")
151     (defgetter "date_fmt" "LC_TIME")
152     (defgetter "yesexpr" "LC_MESSAGES")
153     (defgetter "noexpr" "LC_MESSAGES")
154     (defgetter "height" "LC_PAPER")
155     (defgetter "width" "LC_PAPER")
156     (defgetter "name_fmt" "LC_NAME")
157     (defgetter "name_gen" "LC_NAME")
158     (defgetter "name_mr" "LC_NAME")
159     (defgetter "name_mrs" "LC_NAME")
160     (defgetter "name_miss" "LC_NAME")
161     (defgetter "name_ms" "LC_NAME")
162     (defgetter "postal_fmt" "LC_ADDRESS")
163     (defgetter "tel_int_fmt" "LC_TELEPHONE")
164     (defgetter "measurement" "LC_MEASUREMENT")
165    
166    
167 sross 1.6 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5