/[cl-l10n]/cl-l10n/parse-time.lisp
ViewVC logotype

Diff of /cl-l10n/parse-time.lisp

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

revision 1.1 by sross, Wed Mar 30 11:23:56 2005 UTC revision 1.2 by sross, Thu Mar 31 13:53:42 2005 UTC
# Line 13  Line 13 
13  ;;; **********************************************************************  ;;; **********************************************************************
14    
15  ;; This has been borrowed and  slightly modified to be more friendly  ;; This has been borrowed and  slightly modified to be more friendly
16  ;; towards non english time strings and differing locales.  ;; towards non english time strings and locales.
17  ;; Sean Ross 29 March 2005.  ;; Sean Ross 29 March 2005.
18    
19  (in-package :cl-l10n)  (in-package :cl-l10n)
20    
21  (defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))  (defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
22  (defvar time-dividers '(#\: #\.))  (defvar time-dividers '(#\: #\.))
 (defvar date-dividers '(#\\ #\/ #\-))  
23    
24  (defvar *error-on-mismatch* nil  (defvar *error-on-mismatch* nil
25    "If t, an error will be signalled if parse-time is unable    "If t, an error will be signalled if parse-time is unable
# Line 69  Line 68 
68  ;;; year, time-divider, date-divider, am-pm, zone, izone, weekday,  ;;; year, time-divider, date-divider, am-pm, zone, izone, weekday,
69  ;;; noon-midn, and any special symbol.  ;;; noon-midn, and any special symbol.
70    
71  ; TODO (add more linux like dates. eg 3 days ago)  #|
72    
73    
74    
75    |#
76    
77    
78  (defparameter *default-date-time-patterns*  (defparameter *default-date-time-patterns*
79    '(    '(
# Line 88  Line 92 
92      ((noon-midn) month (date-divider) year)      ((noon-midn) month (date-divider) year)
93      ((noon-midn) year (date-divider) month)      ((noon-midn) year (date-divider) month)
94    
      ;; Time formats.  
     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)  
           (date-divider) (zone))  
     (noon-midn)  
     (hour (noon-midn))  
95    
96       ;; Time/date combined formats.   ;; Time/date combined formats.
97    
98      ((weekday) month (date-divider) day (date-divider) year      ((weekday) month (date-divider) day (date-divider) year
99             hour (time-divider) (minute) (time-divider) (secondp)             hour (time-divider) (minute) (time-divider) (secondp)
100             (am-pm) (date-divider) (zone))             (am-pm) (date-divider) (zone))
# Line 131  Line 131 
131      (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)      (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
132            (date-divider) (zone) year (date-divider) month)            (date-divider) (zone) year (date-divider) month)
133    
134    
135         ;; Time formats.
136        (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
137              (date-divider) (zone))
138        (noon-midn)
139        (hour (noon-midn))
140    
141       ;; Weird, non-standard formats.       ;; Weird, non-standard formats.
142      (weekday month day hour (time-divider) minute (time-divider)      (weekday month day hour (time-divider) minute (time-divider)
143               secondp (am-pm)               secondp (am-pm)
# Line 402  Line 409 
409          (let ((test-value (special-string-p substring)))          (let ((test-value (special-string-p substring)))
410            (if test-value  (cons 'special test-value)))            (if test-value  (cons 'special test-value)))
411          (if *error-on-mismatch*          (if *error-on-mismatch*
412              (error "\"~A\" is not a recognized word or abbreviation."              (error 'parser-error
413                     substring)                    :value substring
414                      :reason "Not a recognized word or abbreviation.")
415              (return-from match-substring nil)))))              (return-from match-substring nil)))))
416    
417  ;;; Decompose-string takes the time/date string and decomposes it into a  ;;; Decompose-string takes the time/date string and decomposes it into a
# Line 473  Line 481 
481              (t              (t
482               ;; Unrecognized character - barf voraciously.               ;; Unrecognized character - barf voraciously.
483               (if *error-on-mismatch*               (if *error-on-mismatch*
484                   (error                   (error 'parser-error
485                    'simple-error                          :value string
486                    :format-control "Can't parse time/date string.~%>>> ~A~                          :reason "Can't parse time/date string. Bogus character encountered.")
                                    ~%~VT^-- Bogus character encountered here."  
                   :format-arguments (list string (+ string-index 4)))  
487                   (return-from decompose-string nil)))))))                   (return-from decompose-string nil)))))))
488    
489  ;;; Match-pattern-element tries to match a pattern element with a datum  ;;; Match-pattern-element tries to match a pattern element with a datum
# Line 533  Line 539 
539           (setf (decoded-time-hour parsed-values) 12))           (setf (decoded-time-hour parsed-values) 12))
540          ((eq form-value 'midn)          ((eq form-value 'midn)
541           (setf (decoded-time-hour parsed-values) 0))           (setf (decoded-time-hour parsed-values) 0))
542          (t (error "Unrecognized symbol: ~A" form-value)))          (t (error 'parser-error :value form-value
543                      :reason "Unrecognized symbol.")))
544    (setf (decoded-time-minute parsed-values) 0)    (setf (decoded-time-minute parsed-values) 0)
545    (setf (decoded-time-second parsed-values) 0))    (setf (decoded-time-second parsed-values) 0))
546    
# Line 548  Line 555 
555                    (setf (decoded-time-hour parsed-values) 0))                    (setf (decoded-time-hour parsed-values) 0))
556                   ((not (<= 0 hour 12))                   ((not (<= 0 hour 12))
557                    (if *error-on-mismatch*                    (if *error-on-mismatch*
558                        (error "~D is not an AM hour, dummy." hour)))))                        (error 'parser-error :value hour :reason "Not an AM hour, dummy.")))))
559            ((eq form-value 'pm)            ((eq form-value 'pm)
560             (if (<= 0 hour 11)             (if (<= 0 hour 11)
561                 (setf (decoded-time-hour parsed-values)                 (setf (decoded-time-hour parsed-values)
562                       (mod (+ hour 12) 24))))                       (mod (+ hour 12) 24))))
563            (t (error "~A isn't AM/PM - this shouldn't happen."            (t (error 'parser-error :value form-value :reason "Not an AM/PM - this shouldn't happen."
564                      form-value)))))                      form-value)))))
565    
566  ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.  ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
# Line 582  Line 589 
589          (am-pm (deal-with-am-pm form-value parsed-values))          (am-pm (deal-with-am-pm form-value parsed-values))
590          (noon-midn (deal-with-noon-midn form-value parsed-values))          (noon-midn (deal-with-noon-midn form-value parsed-values))
591          (special (funcall form-value parsed-values))          (special (funcall form-value parsed-values))
592          (t (error "Unrecognized symbol in form list: ~A." form-type))))))          (t (error 'parser-error :value form-type :reason "Unrecognized symbol in form list."))))))
   
 (defun day-element-p (x)  
   (member x '(#\d #\e)))  
   
 (defun month-element-p (x)  
   (char= x #\m))  
593    
 (defun year-element-p (x)  
   (member x '(#\y #\Y)))  
   
 (defun element-type (char)  
   (cond ((day-element-p char) 'day)  
         ((month-element-p char) 'month)  
         ((year-element-p char) 'year)))  
   
 ;; FIXME  
 ;; this effort definitely doesn't cover  
 ;; every single case but it will do for now.  
 (defun locale-date-month-order ()  
   (let ((fmt (locale-d-fmt)))  
     (cond ((string= fmt "%D") '(month day year))  
           ((string= fmt "%F") '(year month day))  
           (t (compute-order fmt)))))  
   
 (defun compute-order (fmt)  
   (let ((res nil))  
     (loop for char across fmt  
           with perc = nil do  
           (cond ((char= char #\%) (setf perc (not perc)))  
                 ((member char date-dividers) nil)  
                 (perc (let ((val (element-type char)))  
                         (when val (push val res))  
                         (setf perc nil)))))  
     (nreverse res)))  
   
 (defun locale-date-pattern ()  
   (let ((order (locale-date-month-order)))  
     (when order  
       (loop for x in order  
             append (list x '(date-divider))))))  
594    
595  (defun default-patterns-p (patterns)  (defun default-patterns-p (patterns)
596    (eq patterns *default-date-time-patterns*))    (eq patterns *default-date-time-patterns*))
# Line 632  Line 600 
600      ;; patterns have not been explicitly specified so we try      ;; patterns have not been explicitly specified so we try
601      ;; to match against locale a specific date pattern first.      ;; to match against locale a specific date pattern first.
602      ;; eg. 03/04/2005 is 3rd April in UK but 4 March in US.      ;; eg. 03/04/2005 is 3rd April in UK but 4 March in US.
603      (let ((res (match-pattern (locale-date-pattern)      (dolist (pattern (parsers *locale*))
604                                string-parts        (let ((res (match-pattern pattern
605                                parts-length)))                                  string-parts
606        (when res                                  parts-length)))
607          (return-from get-matching-pattern res))))          (when res
608              (return-from get-matching-pattern res)))))
609    (dolist (pattern patterns)    (dolist (pattern patterns)
610      (let ((match-result (match-pattern pattern string-parts      (let ((match-result (match-pattern pattern string-parts
611                                         parts-length)))                                         parts-length)))
# Line 652  Line 621 
621                                 (default-month nil) (default-year nil)                                 (default-month nil) (default-year nil)
622                                 (default-zone nil) (default-weekday nil)                                 (default-zone nil) (default-weekday nil)
623                                 (locale *locale*))                                 (locale *locale*))
624    "Tries very hard to make sense out of the argument time-string and    "Tries very hard to make sense out of the argument time-string using
625     returns a single integer representing the universal time if     locale and returns a single integer representing the universal time if
626     successful.  If not, it returns nil.  If the :error-on-mismatch     successful.  If not, it returns nil.  If the :error-on-mismatch
627     keyword is true, parse-time will signal an error instead of     keyword is true, parse-time will signal an error instead of
628     returning nil.  Default values for each part of the time/date     returning nil.  Default values for each part of the time/date
# Line 674  Line 643 
643            (set-time-values string-form parsed-values)            (set-time-values string-form parsed-values)
644            (convert-to-unitime parsed-values))            (convert-to-unitime parsed-values))
645          (if *error-on-mismatch*          (if *error-on-mismatch*
646            (error "\"~A\" is not a recognized time/date format." time-string)              (error 'parser-error :value time-string :reason "Not a recognized time/date format.")
647            nil))))            nil))))
648    
649    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5