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

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5