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

Last change on this file since 38668 was 38668, checked in by Kon Lovett, 5 months ago

remove redundant -local, use -strict-types (#t is-a type? see -io zone-reader NOTE), isolate tm:ctm

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