source: project/release/5/srfi-19/trunk/srfi-19-io.scm @ 38336

Last change on this file since 38336 was 38336, checked in by Kon Lovett, 6 months ago

use remainder not modulo (dividend always +, sign of divisor significant), use quotient&remainder, add tz format test

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