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

Contents of /cl-l10n/locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Thu Apr 27 18:30:30 2006 UTC (7 years, 11 months ago) by sross
Branch: MAIN
CVS Tags: before_i18n_rewrite
Changes since 1.11: +2 -0 lines
* parse-number.lisp: Changed parse-error to extend parser-error
* parse-time.lisp: Changed uses of eq to eql when using numbers
  or characters.
* printers.lisp: Default length fraction digits to 0 if it can't
  be found in the current locale. Fixed printers of %R time format directive.
* load-locale.lisp: Search environment variable LANG before trying using
  POSIX locale when loading default locale.
  Add shadowing-format which shadows format and formatter into the current package.
* package.lisp: Export load-default-locale
* doc/cl-l10n.texi: Rename the Index node to Comprehensive Index in
  order to avoid a name clash with index.html on platforms with
  case-insensitive filesystems.  Prettify the copyright notice.
* doc/Makefile, doc/style.css, doc/gendocs.sh, doc/gendocs_template, doc/style.css:
  New files.
* load-locale.lisp (load-locale): Specify an explicit
  external-format for CLISP
* test.lisp: Fix indentation of deftest forms.
  (time.2): Obtain the o-with-diaeresis in a slightly more portable way.
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3
4 ;; TODO
5 ;; use LC_COLLATE to define locale-uppercase and friends
6 ;; Test on windows.
7 ;; Parsers (money)
8 ;; locale aliases?
9 ;; Optimizing print-time
10 ;; Handle _ and - in time directives (see date --help)
11 ;; Compile locales into fasl files.
12
13 (in-package :cl-l10n )
14
15 (defvar *locale-path*
16 (merge-pathnames (make-pathname :directory '(:relative "locales"))
17 (asdf:component-pathname (asdf:find-system :cl-l10n))))
18
19 (defvar *locale* nil)
20
21 (defvar *locales* (make-hash-table :test #'equal)
22 "Hash table containing all loaded locales keyed on name (eg. \"af_ZA\")")
23
24 ;; Conditions
25 (define-condition locale-error (error)
26 ((mesg :accessor mesg :initarg :mesg :initform "Unknown."))
27 (:report (lambda (obj stream) (cl:format stream "~A" (mesg obj)))))
28
29 (defun locale-error (string &rest args)
30 (error 'locale-error :mesg (apply #'cl:format nil string args)))
31
32 ;; Classes
33 (defclass locale ()
34 ((locale-name :accessor locale-name :initarg :name
35 :initform (required-arg :name))
36 (title :accessor title :initarg :title :initform nil)
37 (printers :accessor printers :initarg :printers :initform nil)
38 (parsers :accessor parsers :initarg :parsers :initform nil)
39 (source :accessor source :initarg :source :initform nil)
40 (language :accessor language :initarg :language :initform nil)
41 (territory :accessor territory :initarg :territory :initform nil)
42 (revision :accessor revision :initarg :revision :initform nil)
43 (date :accessor date :initarg :date :initform nil)
44 (categories :accessor categories :initarg :categories
45 :initform (make-hash-table :test #'equal))))
46
47 (defmethod print-object ((obj locale) stream)
48 (print-unreadable-object (obj stream :type t :identity t)
49 (princ (locale-name obj) stream)))
50
51 (defclass category ()
52 ((category-name :accessor category-name :initform (required-arg :name)
53 :initarg :name)
54 (vals :accessor vals :initform (make-hash-table :test #'equal)
55 :initarg :vals)))
56
57 (defmethod print-object ((obj category) stream)
58 (print-unreadable-object (obj stream :type t :identity t)
59 (princ (category-name obj) stream)))
60
61
62 (declaim (inline get-locale))
63 (defun get-locale (name)
64 (gethash name *locales*))
65
66 (defun (setf get-locale) (new-val name)
67 (setf (gethash name *locales*)
68 new-val))
69
70 (defgeneric get-category (locale name)
71 (:documentation "Find category called NAME in locale LOCALE.")
72 (:method ((locale locale) (name string))
73 (gethash name (categories locale))))
74
75 (defmethod (setf get-category) ((new-val category) (locale locale) (name string))
76 (setf (gethash name (categories locale))
77 new-val))
78
79 (defgeneric category-value (category key)
80 (:documentation "Lookup attribute named by string KEY in category CATEGORY.")
81 (:method ((category category) (key string))
82 (gethash key (vals category))))
83
84 (defmethod (setf category-value) ((new-val t) (category category) (key string))
85 (setf (gethash key (vals category))
86 new-val))
87
88 (defun locale-value (locale cat key)
89 (when-let (cat (get-category locale cat))
90 (category-value cat key)))
91
92 (defun getenv (word)
93 #+sbcl (sb-ext:posix-getenv word)
94 #+lispworks (lw:environment-variable word)
95 #+acl (sys:getenv word)
96 #+cmu (cdr (assoc (intern word :keyword) ext:*environment-list*))
97 #+clisp (ext:getenv word)
98 #+ecl (si:getenv word))
99
100 ;; Getters
101 (defmacro defgetter (key cat &key (wrap '#'identity))
102 (let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
103 `(progn
104 (defun ,name (&optional (locale *locale*))
105 (let ((locale (locale-des->locale locale)))
106 (when locale
107 (funcall ,wrap (locale-value locale ,cat ,key)))))
108 (export ',name))))
109
110 (defun parse-car-or-val (x)
111 (values (parse-integer (if (consp x) (car x) x))))
112
113 (defgetter "int_curr_symbol" "LC_MONETARY")
114 (defgetter "currency_symbol" "LC_MONETARY")
115 (defgetter "mon_decimal_point" "LC_MONETARY")
116 (defgetter "mon_thousands_sep" "LC_MONETARY")
117 (defgetter "mon_grouping" "LC_MONETARY" :wrap 'parse-car-or-val)
118 (defgetter "positive_sign" "LC_MONETARY")
119 (defgetter "negative_sign" "LC_MONETARY")
120 (defgetter "int_frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
121 (defgetter "frac_digits" "LC_MONETARY" :wrap 'parse-car-or-val)
122 (defgetter "p_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
123 (defgetter "p_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
124 (defgetter "n_cs_precedes" "LC_MONETARY" :wrap 'parse-car-or-val)
125 (defgetter "n_sep_by_space" "LC_MONETARY" :wrap 'parse-car-or-val)
126 (defgetter "p_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
127 (defgetter "n_sign_posn" "LC_MONETARY" :wrap 'parse-car-or-val)
128 (defgetter "decimal_point" "LC_NUMERIC")
129 (defgetter "thousands_sep" "LC_NUMERIC")
130 (defgetter "grouping" "LC_NUMERIC" :wrap 'parse-car-or-val)
131 (defgetter "abday" "LC_TIME")
132 (defgetter "day" "LC_TIME")
133 (defgetter "abmon" "LC_TIME")
134 (defgetter "mon" "LC_TIME")
135 (defgetter "d_t_fmt" "LC_TIME")
136 (defgetter "d_fmt" "LC_TIME")
137 (defgetter "t_fmt" "LC_TIME")
138 (defgetter "am_pm" "LC_TIME")
139 (defgetter "t_fmt_ampm" "LC_TIME")
140 (defgetter "date_fmt" "LC_TIME")
141 (defgetter "yesexpr" "LC_MESSAGES")
142 (defgetter "noexpr" "LC_MESSAGES")
143 (defgetter "height" "LC_PAPER")
144 (defgetter "width" "LC_PAPER")
145 (defgetter "name_fmt" "LC_NAME")
146 (defgetter "name_gen" "LC_NAME")
147 (defgetter "name_mr" "LC_NAME")
148 (defgetter "name_mrs" "LC_NAME")
149 (defgetter "name_miss" "LC_NAME")
150 (defgetter "name_ms" "LC_NAME")
151 (defgetter "postal_fmt" "LC_ADDRESS")
152 (defgetter "tel_int_fmt" "LC_TELEPHONE")
153 (defgetter "measurement" "LC_MEASUREMENT")
154
155
156 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5