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

Diff of /cl-l10n/load-locale.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by sross, Thu Mar 31 13:53:42 2005 UTC revision 1.13 by sross, Wed May 18 15:34:08 2005 UTC
# Line 16  If LOADER is non-nil skip everything and Line 16  If LOADER is non-nil skip everything and
16    (let ((name (aif (position #\. loc-name)    (let ((name (aif (position #\. loc-name)
17                     (subseq loc-name 0 it)                     (subseq loc-name 0 it)
18                     loc-name)))                     loc-name)))
     (unless use-cache  
       ;; The local file might have changed so ...  
       (clear-getter-cache))  
19      (acond ((and (not name) (not errorp)) nil)      (acond ((and (not name) (not errorp)) nil)
20             ((and use-cache (get-locale name)) it)             ((and use-cache (get-locale name)) it)
21             (loader (setf (get-locale name) (funcall loader name)))             (loader (setf (get-locale name) (funcall loader name)))
# Line 48  actual locale object." Line 45  actual locale object."
45  (defun load-locale (name)  (defun load-locale (name)
46    (let ((path (merge-pathnames *locale-path* name)))    (let ((path (merge-pathnames *locale-path* name)))
47      (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)      (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
48      (let ((locale (make-instance *locale-type* :name name))      (let ((locale (make-instance *locale-type* :name name)))
           (*read-eval* nil)  
           (*print-circle* nil))  
49        (with-open-file (stream path        (with-open-file (stream path
50                         :external-format #+(and sbcl sb-unicode) :latin1                         :external-format #+(and sbcl sb-unicode) :latin1
51                                          #-(and sbcl sb-unicode) :default)                                          #-(and sbcl sb-unicode) :default)
52          (multiple-value-bind (escape comment) (munge-headers stream)          (multiple-value-bind (escape comment) (munge-headers stream)
53            (awhile (next-header stream)            (loop for header = (next-header stream)
54              (awhen (make-category locale it (parse-category it stream                  while header do
55                                                              escape comment))              (when-let (cat (make-category locale header
56                (setf (get-category locale (category-name it)) it)))))                                            (parse-category header stream
57                                                              escape comment)))
58                  (setf (get-category locale header) cat)))))
59        (add-printers locale)        (add-printers locale)
60        (add-parsers locale)        (add-parsers locale)
61        locale)))        locale)))
62    
63  (defun load-all-locales (&optional (path *locale-path*))  (defun load-all-locales (&key (path *locale-path*) (ignore-errors nil) (use-cache nil))
64    "Load all locale found in pathname designator PATH."    "Load all locale found in pathname designator PATH."
65    (let ((*locale-path* path))    (let ((*locale-path* path))
66      ;; Is this portable?      (dolist (x (list-directory *locale-path*))
67      (dolist (x (directory (merge-pathnames *locale-path* "*")))        (when (and (not (directory-pathname-p x)) (pathname-name x))
68        (when (pathname-name x)          (let ((locale (pathname-name x)))
69          (with-simple-restart (continue "Ignore locale ~A." x)            (with-simple-restart (continue "Ignore locale ~A." x)
70            (handler-case (load-locale (pathname-name x))              (handler-bind ((error (lambda (&optional c)
71              (locale-error (c) (warn "Unable to load locale ~A. ~%~A." x c))))))))                                      (when ignore-errors
72                                          (warn "Failed to load locale ~S, Ignoring." locale)
73                                          (invoke-restart (find-restart 'continue c))))))
74                  (locale locale :use-cache use-cache))))))))
75    
76  (defvar *default-thousands-sep* #\,)  (defvar *default-thousands-sep* #\,)
77    
# Line 126  actual locale object." Line 126  actual locale object."
126    
127  (defun add-printers (locale)  (defun add-printers (locale)
128    "Creates monetary and numeric format strings for locale LOCALE."    "Creates monetary and numeric format strings for locale LOCALE."
129    (setf (printers locale)    (when (and (get-category locale "LC_MONETARY")
130          (nconc (list :number-no-ts               (get-category locale "LC_NUMERIC"))
131                       (create-number-fmt-string locale t))      ;; otherwise its an include locale (tranlit* etc)
132                 (list :number-ts      (setf (printers locale)
133                       (create-number-fmt-string locale nil))            (nconc (list :number-no-ts
134                 (list :money-p-no-ts                         (create-number-fmt-string locale t))
135                       (create-money-fmt-string locale t nil))                   (list :number-ts
136                 (list :money-p-ts                         (create-number-fmt-string locale nil))
137                       (create-money-fmt-string locale nil nil))                   (list :money-p-no-ts
138                 (list :money-n-no-ts                         (create-money-fmt-string locale t nil))
139                       (create-money-fmt-string locale t t))                   (list :money-p-ts
140                 (list :money-n-ts                         (create-money-fmt-string locale nil nil))
141                       (create-money-fmt-string locale nil t))                   (list :money-n-no-ts
142                 (printers locale))))                         (create-money-fmt-string locale t t))
143                     (list :money-n-ts
144                           (create-money-fmt-string locale nil t))
145                     (printers locale)))))
146    
147  (defun day-element-p (x)  (defun day-element-p (x)
148    (member x '(#\d #\e)))    (member x '(#\d #\e)))
149    
150  (defun month-element-p (x)  (defun month-element-p (x)
151    (char= x #\m))    (member x '(#\m #\b #\B)))
152    
153  (defun year-element-p (x)  (defun year-element-p (x)
154    (member x '(#\y #\Y)))    (member x '(#\y #\Y)))
# Line 172  actual locale object." Line 175  actual locale object."
175            with perc = nil do            with perc = nil do
176            (cond ((char= char #\%) (setf perc (not perc)))            (cond ((char= char #\%) (setf perc (not perc)))
177                  ((member char date-dividers) nil)                  ((member char date-dividers) nil)
178                  (perc (let ((val (element-type char)))                  (perc (unless (char= char #\E)
179                          (when val (push val res))                          ;; some locales (eg lo_LA) have this funny E before
180                          (setf perc nil)))))                          ;; various time format designators. Debian
181                            ;; treats this as if it wasn't there so neither do we.
182                            (let ((val (element-type char)))
183                              (when val (push val res))
184                              (setf perc nil))))))
185      (nreverse res)))      (nreverse res)))
186    
   
187  (defun add-parsers (locale)  (defun add-parsers (locale)
188    (destructuring-bind (first second third)    (when (get-category locale "LC_TIME")
189        (locale-date-month-order locale)      (destructuring-bind (first second third)
190      (setf (parsers locale)          (locale-date-month-order locale)
191            (list `((noon-midn) (weekday) ,first (date-divider) ,second (date-divider) ,third (noon-midn))        (setf (parsers locale)
192                  `((weekday) ,first (date-divider) ,second (date-divider) ,third hour (time-divider) minute              (list `((noon-midn) (weekday) ,first (date-divider) ,second (date-divider) ,third (noon-midn))
193                    (time-divider) (secondp) (am-pm) (date-divider) (zone))                    `((weekday) ,first (date-divider) ,second (date-divider) ,third hour (time-divider) minute
194                  `(hour (time-divider) minute (time-divider) (secondp) (am-pm) (weekday) ,first (date-divider)                      (time-divider) (secondp) (am-pm) (date-divider) (zone))
195                         (secondp) (date-divider) ,third (date-divider) (zone))))))                    `(hour (time-divider) minute (time-divider) (secondp) (am-pm) (weekday) ,first (date-divider)
196                             (secondp) (date-divider) ,third (date-divider) (zone)))))))
197    
198  (defvar *category-loaders*  (defvar *category-loaders*
199    '(("LC_IDENTIFICATION" . load-identification)    '(("LC_IDENTIFICATION" . load-identification)
# Line 205  actual locale object." Line 212  actual locale object."
212    (cdr (assoc name *category-loaders* :test #'string=)))    (cdr (assoc name *category-loaders* :test #'string=)))
213    
214  (defun make-category (locale name vals)  (defun make-category (locale name vals)
215    (awhen (get-loader name)    (when-let (loader (get-loader name))
216      (funcall it locale name vals)))      (funcall loader locale name vals)))
217    
218  (defgeneric load-category (locale name vals)  (defgeneric load-category (locale name vals)
219    (:documentation "Load a category for LOCALE using VALS.")    (:documentation "Load a category for LOCALE using VALS.")
# Line 283  actual locale object." Line 290  actual locale object."
290                     (schar (cdr (get-value line stream escape)) 0)))))                     (schar (cdr (get-value line stream escape)) 0)))))
291      (values escape comment-char)))      (values escape comment-char)))
292    
   
   
293  (defun get-full-line (line stream escape)  (defun get-full-line (line stream escape)
294    (let ((length (length line)))    (let ((length (length line)))
295      (if (char= (elt line (1- length)) escape)      (if (char= (elt line (1- length)) escape)
# Line 299  actual locale object." Line 304  actual locale object."
304                               escape)))                               escape)))
305          line)))          line)))
306    
307    (defun real-value (string)
308  (defun real-character (char)    (loop for char across string
309    (let ((int (parse-integer (trim char (list* #\U #\> #\< *whitespace*))          with in-special = nil
310                              :radix 16)))          with result = ()
311      (handler-case (code-char int)          with special-val = () do
312        (type-error (c)          (cond ((eql char #\"))
313          (declare (ignore c))                ((eql char #\<) (setf in-special t))
314          (locale-error "Cannot represent ~A as a character." int)))))                ((and in-special (eq char #\>))
315                   (push (code-char
316  (defvar *regex* '(:sequence                        (parse-integer (coerce (cdr (nreverse special-val)) 'string)
317                    #\<                                       :radix 16))
318                    (:greedy-repetition 0 nil                       result)
319                     (:inverted-char-class #\> #\<)                 (setf in-special nil
320                     :everything)                       special-val nil))
321                    #\>))                (in-special (push char special-val))
322                  (t (push char result)))
323  (defvar *match-scanner* (cl-ppcre:create-scanner *regex*))          finally (return (coerce (nreverse result)
324                                    #-lispworks 'string
325  (defun old-real-value (val)                                  #+lispworks 'lw:text-string))))
   (aif (all-matches-as-strings *match-scanner* val)  
        (map #-lispworks 'string #+lispworks  
             'lw:text-string #'real-character it)  
        val))  
   
 ;; KLUDGE  
 (defun real-value (val)  
   (remove #\" (old-real-value val)))  
   
326    
327  (defvar *split-scanner*  (defvar *split-scanner*
328    (cl-ppcre:create-scanner '(:char-class #\;)))    (cl-ppcre:create-scanner '(:char-class #\;)))

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5