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

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5