source: project/release/4/srfi-19/trunk/srfi-19-io.scm @ 15788

Last change on this file since 15788 was 15788, checked in by Kon Lovett, 11 years ago

Save.

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