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

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

Save.

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