source: project/release/3/srfi-19/trunk/srfi-19-io.scm @ 12029

Last change on this file since 12029 was 12029, checked in by Kon Lovett, 13 years ago

Save.

File size: 24.9 KB
Line 
1;;;; srfi-19-io.scm
2;;;; Chicken port, Kon Lovett, Dec '05
3
4;; SRFI-19: Time Data Types and Procedures.
5;;
6;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
7;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
8;;
9;; This document and translations of it may be copied and furnished to others,
10;; and derivative works that comment on or otherwise explain it or assist in its
11;; implementation may be prepared, copied, published and distributed, in whole or
12;; in part, without restriction of any kind, provided that the above copyright
13;; notice and this paragraph are included on all such copies and derivative works.
14;; However, this document itself may not be modified in any way, such as by
15;; removing the copyright notice or references to the Scheme Request For
16;; Implementation process or editors, except as needed for the purpose of
17;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
18;; process must be followed, or as required to translate it into languages other
19;; than English.
20;;
21;; The limited permissions granted above are perpetual and will not be revoked
22;; by the authors or their successors or assigns.
23;;
24;; This document and the information contained herein is provided on an "AS IS"
25;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
26;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
27;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
28;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
29
30(eval-when (compile)
31  (declare
32    (not usual-integrations
33      + - * /
34      remainder quotient modulo
35      expt
36      abs
37      round floor truncate
38      number? integer? inexact?
39      zero? negative? positive?
40      = <= >= < >
41      inexact->exact exact->inexact
42      char-alphabetic? char-numeric?
43      number->string string->number
44      string-length string-append
45      string->list list->string)
46    (inline)
47    (generic)
48    (no-procedure-checks)
49    (no-bound-checks)
50    (export
51      ;; SRFI-19 extensions
52      format-date
53      scan-date
54      ;; SRFI-19
55      date->string
56      string->date) ) )
57
58(use srfi-1 srfi-13
59     srfi-29 locale numbers
60     srfi-19-core)
61
62;;;
63
64(include "srfi-19-common")
65
66;;;
67
68;; -- Locale bundle item keys
69
70(define LOCALE-NUMBER-SEPARATOR 'separator)
71
72(define LOCALE-ABRV-WEEKDAYS '#(sun mon tue wed thu fri sat))
73(define LOCALE-LONG-WEEKDAYS '#(sunday monday tuesday wednesday thursday friday saturday))
74(define LOCALE-ABRV-MONTHS '#(|| jan feb mar apr may jun jul aug sep oct nov dec))
75(define LOCALE-LONG-MONTHS '#(|| january february march april may june july august september october november december))
76
77(define LOCALE-PM 'pm)
78(define LOCALE-AM 'am)
79
80;; See date->string
81
82(define LOCALE-DATE-TIME-FORMAT 'date-time)
83(define LOCALE-SHORT-DATE-FORMAT 'date)
84(define LOCALE-TIME-FORMAT 'time)
85
86;; SRFI-29: Localization initialization
87
88(reset-locale-parameters)
89(load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))
90
91(define-inline (item@ key)
92  (localized-template/default 'srfi-19 key) )
93
94;;; Date & Time Formatted I/O
95
96;; Given a 'two digit' number, find the year within 50 years +/-
97
98(define (tm:natural-year n)
99  (let* ([current-year (date-year (current-date))]
100         [current-century (fx* (fx/ current-year 100) 100)])
101    (cond
102      [(fx>= n 100)
103        n]
104      [(fx< n 0)
105        n]
106      [(fx<= (fx- (fx+ current-century n) current-year) 50)
107        (fx+ current-century n)]
108      [else
109        (fx+ (fx- current-century 100) n)]) ) )
110
111;; Return a string representing the decimal expansion of the fractional
112;; portion of a number, limited by a specified precision
113
114(define (tm:decimal-expansion r precision)
115  (let loop ([num (- r (round r))]
116             [p precision]
117             [lst '()])
118    (if (or (fx= 0 p) (zero? num))
119      (apply string-append (reverse! lst))
120      (let* ([num-times-10 (* 10 num)]
121             [round-num-times-10 (round num-times-10)])
122        (loop (- num-times-10 round-num-times-10)
123              (fx- p 1)
124              (cons (number->string (inexact->exact round-num-times-10))
125                    lst)) ) ) ) )
126
127;; Returns a string rep. of number N, of minimum LENGTH,
128;; padded with character PAD-WITH. If PAD-WITH if #f,
129;; no padding is done, and it's as if number->string was used.
130;; if string is longer than LENGTH, it's as if number->string was used.
131
132(define (tm:padding n pad-with length)
133  (let* ([str (number->string n)]
134         [len (string-length str)])
135    (let ((str (if (and (fx>= len 2)
136                        (char=? #\. (string-ref str (fx- len 2)))
137                        (char=? #\0 (string-ref str (fx- len 1))) )
138               (substring str 0 (fx- len 2))
139               str) ) )
140      (if (or (not pad-with) (> len length))
141        str
142        (string-pad str length pad-with)) ) ) )
143
144(define (tm:last-n-digits i n)
145  (abs (remainder i (expt 10 n))) )
146
147(define (tm:locale-abbr-weekday n)
148  (item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)) )
149
150(define (tm:locale-long-weekday n)
151  (item@ (vector-ref LOCALE-LONG-WEEKDAYS n)) )
152
153(define (tm:locale-abbr-month n)
154  (item@ (vector-ref LOCALE-ABRV-MONTHS n)) )
155
156(define (tm:locale-long-month n)
157  (item@ (vector-ref LOCALE-LONG-MONTHS n)) )
158
159(define (tm:locale-find-string str vec)
160  (let loop ([idx (fx- (vector-length vec) 1)])
161    (and (fx<= 0 idx)
162         (or (and (string=? str (item@ (vector-ref vec idx))) idx)
163             (loop (fx- idx 1))) ) ) )
164
165(define (tm:locale-abbr-weekday->index str)
166  (tm:locale-find-string str LOCALE-ABRV-WEEKDAYS) )
167
168(define (tm:locale-long-weekday->index str)
169  (tm:locale-find-string str LOCALE-LONG-WEEKDAYS) )
170
171(define (tm:locale-abbr-month->index str)
172  (tm:locale-find-string str LOCALE-ABRV-MONTHS) )
173
174(define (tm:locale-long-month->index str)
175  (tm:locale-find-string str LOCALE-LONG-MONTHS) )
176
177;; There is no unique way to map a timezone offset to a political timezone!
178
179(define (tm:locale-print-time-zone date port)
180  (when (date-zone-name date)
181    (display (date-zone-name date) port)) )
182
183;; Again, locale specific.
184
185(define (tm:locale-am/pm hr)
186  (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)) )
187
188(define (tm:tz-printer offset port)
189  (if (= offset 0)
190    (display "Z" port)
191    (let ((isneg (fx< offset 0)))
192      (display (if isneg #\- #\+) port)
193      (let ([offset (if isneg (fxneg offset) offset)])
194        (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
195        (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
196
197;; A table of output formatting directives.
198;; the first time is the format char.
199;; the second is a procedure that takes the date, a padding character
200;; (which might be #f), and the output port.
201
202(define tm:display-directives
203  (list
204    (cons #\~
205      (lambda (date pad-with port)
206        (display #\~ port)))
207
208    (cons #\a
209      (lambda (date pad-with port)
210        (display (tm:locale-abbr-weekday (date-week-day date)) port)))
211
212    (cons #\A
213      (lambda (date pad-with port)
214        (display (tm:locale-long-weekday (date-week-day date)) port)))
215
216    (cons #\b
217      (lambda (date pad-with port)
218        (display (tm:locale-abbr-month (date-month date)) port)))
219
220    (cons #\B
221      (lambda (date pad-with port)
222        (display (tm:locale-long-month (date-month date)) port)))
223
224    (cons #\c
225      (lambda (date pad-with port)
226        (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port)))
227
228    (cons #\d
229      (lambda (date pad-with port)
230        (display (tm:padding (date-day date) #\0 2) port)))
231
232    (cons #\D
233      (lambda (date pad-with port)
234        (display (date->string date "~m/~d/~y") port)))
235
236    (cons #\e
237      (lambda (date pad-with port)
238        (display (tm:padding (date-day date) #\space 2) port)))
239
240    (cons #\f
241      (lambda (date pad-with port)
242        (let ([ns (date-nanosecond date)] [sec (date-second date)])
243          (if (> ns NS/S) ; This shouldn't happen!
244            (display (tm:padding (+ sec 1) pad-with 2) port)
245            (display (tm:padding sec pad-with 2) port))
246          (let ([f (tm:decimal-expansion (/ ns NS/S) 6)])
247            (when (fx> (string-length f) 0)
248              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
249              (display f port))))))
250
251    (cons #\h
252      (lambda (date pad-with port)
253        (display (date->string date "~b") port)))
254
255    (cons #\H
256      (lambda (date pad-with port)
257        (display (tm:padding (date-hour date) pad-with 2) port)))
258
259    (cons #\I
260      (lambda (date pad-with port)
261        (let ([hr (date-hour date)])
262          (if (fx> hr 12)
263            (display (tm:padding (fx- hr 12) pad-with 2) port)
264            (display (tm:padding hr pad-with 2) port)))))
265
266    (cons #\j
267      (lambda (date pad-with port)
268        (display (tm:padding (date-year-day date) pad-with 3) port)))
269
270    (cons #\k
271      (lambda (date pad-with port)
272        (display (tm:padding (date-hour date) #\space 2) port)))
273
274    (cons #\l
275      (lambda (date pad-with port)
276        (let ([hr (date-hour date)])
277          (display (tm:padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
278
279    (cons #\m
280      (lambda (date pad-with port)
281        (display (tm:padding (date-month date) pad-with 2) port)))
282
283    (cons #\M
284      (lambda (date pad-with port)
285        (display (tm:padding (date-minute date) pad-with 2) port)))
286
287    (cons #\n
288      (lambda (date pad-with port)
289        (newline port)))
290
291    (cons #\N
292      (lambda (date pad-with port)
293        (display (tm:padding (date-nanosecond date) pad-with 7) port)))
294
295    (cons #\p
296      (lambda (date pad-with port)
297        (display (tm:locale-am/pm (date-hour date)) port)))
298
299    (cons #\r
300      (lambda (date pad-with port)
301        (display (date->string date "~I:~M:~S ~p") port)))
302
303    (cons #\s
304      (lambda (date pad-with port)
305        (display (time-second (date->time-utc date)) port)))
306
307    (cons #\S
308      (lambda (date pad-with port)
309        (let ([sec (date-second date)])
310          (if (> (date-nanosecond date) NS/S) ; This shouldn't happen!
311            (display (tm:padding (+ sec 1) pad-with 2) port)
312            (display (tm:padding sec pad-with 2) port)))))
313
314    (cons #\t
315      (lambda (date pad-with port)
316        (display #\tab port)))
317
318    (cons #\T
319      (lambda (date pad-with port)
320        (display (date->string date "~H:~M:~S") port)))
321
322    (cons #\U
323      (lambda (date pad-with port)
324        (let ([wkno (date-week-number date 0)])
325          (if (fx> (tm:days-before-first-week date 0) 0)
326            (display (tm:padding (fx+ wkno 1) #\0 2) port)
327            (display (tm:padding wkno #\0 2) port)))))
328
329    (cons #\V
330      (lambda (date pad-with port)
331        (display (tm:padding (date-week-number date 1) #\0 2) port)))
332
333    (cons #\w
334      (lambda (date pad-with port)
335        (display (date-week-day date) port)))
336
337    (cons #\W
338      (lambda (date pad-with port)
339        (let ([wkno (date-week-number date 1)])
340          (if (fx> (tm:days-before-first-week date 1) 0)
341            (display (tm:padding (fx+ wkno 1) #\0 2) port)
342            (display (tm:padding wkno #\0 2) port)))))
343
344    (cons #\x
345      (lambda (date pad-with port)
346        (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port)))
347
348    (cons #\X
349      (lambda (date pad-with port)
350        (display (date->string date (item@ LOCALE-TIME-FORMAT)) port)))
351
352    (cons #\y
353      (lambda (date pad-with port)
354        (display
355          (tm:padding (tm:last-n-digits (date-year date) 2) pad-with 2) port)))
356
357    (cons #\Y
358      (lambda (date pad-with port)
359        (display (date-year date) port)))
360
361    (cons #\z
362      (lambda (date pad-with port)
363        (tm:tz-printer (date-zone-offset date) port)))
364
365    (cons #\Z
366      (lambda (date pad-with port)
367        (tm:locale-print-time-zone date port)))
368
369    (cons #\1
370      (lambda (date pad-with port)
371        (display (date->string date "~Y-~m-~d") port)))
372
373    (cons #\2
374      (lambda (date pad-with port)
375        (display (date->string date "~H:~M:~S~z") port)))
376
377    (cons #\3
378      (lambda (date pad-with port)
379        (display (date->string date "~H:~M:~S") port)))
380
381    (cons #\4
382      (lambda (date pad-with port)
383        (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
384
385    (cons #\5
386      (lambda (date pad-with port)
387        (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) ) )
388
389(define (tm:date-printer loc date format-rem len-rem port)
390  (when (fx< 0 len-rem)
391    (let ([current-char
392            (car format-rem)]
393          [get-formatter
394            (lambda (char)
395              (and-let* ([associated (assoc char tm:display-directives)])
396                (cdr associated)))])
397      (cond
398        [(not (char=? current-char #\~))
399          (display current-char port)
400          (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port)]
401        [(fx< len-rem 2)
402          (error loc "bad date format" (list->string format-rem))]
403        [else
404          (let ([pad-ch (cadr format-rem)])
405            (cond
406              [(char=? pad-ch #\-)
407                (if (fx< len-rem 3)
408                  (error loc "bad date format" (list->string format-rem))
409                  (let ([formatter (get-formatter (caddr format-rem))])
410                    (if (not formatter)
411                      (error loc "bad date format" (list->string format-rem))
412                      (begin
413                        (formatter date #f port)
414                        (tm:date-printer loc date (cdddr format-rem)
415                                         (fx- len-rem 3) port)))))]
416              [(char=? pad-ch #\_)
417                (if (fx< len-rem 3)
418                  (error loc "bad date format" (list->string format-rem))
419                  (let ([formatter (get-formatter (caddr format-rem))])
420                    (if (not formatter)
421                      (error loc "bad date format" (list->string format-rem))
422                      (begin
423                        (formatter date #\space port)
424                        (tm:date-printer loc date (cdddr format-rem)
425                                         (fx- len-rem 3) port)))))]
426              [else
427                (let ([formatter (get-formatter pad-ch)])
428                  (if (not formatter)
429                    (error loc "bad date format" (list->string format-rem))
430                    (begin
431                      (formatter date #\0 port)
432                      (tm:date-printer loc date (cddr format-rem)
433                                       (fx- len-rem 2) port))))]))]) )) )
434
435(define (format-date dest fmt-str . r)
436  (let ([port #f] [date (optional r #f)])
437    (cond
438      [(not dest)
439        (set! port (open-output-string))]
440      [(string? dest)
441        (set! date fmt-str)
442        (set! fmt-str dest)
443        (set! port (open-output-string))]
444      [(number? dest)
445        (set! port (current-error-port))]
446      [(port? dest)
447        (set! port dest)]
448      [else
449        (set! port (current-output-port))])
450    (tm:date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port)
451    (or dest
452        (not (string? dest)))
453        (get-output-string port) ) )
454
455(define (date->string date . format-string)
456  (format-date (optional format-string "~c") date))
457
458;;; Input
459
460(define (tm:char->int ch)
461  (switch ch
462    [#\0 0]
463    [#\1 1]
464    [#\2 2]
465    [#\3 3]
466    [#\4 4]
467    [#\5 5]
468    [#\6 6]
469    [#\7 7]
470    [#\8 8]
471    [#\9 9]
472    [else (error 'date-read "bad date template: non-integer character" ch)]) )
473
474;; read an integer upto n characters long on port;
475;; upto -> #f if any length
476
477(define (tm:integer-reader upto port)
478  (let loop ([accum 0] [nchars 0])
479    (let ([ch (peek-char port)])
480      (if (or (eof-object? ch)
481              (not (char-numeric? ch))
482              (and upto (fx>= nchars upto)))
483        accum
484        (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))) ) ) )
485
486(define (tm:make-integer-reader upto)
487  (lambda (port)
488    (tm:integer-reader upto port)) )
489
490;; read *exactly* n characters and convert to integer; could be padded
491
492(define (tm:integer-reader-exact n port)
493  (let ([padding-ok #t])
494    (let loop ([accum 0] [nchars 0])
495      (let ([ch (peek-char port)])
496        (cond
497          [(fx>= nchars n)
498            accum]
499          [(eof-object? ch)
500            (error 'string->date "bad date template: premature ending to integer read")]
501          [(char-numeric? ch)
502            (set! padding-ok #f)
503            (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))]
504          [padding-ok
505            (read-char port)    ; consume padding
506            (loop accum (fx+ nchars 1))]
507          [else                 ; padding where it shouldn't be
508            (error 'string->date "bad date template: non-numeric characters in integer read")]) ) ) ) )
509
510(define (tm:make-integer-exact-reader n)
511  (lambda (port)
512    (tm:integer-reader-exact n port)) )
513
514(define (tm:zone-reader port)
515  (let ([offset 0] [is-pos #t])
516    (let ([ch (read-char port)])
517      (when (eof-object? ch)
518        (error 'string->date "bad date template: invalid time zone +/-"))
519      (if (or (char=? ch #\Z) (char=? ch #\z))
520        0
521        (begin
522          (cond
523            [(char=? ch #\+) (set! is-pos #t)]
524            [(char=? ch #\-) (set! is-pos #f)]
525            [else
526              (error 'string->date "bad date template: invalid time zone +/-" ch)])
527          (let ([ch (read-char port)])
528            (when (eof-object? ch)
529              (error 'string->date "bad date template: invalid time zone number"))
530            (set! offset (fx* (tm:char->int ch) (fx* 10 SEC/HR))))
531          ;; non-existing values are considered zero
532          (let ([ch (read-char port)])
533            (unless (eof-object? ch)
534              (set! offset (fx+ offset (fx* (tm:char->int ch) SEC/HR)))))
535          (let ([ch (read-char port)])
536            (unless (eof-object? ch)
537              (set! offset (fx+ offset (fx* (tm:char->int ch) 600)))))
538          (let ([ch (read-char port)])
539            (unless (eof-object? ch)
540              (set! offset (fx+ offset (fx* (tm:char->int ch) 60)))))
541          (if is-pos offset (fxneg offset)))) ) ) )
542
543;; Looking at a char, read the char string, run thru indexer, return index
544
545(define (tm:locale-reader port indexer)
546  (letrec (
547    [read-char-string
548      (lambda ()
549        (let ([ch (peek-char port)])
550          (when (char-alphabetic? ch)
551            (write-char (read-char port))
552            (read-char-string)) ) )])
553    (let* ([str (with-output-to-string read-char-string)]
554           [index (indexer str)])
555      (unless index
556        (error 'string->date "bad date template: invalid string for indexer" str))
557      index ) ) )
558
559(define (tm:make-locale-reader indexer)
560  (lambda (port)
561    (tm:locale-reader port indexer)) )
562
563(define (tm:make-char-id-reader char)
564  (lambda (port)
565    (if (char=? char (read-char port))
566      char
567      (error 'string->date "bad date template: invalid character match"))) )
568
569;; A List of formatted read directives.
570;; Each entry is a list.
571;; 1. the character directive;
572;; a procedure, which takes a character as input & returns
573;; 2. #t as soon as a character on the input port is acceptable
574;; for input,
575;; 3. a port reader procedure that knows how to read the current port
576;; for a value. Its one parameter is the port.
577;; 4. a action procedure, that takes the value (from 3.) and some
578;; object (here, always the date) and (probably) side-effects it.
579;; In some cases (e.g., ~A) the action is to do nothing
580
581(define tm:read-directives
582  (let ([ireader4 (tm:make-integer-reader 4)]
583        [ireader2 (tm:make-integer-reader 2)]
584        [ireader7 (tm:make-integer-reader 7)]
585        [ireaderf (tm:make-integer-reader #f)]
586        [eireader2 (tm:make-integer-exact-reader 2)]
587        [eireader4 (tm:make-integer-exact-reader 4)]
588        [locale-reader-abbr-weekday (tm:make-locale-reader tm:locale-abbr-weekday->index)]
589        [locale-reader-long-weekday (tm:make-locale-reader tm:locale-long-weekday->index)]
590        [locale-reader-abbr-month   (tm:make-locale-reader tm:locale-abbr-month->index)]
591        [locale-reader-long-month   (tm:make-locale-reader tm:locale-long-month->index)]
592        [char-fail (lambda (ch) #t)]
593        [do-nothing noop #;(lambda (val object) (void))])
594
595    (list
596      (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
597
598      (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
599
600      (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
601
602      (list #\b char-alphabetic? locale-reader-abbr-month
603        (lambda (val object) (tm:date-month-set! object val)))
604
605      (list #\B char-alphabetic? locale-reader-long-month
606        (lambda (val object) (tm:date-month-set! object val)))
607
608      (list #\d char-numeric? ireader2
609        (lambda (val object) (tm:date-day-set! object val)))
610
611      (list #\e char-fail eireader2
612        (lambda (val object) (tm:date-day-set! object val)))
613
614      (list #\h char-alphabetic? locale-reader-abbr-month
615        (lambda (val object) (tm:date-month-set! object val)))
616
617      (list #\H char-numeric? ireader2
618        (lambda (val object) (tm:date-hour-set! object val)))
619
620      (list #\k char-fail eireader2
621        (lambda (val object) (tm:date-hour-set! object val)))
622
623      (list #\m char-numeric? ireader2
624        (lambda (val object) (tm:date-month-set! object val)))
625
626      (list #\M char-numeric? ireader2
627        (lambda (val object) (tm:date-minute-set! object val)))
628
629      (list #\N char-numeric? ireader7
630        (lambda (val object) (tm:date-nanosecond-set! object val)))
631
632      (list #\S char-numeric? ireader2
633        (lambda (val object) (tm:date-second-set! object val)))
634
635      (list #\y char-fail eireader2
636        (lambda (val object)
637          (tm:date-year-set! object (tm:natural-year val))))
638
639      (list #\Y char-numeric? ireader4
640        (lambda (val object) (tm:date-year-set! object val)))
641
642      (list #\z
643        (lambda (c)
644          (or (char=? c #\Z)
645              (char=? c #\z)
646              (char=? c #\+)
647              (char=? c #\-)))
648        tm:zone-reader
649        (lambda (val object)
650          (tm:date-zone-offset-set! object val))) ) ) )
651
652(define (tm:date-reader date format-rem len-rem port)
653  (let loop ([format-rem format-rem] [len-rem len-rem])
654    (let ([skip-until
655            (lambda (skipper)
656              (let loop ([ch (peek-char port)])
657                (if (eof-object? ch)
658                  (error 'scan-date "bad date template" (list->string format-rem))
659                  (unless (skipper ch)
660                    (read-char port)
661                    (loop (peek-char port))))))])
662      (when (fx< 0 len-rem)
663        (let ([current-char (car format-rem)])
664          (cond
665            [(not (char=? current-char #\~))
666              (let ([port-char (read-char port)])
667                (when (or (eof-object? port-char)
668                          (not (char=? current-char port-char)))
669                  (error 'scan-date "bad date template" (list->string format-rem))))
670              (loop (cdr format-rem) (fx- len-rem 1))]
671              ;; otherwise, it's an escape, we hope
672            [(fx< len-rem 2)
673              (error 'scan-date "bad date template" (list->string format-rem))]
674            [else
675              (let* ([format-char (cadr format-rem)]
676                     [format-info (assoc format-char tm:read-directives)])
677                (unless format-info
678                  (error 'scan-date "bad date template" (list->string format-rem)))
679                (let ([skipper (cadr format-info)]
680                      [reader (caddr format-info)]
681                      [actor (cadddr format-info)])
682                  (skip-until skipper)
683                  (let ([val (reader port)])
684                    (if (eof-object? val)
685                      (error 'scan-date "bad date template" (list->string format-rem))
686                      (actor val date))))
687                (loop (cddr format-rem) (fx- len-rem 2)))]) ) ) ) ) )
688
689(define (scan-date src template-string)
690  (let ([port #f]
691        [newdate
692          (tm:make-date
693            0 0 0 0 #f #f #f
694            (local-timezone-offset) (local-timezone-name) (local-timezone-dst?)
695            #f #f #f)])
696    (let ([date-compl?
697            (lambda ()
698              (and (date-nanosecond newdate)
699                   (date-second newdate) (date-minute newdate) (date-hour newdate)
700                   (date-day newdate) (date-month newdate) (date-year newdate)
701                   (date-zone-offset newdate)))]
702          [date-ok?
703            (lambda ()
704              (tm:vali-date
705                'scan-date
706                (date-nanosecond newdate)
707                (date-second newdate) (date-minute newdate) (date-hour newdate)
708                (date-day newdate) (date-month newdate) (date-year newdate)
709                (date-zone-offset newdate)
710                (date-zone-name newdate)))])
711      (cond
712        [(string? src)  (set! port (open-input-string src))]
713        [(port? src)    (set! port src)]
714        [src            (set! port (current-input-port))])
715      (tm:date-reader newdate (string->list template-string) (string-length template-string) port)
716      (unless (date-compl?)
717        (error 'scan-date "bad date template: date read incomplete" template-string newdate))
718      (and (date-ok?) newdate) ) ) )
719
720(define (string->date src . template-string)
721  (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))))
Note: See TracBrowser for help on using the repository browser.