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

  ViewVC Help
Powered by ViewVC 1.1.5