/[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.16 by alendvai, Tue Jun 6 14:58:46 2006 UTC revision 1.17 by alendvai, Thu Jun 8 09:38:19 2006 UTC
# Line 5  Line 5 
5  (defparameter *ignore-categories*  (defparameter *ignore-categories*
6    (list "LC_CTYPE" "LC_COLLATE"))    (list "LC_CTYPE" "LC_COLLATE"))
7    
8    (defparameter *language->default-locale-name* (make-hash-table :test #'equal)
9      "This map specifies what is the default locale for locale specifications without a region (i.e. en_US for en)")
10    
11    (deftype locale-descriptor ()
12      `(or locale string symbol))
13    
14    (defun canonical-locale-name-from (locale)
15      (check-type locale locale-descriptor)
16      (if (typep locale 'locale)
17          (locale-name locale)
18          (let ((name locale))
19            (when (and (not (null name))
20                       (symbolp name))
21              (setf name (symbol-name name)))
22            (let* ((parts (split "_" name))
23                   (count (list-length parts))
24                   (first-length (length (first parts)))
25                   (second-length (length (second parts))))
26              (when (> count 2)
27                (error "Locale variants are not yet supported"))
28              (when (or (> first-length 3)
29                        (< first-length 2)
30                        (and (> count 1)
31                             (or (> second-length 3)
32                                 (< second-length 2))))
33                (error "~A is not a valid locale name (examples: en_GB, en_US, en)" locale))
34              (let ((language (string-downcase (first parts)))
35                    (region (when (> count 1)
36                              (second parts))))
37                (if (> count 1)
38                    (concatenate 'string language "_" region)
39                    (aif (gethash language *language->default-locale-name*)
40                         it
41                         (concatenate 'string language "_" (string-upcase language)))))))))
42    
43    ;; set up the default region mappings while loading
44    (eval-when (:load-toplevel :execute)
45      (loop for (language locale) in
46            '((en "en_US")) do
47            (setf (gethash (string-downcase (symbol-name language)) *language->default-locale-name*)
48                  (canonical-locale-name-from locale)))
49      (values))
50    
51  ;; Add a restart here?  ;; Add a restart here?
52  (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))  (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
53    "Find locale named by the string LOC-NAME. If USE-CACHE    "Find locale named by the specification LOC-NAME. If USE-CACHE
54  is non-nil forcefully reload the locale from *locale-path* else  is non-nil forcefully reload the locale from *locale-path* else
55  the locale is first looked for in *locales*. If ERRORP is non-nil  the locale is first looked for in *locales*. If ERRORP is non-nil
56  signal a warning rather than an error if the locale file cannot be found.  signal a warning rather than an error if the locale file cannot be found.
57  If LOADER is non-nil skip everything and call loader with LOC-NAME."  If LOADER is non-nil skip everything and call loader with LOC-NAME."
58    (let ((name (aif (position #\. loc-name)    (if (typep loc-name 'locale)
59                     (subseq loc-name 0 it)        loc-name
60                     loc-name)))        (let ((name (canonical-locale-name-from
61      (acond ((and (not name) (not errorp)) nil)                     (aif (position #\. loc-name)
62             ((and use-cache (get-locale name)) it)                          (subseq loc-name 0 it)
63             (loader (setf (get-locale name) (funcall loader name)))                          loc-name))))
64             ((probe-file (merge-pathnames *locale-path* name))          (acond ((and (not name) (not errorp)) nil)
65              (setf (get-locale name) (load-locale name)))                 ((and use-cache (get-locale name)) it)
66             (t (funcall (if errorp #'error #'warn)                 (loader (setf (get-locale name) (funcall loader name)))
67                         "Can't find locale ~A." name)))))                 ((probe-file (merge-pathnames *locale-path* name))
68                    (setf (get-locale name) (load-locale name)))
69                   (t (funcall (if errorp #'error #'warn)
70                               "Can't find locale ~A." name))))))
71    
72  (defvar *locale-type* 'locale  (defvar *locale-type* 'locale
73    "The class of loaded locales.")    "The class of loaded locales.")
# Line 29  If LOADER is non-nil skip everything and Line 75  If LOADER is non-nil skip everything and
75  (defvar *category-type* 'category  (defvar *category-type* 'category
76    "The class of loaded categories")    "The class of loaded categories")
77    
 (deftype locale-descriptor ()  
   `(or locale string symbol))  
   
 (defun locale-des->locale (loc)  
   "Turns a locale descriptor(a string, symbol or locale) into an  
 actual locale object."  
   (check-type loc locale-descriptor)  
   (etypecase loc  
     (locale loc)  
     (string (locale loc))  
     (symbol (locale (string loc)))))  
   
78  (defun load-locale (name)  (defun load-locale (name)
79    (let ((path (merge-pathnames *locale-path* name))    (let ((path (merge-pathnames *locale-path* name))
80          (ef #+sbcl :iso-8859-1          (ef #+sbcl :iso-8859-1
# Line 360  actual locale object." Line 394  actual locale object."
394          (return-from next-header (trim line)))))          (return-from next-header (trim line)))))
395    
396  (defun set-locale (locale-des)  (defun set-locale (locale-des)
397    (setf *locale* (locale-des->locale locale-des)))    (setf *locale* (if (listp locale-des)
398                         (loop for locale in locale-des
399                               collect (locale locale))
400                         (locale locale-des))))
401    
402    (defmacro with-locale (locale &body body)
403      `(let ((*locale* (locale ,locale)))
404        ,@body))
405    
406  (defun load-default-locale ()  (defun load-default-locale ()
407    (setf *locale* (get-default-locale)))    (set-locale (get-default-locale)))
408    
409  (defun get-default-locale ()  (defun get-default-locale ()
410    (or (locale (getenv "CL_LOCALE") :errorp nil)    (macrolet ((try (name)
411        (locale (getenv "LC_CTYPE") :errorp nil)                 `(when-let (it (getenv ,name))
412        (locale (getenv "LANG") :errorp nil)                   (locale it :errorp nil))))
413        (locale "POSIX" :errorp nil)))      (or (try "CL_LOCALE")
414            (try "LC_CTYPE")
415            (try "LANG")
416            (locale "POSIX" :errorp nil))))
417    
418  (eval-when (:load-toplevel :execute)  (eval-when (:load-toplevel :execute)
419    (load-default-locale))    (load-default-locale))

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5