/[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.14 by sross, Wed May 25 09:30:51 2005 UTC revision 1.15 by sross, Thu Apr 27 18:30:30 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  ;; Add a restart here?  ;; Add a restart here?
9  (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))  (defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
10    "Find locale named by the string LOC-NAME. If USE-CACHE    "Find locale named by the string LOC-NAME. If USE-CACHE
# Line 43  actual locale object." Line 42  actual locale object."
42      (symbol (locale (string loc)))))      (symbol (locale (string loc)))))
43    
44  (defun load-locale (name)  (defun load-locale (name)
45    (let ((path (merge-pathnames *locale-path* name)))    (let ((path (merge-pathnames *locale-path* name))
46            (ef #+sbcl :iso-8859-1
47                #+clisp (ext:make-encoding :charset 'charset:iso-8859-1
48                                           :line-terminator :unix)
49                #-(or sbcl clisp) :default))
50      (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)      (cl:format *debug-io* "~&;; Loading locale from ~A.~%" path)
51      (let ((locale (make-instance *locale-type* :name name)))      (let ((locale (make-instance *locale-type* :name name)))
52        (with-open-file (stream path        (with-open-file (stream path :external-format ef)
                        :external-format #+(and sbcl sb-unicode) :latin1  
                                         #-(and sbcl sb-unicode) :default)  
53          (multiple-value-bind (escape comment) (munge-headers stream)          (multiple-value-bind (escape comment) (munge-headers stream)
54            (loop for header = (next-header stream)            (loop for header = (next-header stream)
55                  while header do                  while header do
# Line 83  actual locale object." Line 84  actual locale object."
84  (defun create-number-fmt-string (locale no-ts)  (defun create-number-fmt-string (locale no-ts)
85    (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"    (cl:format nil "~~A~~,,'~A,~A~A~~{~~A~~}"
86               (thousands-sep-char (locale-thousands-sep locale))               (thousands-sep-char (locale-thousands-sep locale))
87               (locale-grouping locale)               (if (minusp (locale-grouping locale)) 3 (locale-grouping locale))
88               (if no-ts "D" ":D")))               (if no-ts "D" ":D")))
89    
90  (defun get-descriptors (minusp locale)  (defun get-descriptors (minusp locale)
# Line 114  actual locale object." Line 115  actual locale object."
115          ;; Actual number          ;; Actual number
116          (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"          (cl:format stream "~~,,'~A,~A~A~~{~~A~~}"
117                     (thousands-sep-char (locale-mon-thousands-sep locale))                     (thousands-sep-char (locale-mon-thousands-sep locale))
118                     (locale-mon-grouping locale)                     (if (minusp (locale-mon-grouping locale)) 3 (locale-mon-grouping locale))
119                     (if no-ts "D" ":D"))                     (if no-ts "D" ":D"))
120          (unless prec          (unless prec
121            (princ sym-sep stream))            (princ sym-sep stream))
# Line 313  actual locale object." Line 314  actual locale object."
314          with in-special = nil          with in-special = nil
315          with result = ()          with result = ()
316          with special-val = () do          with special-val = () do
317          (cond ((eql char #\"))          (cond ((eql char #\") nil) ;;ignore
318                ((eql char #\<) (setf in-special t))                ((eql char #\<) (setf in-special t))
319                ((and in-special (eq char #\>))                ((and in-special (eql char #\>))
320                 (push (code-char                 (push (code-char
321                        (parse-integer (coerce (cdr (nreverse special-val)) 'string)                        (parse-integer (coerce (cdr (nreverse special-val)) 'string)
322                                       :radix 16))                                       :radix 16))
# Line 358  actual locale object." Line 359  actual locale object."
359                       *ignore-categories*))                       *ignore-categories*))
360          (return-from next-header (trim line)))))          (return-from next-header (trim line)))))
361    
362    (defun set-locale (locale-des)
363      (setf *locale* (locale-des->locale locale-des)))
364    
365  (defun load-default-locale ()  (defun load-default-locale ()
366    (setf *locale* (get-default-locale)))    (setf *locale* (get-default-locale)))
367    
368  (defun get-default-locale ()  (defun get-default-locale ()
369    (or (locale (getenv "CL_LOCALE") :errorp nil)    (or (locale (getenv "CL_LOCALE") :errorp nil)
370        (locale (getenv "LC_CTYPE") :errorp nil)        (locale (getenv "LC_CTYPE") :errorp nil)
371        (locale "POSIX")))        (locale (getenv "LANG") :errorp nil)
372          (locale "POSIX" :errorp nil)))
373    
374    (load-default-locale)
375    
 ;; EOF  
376    ;; EOF

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

  ViewVC Help
Powered by ViewVC 1.1.5