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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Mar 30 11:23:56 2005 UTC (9 years ago) by sross
Branch: MAIN
Added parse-time.lisp
1 ;;; **********************************************************************
2 ;;; This code was written as part of the CMU Common Lisp project at
3 ;;; Carnegie Mellon University, and has been placed in the public domain.
4 ;;;
5
6 ;;;
7 ;;; **********************************************************************
8
9 ;;; Parsing routines for time and date strings. Parse-time returns the
10 ;;; universal time integer for the time and/or date given in the string.
11 ;;; Written by Jim Healy, June 1987.
12
13 ;;; **********************************************************************
14
15 ;; This has been borrowed and slightly modified to be more friendly
16 ;; towards non english time strings and differing locales.
17 ;; Sean Ross 29 March 2005.
18
19 (in-package :cl-l10n)
20
21 (defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
22 (defvar time-dividers '(#\: #\.))
23 (defvar date-dividers '(#\\ #\/ #\-))
24
25 (defvar *error-on-mismatch* nil
26 "If t, an error will be signalled if parse-time is unable
27 to determine the time/date format of the string.")
28
29 ;;; Set up hash tables for month, weekday, zone, and special strings.
30 ;;; Provides quick, easy access to associated information for these items.
31
32 ;;; Hashlist takes an association list and hashes each pair into the
33 ;;; specified tables using the car of the pair as the key and the cdr as
34 ;;; the data object.
35
36
37 (defmacro hashlist (list table)
38 `(dolist (item ,list)
39 (setf (gethash (car item) ,table) (cdr item))))
40
41 (defparameter zone-table-size 11)
42 (defparameter special-table-size 11)
43
44 (defvar *zone-strings* (make-hash-table :test #'equal
45 :size zone-table-size))
46
47 (defvar *special-strings* (make-hash-table :test #'equal
48 :size special-table-size))
49
50 ;;; Load-time creation of the hash tables.
51
52 (hashlist '(("gmt" . 0) ("est" . 5)
53 ("edt" . 4) ("cst" . 6)
54 ("cdt" . 5) ("mst" . 7)
55 ("mdt" . 6) ("pst" . 8)
56 ("pdt" . 7) ("utc" . 0))
57 *zone-strings*)
58
59 (hashlist '(("yesterday" . yesterday) ("today" . today)
60 ("tomorrow" . tomorrow) ("now" . now))
61 *special-strings*)
62
63 ;;; Time/date format patterns are specified as lists of symbols repre-
64 ;;; senting the elements. Optional elements can be specified by
65 ;;; enclosing them in parentheses. Note that the order in which the
66 ;;; patterns are specified below determines the order of search.
67
68 ;;; Choices of pattern symbols are: second, minute, hour, day, month,
69 ;;; year, time-divider, date-divider, am-pm, zone, izone, weekday,
70 ;;; noon-midn, and any special symbol.
71
72 ; TODO (add more linux like dates. eg 3 days ago)
73
74 (defparameter *default-date-time-patterns*
75 '(
76 ;; Date formats.
77 ((weekday) month (date-divider) day (date-divider) year (noon-midn))
78 ((weekday) day (date-divider) month (date-divider) year (noon-midn))
79 ((weekday) month (date-divider) day (noon-midn))
80 (year (date-divider) month (date-divider) day (noon-midn))
81 (month (date-divider) year (noon-midn))
82 (year (date-divider) month (noon-midn))
83
84 ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
85 ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
86 ((noon-midn) (weekday) month (date-divider) day)
87 ((noon-midn) year (date-divider) month (date-divider) day)
88 ((noon-midn) month (date-divider) year)
89 ((noon-midn) year (date-divider) month)
90
91 ;; Time formats.
92 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
93 (date-divider) (zone))
94 (noon-midn)
95 (hour (noon-midn))
96
97 ;; Time/date combined formats.
98 ((weekday) month (date-divider) day (date-divider) year
99 hour (time-divider) (minute) (time-divider) (secondp)
100 (am-pm) (date-divider) (zone))
101 ((weekday) day (date-divider) month (date-divider) year
102 hour (time-divider) (minute) (time-divider) (secondp)
103 (am-pm) (date-divider) (zone))
104 ((weekday) month (date-divider) day
105 hour (time-divider) (minute) (time-divider) (secondp)
106 (am-pm) (date-divider) (zone))
107 (year (date-divider) month (date-divider) day
108 hour (time-divider) (minute) (time-divider) (secondp)
109 (am-pm) (date-divider) (zone))
110 (month (date-divider) year
111 hour (time-divider) (minute) (time-divider) (secondp)
112 (am-pm) (date-divider) (zone))
113 (year (date-divider) month
114 hour (time-divider) (minute) (time-divider) (secondp)
115 (am-pm) (date-divider) (zone))
116
117 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
118 (date-divider) (zone) (weekday) month (date-divider)
119 day (date-divider) year)
120 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
121 (date-divider) (zone) (weekday) day (date-divider)
122 month (date-divider) year)
123 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
124 (date-divider) (zone) (weekday) month (date-divider)
125 day)
126 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
127 (date-divider) (zone) year (date-divider) month
128 (date-divider) day)
129 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
130 (date-divider) (zone) month (date-divider) year)
131 (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
132 (date-divider) (zone) year (date-divider) month)
133
134 ;; Weird, non-standard formats.
135 (weekday month day hour (time-divider) minute (time-divider)
136 secondp (am-pm)
137 (zone) year)
138 ((weekday) day (date-divider) month (date-divider) year hour
139 (time-divider) minute (time-divider) (secondp) (am-pm)
140 (date-divider) (zone))
141 ((weekday) month (date-divider) day (date-divider) year hour
142 (time-divider) minute (time-divider) (secondp) (am-pm)
143 (date-divider) (zone))
144
145 ;; Special-string formats.
146 (now (yesterday))
147 ((yesterday) now)
148 (now (today))
149 ((today) now)
150 (now (tomorrow))
151 ((tomorrow) now)
152 (yesterday (noon-midn))
153 ((noon-midn) yesterday)
154 (today (noon-midn))
155 ((noon-midn) today)
156 (tomorrow (noon-midn))
157 ((noon-midn) tomorrow)
158 ))
159
160 ;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C.
161 (defparameter *http-date-time-patterns*
162 '(
163 ;; RFC1123/RFC822 and RFC850.
164 ((weekday) day (date-divider) month (date-divider) year
165 hour time-divider minute (time-divider) (secondp) izone)
166 ((weekday) day (date-divider) month (date-divider) year
167 hour time-divider minute (time-divider) (secondp) (zone))
168
169 ;; ANSI-C.
170 ((weekday) month day
171 hour time-divider minute (time-divider) (secondp) year)))
172
173
174 ;;; The decoded-time structure holds the time/date values which are
175 ;;; eventually passed to 'encode-universal-time' after parsing.
176
177 ;;; Note: Currently nothing is done with the day of the week. It might
178 ;;; be appropriate to add a function to see if it matches the date.
179
180 (defstruct decoded-time
181 (second 0 :type integer) ; Value between 0 and 59.
182 (minute 0 :type integer) ; Value between 0 and 59.
183 (hour 0 :type integer) ; Value between 0 and 23.
184 (day 1 :type integer) ; Value between 1 and 31.
185 (month 1 :type integer) ; Value between 1 and 12.
186 (year 1900 :type integer) ; Value above 1899 or between 0 and 99.
187 (zone 0 :type rational) ; Value between -24 and 24 inclusive.
188 (dotw 0 :type integer)) ; Value between 0 and 6.
189
190 ;;; Make-default-time returns a decoded-time structure with the default
191 ;;; time values already set. The default time is currently 00:00 on
192 ;;; the current day, current month, current year, and current time-zone.
193
194 (defun make-default-time (def-sec def-min def-hour def-day
195 def-mon def-year def-zone def-dotw)
196 (let ((default-time (make-decoded-time)))
197 (multiple-value-bind (sec min hour day mon year dotw dst zone)
198 (get-decoded-time)
199 (declare (ignore dst))
200 (if def-sec
201 (if (eq def-sec :current)
202 (setf (decoded-time-second default-time) sec)
203 (setf (decoded-time-second default-time) def-sec))
204 (setf (decoded-time-second default-time) 0))
205 (if def-min
206 (if (eq def-min :current)
207 (setf (decoded-time-minute default-time) min)
208 (setf (decoded-time-minute default-time) def-min))
209 (setf (decoded-time-minute default-time) 0))
210 (if def-hour
211 (if (eq def-hour :current)
212 (setf (decoded-time-hour default-time) hour)
213 (setf (decoded-time-hour default-time) def-hour))
214 (setf (decoded-time-hour default-time) 0))
215 (if def-day
216 (if (eq def-day :current)
217 (setf (decoded-time-day default-time) day)
218 (setf (decoded-time-day default-time) def-day))
219 (setf (decoded-time-day default-time) day))
220 (if def-mon
221 (if (eq def-mon :current)
222 (setf (decoded-time-month default-time) mon)
223 (setf (decoded-time-month default-time) def-mon))
224 (setf (decoded-time-month default-time) mon))
225 (if def-year
226 (if (eq def-year :current)
227 (setf (decoded-time-year default-time) year)
228 (setf (decoded-time-year default-time) def-year))
229 (setf (decoded-time-year default-time) year))
230 (if def-zone
231 (if (eq def-zone :current)
232 (setf (decoded-time-zone default-time) zone)
233 (setf (decoded-time-zone default-time) def-zone))
234 (setf (decoded-time-zone default-time) zone))
235 (if def-dotw
236 (if (eq def-dotw :current)
237 (setf (decoded-time-dotw default-time) dotw)
238 (setf (decoded-time-dotw default-time) def-dotw))
239 (setf (decoded-time-dotw default-time) dotw))
240 default-time)))
241
242 ;;; Converts the values in the decoded-time structure to universal time
243 ;;; by calling encode-universal-time.
244 ;;; If zone is in numerical form, tweeks it appropriately.
245
246 (defun convert-to-unitime (parsed-values)
247 (let ((zone (decoded-time-zone parsed-values)))
248 (encode-universal-time (decoded-time-second parsed-values)
249 (decoded-time-minute parsed-values)
250 (decoded-time-hour parsed-values)
251 (decoded-time-day parsed-values)
252 (decoded-time-month parsed-values)
253 (decoded-time-year parsed-values)
254 (if (or (> zone 24) (< zone -24))
255 (let ((new-zone (/ zone 100)))
256 (cond ((minusp new-zone) (- new-zone))
257 ((plusp new-zone) (- new-zone))
258 ;; must be zero (GMT)
259 (t new-zone)))
260 zone))))
261
262 ;;; Sets the current values for the time and/or date parts of the
263 ;;; decoded time structure.
264
265 (defun set-current-value (values-structure &key (time nil) (date nil)
266 (zone nil))
267 (multiple-value-bind (sec min hour day mon year dotw dst tz)
268 (get-decoded-time)
269 (declare (ignore dst))
270 (when time
271 (setf (decoded-time-second values-structure) sec)
272 (setf (decoded-time-minute values-structure) min)
273 (setf (decoded-time-hour values-structure) hour))
274 (when date
275 (setf (decoded-time-day values-structure) day)
276 (setf (decoded-time-month values-structure) mon)
277 (setf (decoded-time-year values-structure) year)
278 (setf (decoded-time-dotw values-structure) dotw))
279 (when zone
280 (setf (decoded-time-zone values-structure) tz))))
281
282 ;;; Special function definitions. To define a special substring, add
283 ;;; a dotted pair consisting of the substring and a symbol in the
284 ;;; *special-strings* hashlist statement above. Then define a function
285 ;;; here which takes one argument- the decoded time structure- and
286 ;;; sets the values of the structure to whatever is necessary. Also,
287 ;;; add a some patterns to the patterns list using whatever combinations
288 ;;; of special and pre-existing symbols desired.
289
290 (defun yesterday (parsed-values)
291 (set-current-value parsed-values :date t :zone t)
292 (setf (decoded-time-day parsed-values)
293 (1- (decoded-time-day parsed-values))))
294
295 (defun today (parsed-values)
296 (set-current-value parsed-values :date t :zone t))
297
298 (defun tomorrow (parsed-values)
299 (set-current-value parsed-values :date t :zone t)
300 (setf (decoded-time-day parsed-values)
301 (1+ (decoded-time-day parsed-values))))
302
303 (defun now (parsed-values)
304 (set-current-value parsed-values :time t))
305
306 ;;; Predicates for symbols. Each symbol has a corresponding function
307 ;;; defined here which is applied to a part of the datum to see if
308 ;;; it matches the qualifications.
309
310 (defun am-pm (string)
311 (let ((am-pm (locale-am-pm)))
312 (and (simple-string-p string)
313 (cond ((string-equal string (car am-pm)) 'am)
314 ((string-equal string (cadr am-pm)) 'pm)
315 ((string-equal string "am") 'am)
316 ((string-equal string "pm") 'pm)
317 (t nil)))))
318
319 (defun noon-midn (string)
320 (and (simple-string-p string)
321 (cond ((string= string "noon") 'noon)
322 ((string= string "midnight") 'midn)
323 (t nil))))
324
325 (defun weekday (string)
326 (when (stringp string)
327 (let ((pos (or (position string (locale-day) :test 'string-equal)
328 (position string (locale-abday) :test 'string-equal))))
329 (when pos
330 (decf pos)
331 (if (< pos 0)
332 (incf pos 7)
333 pos)))))
334
335 (defun month (thing)
336 (or (and (stringp thing)
337 (let ((pos (or (position thing (locale-mon) :test 'string-equal)
338 (position thing (locale-abmon) :test 'string-equal))))
339 (when pos
340 (1+ pos))))
341 (and (integerp thing) (<= 1 thing 12))))
342
343 (defun zone (thing)
344 (or (and (simple-string-p thing) (gethash thing *zone-strings*))
345 (if (integerp thing)
346 (let ((zone (/ thing 100)))
347 (and (integerp zone) (<= -24 zone 24))))))
348
349 ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
350 (defun izone (thing)
351 (if (integerp thing)
352 (multiple-value-bind (hours mins)
353 (truncate thing 100)
354 (and (<= -24 hours 24) (<= -59 mins 59)))))
355
356 (defun special-string-p (string)
357 (and (simple-string-p string) (gethash string *special-strings*)))
358
359 (defun secondp (number)
360 (and (integerp number) (<= 0 number 59)))
361
362 (defun minute (number)
363 (and (integerp number) (<= 0 number 59)))
364
365 (defun hour (number)
366 (and (integerp number) (<= 0 number 23)))
367
368 (defun day (number)
369 (and (integerp number) (<= 1 number 31)))
370
371 (defun year (number)
372 (and (integerp number)
373 (or (<= 0 number 99)
374 (<= 1900 number))))
375
376 (defun time-divider (character)
377 (and (characterp character)
378 (member character time-dividers :test #'char=)))
379
380 (defun date-divider (character)
381 (and (characterp character)
382 (member character date-dividers :test #'char=)))
383
384 ;;; Match-substring takes a string argument and tries to match it with
385 ;;; the strings in one of the four hash tables: *weekday-strings*, *month-
386 ;;; strings*, *zone-strings*, *special-strings*. It returns a specific
387 ;;; keyword and/or the object it finds in the hash table. If no match
388 ;;; is made then it immediately signals an error.
389
390 (defun match-substring (substring)
391 (let ((substring (nstring-downcase substring)))
392 (or (let ((test-value (month substring)))
393 (if test-value (cons 'month test-value)))
394 (let ((test-value (weekday substring)))
395 (if test-value (cons 'weekday test-value)))
396 (let ((test-value (am-pm substring)))
397 (if test-value (cons 'am-pm test-value)))
398 (let ((test-value (noon-midn substring)))
399 (if test-value (cons 'noon-midn test-value)))
400 (let ((test-value (zone substring)))
401 (if test-value (cons 'zone test-value)))
402 (let ((test-value (special-string-p substring)))
403 (if test-value (cons 'special test-value)))
404 (if *error-on-mismatch*
405 (error "\"~A\" is not a recognized word or abbreviation."
406 substring)
407 (return-from match-substring nil)))))
408
409 ;;; Decompose-string takes the time/date string and decomposes it into a
410 ;;; list of alphabetic substrings, numbers, and special divider characters.
411 ;;; It matches whatever strings it can and replaces them with a dotted pair
412 ;;; containing a symbol and value.
413
414 (defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
415 (do ((string-index start)
416 (next-negative nil)
417 (parts-list nil))
418 ((eq string-index end) (nreverse parts-list))
419 (let ((next-char (char string string-index))
420 (prev-char (if (= string-index start)
421 nil
422 (char string (1- string-index)))))
423 (cond ((alpha-char-p next-char)
424 ;; Alphabetic character - scan to the end of the substring.
425 (do ((scan-index (1+ string-index) (1+ scan-index)))
426 ((or (eq scan-index end)
427 (not (alpha-char-p (char string scan-index))))
428 (let ((match-symbol (match-substring
429 (subseq string string-index scan-index))))
430 (if match-symbol
431 (push match-symbol parts-list)
432 (return-from decompose-string nil)))
433 (setf string-index scan-index))))
434 ((digit-char-p next-char radix)
435 ;; Numeric digit - convert digit-string to a decimal value.
436 (do ((scan-index string-index (1+ scan-index))
437 (numeric-value 0 (+ (* numeric-value radix)
438 (digit-char-p (char string scan-index) radix))))
439 ((or (eq scan-index end)
440 (not (digit-char-p (char string scan-index) radix)))
441 ;; If next-negative is t, set the numeric value to it's
442 ;; opposite and reset next-negative to nil.
443 (when next-negative
444 (setf next-negative nil)
445 (setf numeric-value (- numeric-value)))
446 (push numeric-value parts-list)
447 (setf string-index scan-index))))
448 ((and (member next-char '(#\+ #\-) :test #'char=)
449 (or (not prev-char)
450 (member prev-char whitespace-chars :test #'char=)))
451 ;; If we see a minus or plus sign before a number, but
452 ;; not after one, it is not a date divider, but a offset
453 ;; from GMT, so set next-negative to t if minus and continue.
454 (setq next-negative (char= next-char #\-))
455 (incf string-index))
456 ((member next-char time-dividers :test #'char=)
457 ;; Time-divider - add it to the parts-list with symbol.
458 (push (cons 'time-divider next-char) parts-list)
459 (incf string-index))
460 ((member next-char date-dividers :test #'char=)
461 ;; Date-divider - add it to the parts-list with symbol.
462 (push (cons 'date-divider next-char) parts-list)
463 (incf string-index))
464 ((member next-char whitespace-chars :test #'char=)
465 ;; Whitespace character - ignore it completely.
466 (incf string-index))
467 ((char= next-char #\()
468 ;; Parenthesized string - scan to the end and ignore it.
469 (do ((scan-index string-index (1+ scan-index)))
470 ((or (eq scan-index end)
471 (char= (char string scan-index) #\)))
472 (setf string-index (1+ scan-index)))))
473 (t
474 ;; Unrecognized character - barf voraciously.
475 (if *error-on-mismatch*
476 (error
477 'simple-error
478 :format-control "Can't parse time/date string.~%>>> ~A~
479 ~%~VT^-- Bogus character encountered here."
480 :format-arguments (list string (+ string-index 4)))
481 (return-from decompose-string nil)))))))
482
483 ;;; Match-pattern-element tries to match a pattern element with a datum
484 ;;; element and returns the symbol associated with the datum element if
485 ;;; successful. Otherwise nil is returned.
486
487 (defun match-pattern-element (pattern-element datum-element)
488 (cond ((listp datum-element)
489 (let ((datum-type (if (eq (car datum-element) 'special)
490 (cdr datum-element)
491 (car datum-element))))
492 (if (eq datum-type pattern-element) datum-element)))
493 ((funcall pattern-element datum-element)
494 (cons pattern-element datum-element))
495 (t nil)))
496
497 ;;; Match-pattern matches a pattern against a datum, returning the
498 ;;; pattern if successful and nil otherwise.
499
500 (defun match-pattern (pattern datum datum-length)
501 (if (>= (length pattern) datum-length)
502 (let ((form-list nil))
503 (do ((pattern pattern (cdr pattern))
504 (datum datum (cdr datum)))
505 ((or (null pattern) (null datum))
506 (cond ((and (null pattern) (null datum))
507 (nreverse form-list))
508 ((null pattern) nil)
509 ((null datum) (dolist (element pattern
510 (nreverse form-list))
511 (if (not (listp element))
512 (return nil))))))
513 (let* ((pattern-element (car pattern))
514 (datum-element (car datum))
515 (optional (listp pattern-element))
516 (matching (match-pattern-element (if optional
517 (car pattern-element)
518 pattern-element)
519 datum-element)))
520 (cond (matching (let ((form-type (car matching)))
521 (unless (or (eq form-type 'time-divider)
522 (eq form-type 'date-divider))
523 (push matching form-list))))
524 (optional (push datum-element datum))
525 (t (return-from match-pattern nil))))))))
526
527 ;;; Deal-with-noon-midn sets the decoded-time values to either noon
528 ;;; or midnight depending on the argument form-value. Form-value
529 ;;; can be either 'noon or 'midn.
530
531 (defun deal-with-noon-midn (form-value parsed-values)
532 (cond ((eq form-value 'noon)
533 (setf (decoded-time-hour parsed-values) 12))
534 ((eq form-value 'midn)
535 (setf (decoded-time-hour parsed-values) 0))
536 (t (error "Unrecognized symbol: ~A" form-value)))
537 (setf (decoded-time-minute parsed-values) 0)
538 (setf (decoded-time-second parsed-values) 0))
539
540 ;;; Deal-with-am-pm sets the decoded-time values to be in the am
541 ;;; or pm depending on the argument form-value. Form-value can
542 ;;; be either 'am or 'pm.
543
544 (defun deal-with-am-pm (form-value parsed-values)
545 (let ((hour (decoded-time-hour parsed-values)))
546 (cond ((eq form-value 'am)
547 (cond ((eq hour 12)
548 (setf (decoded-time-hour parsed-values) 0))
549 ((not (<= 0 hour 12))
550 (if *error-on-mismatch*
551 (error "~D is not an AM hour, dummy." hour)))))
552 ((eq form-value 'pm)
553 (if (<= 0 hour 11)
554 (setf (decoded-time-hour parsed-values)
555 (mod (+ hour 12) 24))))
556 (t (error "~A isn't AM/PM - this shouldn't happen."
557 form-value)))))
558
559 ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
560 (defun deal-with-izone (form-value parsed-values)
561 (multiple-value-bind (hours mins)
562 (truncate form-value 100)
563 (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60))))))
564
565 ;;; Set-time-values uses the association list of symbols and values
566 ;;; to set the time in the decoded-time structure.
567
568 (defun set-time-values (string-form parsed-values)
569 (dolist (form-part string-form t)
570 (let ((form-type (car form-part))
571 (form-value (cdr form-part)))
572 (case form-type
573 (secondp (setf (decoded-time-second parsed-values) form-value))
574 (minute (setf (decoded-time-minute parsed-values) form-value))
575 (hour (setf (decoded-time-hour parsed-values) form-value))
576 (day (setf (decoded-time-day parsed-values) form-value))
577 (month (setf (decoded-time-month parsed-values) form-value))
578 (year (setf (decoded-time-year parsed-values) form-value))
579 (zone (setf (decoded-time-zone parsed-values) form-value))
580 (izone (deal-with-izone form-value parsed-values))
581 (weekday (setf (decoded-time-dotw parsed-values) form-value))
582 (am-pm (deal-with-am-pm form-value parsed-values))
583 (noon-midn (deal-with-noon-midn form-value parsed-values))
584 (special (funcall form-value parsed-values))
585 (t (error "Unrecognized symbol in form list: ~A." form-type))))))
586
587 (defun day-element-p (x)
588 (member x '(#\d #\e)))
589
590 (defun month-element-p (x)
591 (char= x #\m))
592
593 (defun year-element-p (x)
594 (member x '(#\y #\Y)))
595
596 (defun element-type (char)
597 (cond ((day-element-p char) 'day)
598 ((month-element-p char) 'month)
599 ((year-element-p char) 'year)))
600
601 ;; FIXME
602 ;; this effort definitely doesn't cover
603 ;; every single case but it will do for now.
604 (defun locale-date-month-order ()
605 (let ((fmt (locale-d-fmt)))
606 (cond ((string= fmt "%D") '(month day year))
607 ((string= fmt "%F") '(year month day))
608 (t (compute-order fmt)))))
609
610 (defun compute-order (fmt)
611 (let ((res nil))
612 (loop for char across fmt
613 with perc = nil do
614 (cond ((char= char #\%) (setf perc (not perc)))
615 ((member char date-dividers) nil)
616 (perc (let ((val (element-type char)))
617 (when val (push val res))
618 (setf perc nil)))))
619 (nreverse res)))
620
621 (defun locale-date-pattern ()
622 (let ((order (locale-date-month-order)))
623 (when order
624 (loop for x in order
625 append (list x '(date-divider))))))
626
627 (defun default-patterns-p (patterns)
628 (eq patterns *default-date-time-patterns*))
629
630 (defun get-matching-pattern (patterns string-parts parts-length)
631 (when (default-patterns-p patterns)
632 ;; patterns have not been explicitly specified so we try
633 ;; to match against locale a specific date pattern first.
634 ;; eg. 03/04/2005 is 3rd April in UK but 4 March in US.
635 (let ((res (match-pattern (locale-date-pattern)
636 string-parts
637 parts-length)))
638 (when res
639 (return-from get-matching-pattern res))))
640 (dolist (pattern patterns)
641 (let ((match-result (match-pattern pattern string-parts
642 parts-length)))
643 (when match-result
644 (return match-result)))))
645
646
647 (defun parse-time (time-string &key (start 0) (end (length time-string))
648 (error-on-mismatch nil)
649 (patterns *default-date-time-patterns*)
650 (default-seconds nil) (default-minutes nil)
651 (default-hours nil) (default-day nil)
652 (default-month nil) (default-year nil)
653 (default-zone nil) (default-weekday nil)
654 (locale *locale*))
655 "Tries very hard to make sense out of the argument time-string and
656 returns a single integer representing the universal time if
657 successful. If not, it returns nil. If the :error-on-mismatch
658 keyword is true, parse-time will signal an error instead of
659 returning nil. Default values for each part of the time/date
660 can be specified by the appropriate :default- keyword. These
661 keywords can be given a numeric value or the keyword :current
662 to set them to the current value. The default-default values
663 are 00:00:00 on the current date, current time-zone."
664 (let* ((*error-on-mismatch* error-on-mismatch)
665 (*locale* (locale-des->locale locale))
666 (string-parts (decompose-string time-string :start start :end end))
667 (parts-length (length string-parts))
668 (string-form (get-matching-pattern patterns string-parts parts-length)))
669 (if string-form
670 (let ((parsed-values (make-default-time default-seconds default-minutes
671 default-hours default-day
672 default-month default-year
673 default-zone default-weekday)))
674 (set-time-values string-form parsed-values)
675 (convert-to-unitime parsed-values))
676 (if *error-on-mismatch*
677 (error "\"~A\" is not a recognized time/date format." time-string)
678 nil))))
679
680
681 ; EOF

  ViewVC Help
Powered by ViewVC 1.1.5