;;;; srfi-19-io.scm ;;;; Chicken port, Kon Lovett, Dec '05 ;; SRFI-19: Time Data Types and Procedures. ;; ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved. ;; ;; This document and translations of it may be copied and furnished to others, ;; and derivative works that comment on or otherwise explain it or assist in its ;; implementation may be prepared, copied, published and distributed, in whole or ;; in part, without restriction of any kind, provided that the above copyright ;; notice and this paragraph are included on all such copies and derivative works. ;; However, this document itself may not be modified in any way, such as by ;; removing the copyright notice or references to the Scheme Request For ;; Implementation process or editors, except as needed for the purpose of ;; developing SRFIs in which case the procedures for copyrights defined in the SRFI ;; process must be followed, or as required to translate it into languages other ;; than English. ;; ;; The limited permissions granted above are perpetual and will not be revoked ;; by the authors or their successors or assigns. ;; ;; This document and the information contained herein is provided on an "AS IS" ;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. (module srfi-19-io (;export ;; SRFI-19 date->string string->date ;; SRFI-19 extensions format-date scan-date) (import (except scheme + / > exact->inexact number->string) chicken (only srfi-1 reverse!) #;srfi-6 (only srfi-13 string-pad) (only ports with-output-to-string) (only data-structures noop) (only numbers + / > exact->inexact number->string) srfi-29 srfi-19-support) (require-library srfi-1 #;srfi-6 srfi-13 ports data-structures numbers srfi-29 locale srfi-19-support) ;;; (include "srfi-19-common") ;;; (define (error-bad-date-format loc obj) (error loc "bad date format" obj) ) (define (error-bad-date-template loc msg . args) (apply error loc (if (string=? "" msg) "bad date template" (string-append "bad date template - " msg)) args) ) ;;; ;; -- Locale bundle item keys (define LOCALE-NUMBER-SEPARATOR 'separator) (define LOCALE-ABRV-WEEKDAYS '#(sun mon tue wed thu fri sat)) (define LOCALE-LONG-WEEKDAYS '#(sunday monday tuesday wednesday thursday friday saturday)) (define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec)) (define LOCALE-LONG-MONTHS '#(#f january february march april may june july august september october november december)) (define LOCALE-PM 'pm) (define LOCALE-AM 'am) ;; See date->string (define LOCALE-DATE-TIME-FORMAT 'date-time) (define LOCALE-SHORT-DATE-FORMAT 'date) (define LOCALE-TIME-FORMAT 'time) ;; SRFI-29: Localization initialization (reset-locale-parameters) (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19)) ;; SRFI-29 Helper (define-inline (item@ key) (localized-template/default 'srfi-19 key)) ;;; Date & Time Formatted I/O ;; Return a string representing the decimal expansion of the fractional ;; portion of a number, limited by a specified precision (define (decimal-expansion frac prec) (let loop ((n (- frac (round frac))) (p prec) (ls '())) (if (or (fx= 0 p) (zero? n)) (apply string-append (reverse! ls)) (let* ((n*10 (* 10 n)) (rn*10 (round n*10))) (loop (- n*10 rn*10) (fx- p 1) (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) ) ;; Returns a string rep. of number N, of minimum LENGTH, ;; padded with character PAD-WITH. If PAD-WITH if #f, ;; no padding is done, and it's as if number->string was used. ;; if string is longer than LENGTH, it's as if number->string was used. (define (padding n pad-with length) (let* ((str (number->string n)) (len (string-length str))) (define (trailing-dotzero?) (and (fx<= 2 len) (char=? #\. (string-ref str (fx- len 2))) (char=? #\0 (string-ref str (fx- len 1))) ) ) (let ((str (if (not (trailing-dotzero?)) str (substring str 0 (fx- len 2)) ) ) ) (if (or (not pad-with) (fx> len length)) str (string-pad str length pad-with)) ) ) ) (define fxtake-right-digits (let ((nth (vector 0 10 100 1000 100000 1000000 10000000 100000000 1000000000))) (lambda (i n) (fxmod (fxabs i) (vector-ref nth n)) ) ) ) (define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS n))) (define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS n))) (define (locale-abbr-month n) (item@ (vector-ref LOCALE-ABRV-MONTHS n))) (define (locale-long-month n) (item@ (vector-ref LOCALE-LONG-MONTHS n))) (define (locale-find-string str vec) (let loop ((idx (fx- (vector-length vec) 1))) (and (fx< 0 idx) (or (and (string=? str (item@ (vector-ref vec idx))) idx) (loop (fx- idx 1))) ) ) ) (define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS)) (define (locale-long-weekday->index str) (locale-find-string str LOCALE-LONG-WEEKDAYS)) (define (locale-abbr-month->index str) (locale-find-string str LOCALE-ABRV-MONTHS)) (define (locale-long-month->index str) (locale-find-string str LOCALE-LONG-MONTHS)) ;; There is no unique way to map a timezone offset to a political timezone! (define (locale-print-time-zone date port) (when (tm:date-zone-name date) (display (tm:date-zone-name date) port)) ) ;; Again, locale specific. (define (locale-am/pm hr) (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM))) (define (tz-printer offset port) (if (fx= 0 offset) (display "Z" port) (let ((isneg (fx< offset 0))) (display (if isneg #\- #\+) port) (let ((offset (if isneg (fxneg offset) offset))) (display (padding (fx/ offset SEC/HR) #\0 2) port) (display (padding (fx/ (fxmod offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) ) ;; A table of output formatting directives. ;; the first time is the format char. ;; the second is a procedure that takes the date, a padding character ;; (which might be #f), and the output port. (define tm:display-directives (list (cons #\~ (lambda (date pad-with port) (display #\~ port))) (cons #\a (lambda (date pad-with port) (display (locale-abbr-weekday (tm:date-week-day date)) port))) (cons #\A (lambda (date pad-with port) (display (locale-long-weekday (tm:date-week-day date)) port))) (cons #\b (lambda (date pad-with port) (display (locale-abbr-month (tm:date-month date)) port))) (cons #\B (lambda (date pad-with port) (display (locale-long-month (tm:date-month date)) port))) (cons #\c (lambda (date pad-with port) (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port))) (cons #\d (lambda (date pad-with port) (display (padding (tm:date-day date) #\0 2) port))) (cons #\D (lambda (date pad-with port) (display (date->string date "~m/~d/~y") port))) (cons #\e (lambda (date pad-with port) (display (padding (tm:date-day date) #\space 2) port))) (cons #\f (lambda (date pad-with port) (let ((ns (tm:date-nanosecond date)) (sec (tm:date-second date))) (if (> ns NS/S) ; This shouldn't happen! (display (padding (+ sec 1) pad-with 2) port) (display (padding sec pad-with 2) port)) ; ns must be inexact for 'decimal-expansion' (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6))) (when (fx< 0 (string-length f)) (display (item@ LOCALE-NUMBER-SEPARATOR) port) (display f port)))))) (cons #\h (lambda (date pad-with port) (display (date->string date "~b") port))) (cons #\H (lambda (date pad-with port) (display (padding (tm:date-hour date) pad-with 2) port))) (cons #\I (lambda (date pad-with port) (let ((hr (tm:date-hour date))) (if (fx> hr 12) (display (padding (fx- hr 12) pad-with 2) port) (display (padding hr pad-with 2) port))))) (cons #\j (lambda (date pad-with port) (display (padding (tm:date-year-day date) pad-with 3) port))) (cons #\k (lambda (date pad-with port) (display (padding (tm:date-hour date) #\space 2) port))) (cons #\l (lambda (date pad-with port) (let ((hr (tm:date-hour date))) (display (padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port)))) (cons #\m (lambda (date pad-with port) (display (padding (tm:date-month date) pad-with 2) port))) (cons #\M (lambda (date pad-with port) (display (padding (tm:date-minute date) pad-with 2) port))) (cons #\n (lambda (date pad-with port) (newline port))) (cons #\N (lambda (date pad-with port) (display (padding (tm:date-nanosecond date) pad-with 7) port))) (cons #\p (lambda (date pad-with port) (display (locale-am/pm (tm:date-hour date)) port))) (cons #\r (lambda (date pad-with port) (display (date->string date "~I:~M:~S ~p") port))) (cons #\s (lambda (date pad-with port) (display (tm:time-second (tm:date->time-utc date)) port))) (cons #\S (lambda (date pad-with port) (let ((sec (tm:date-second date))) (if (> (tm:date-nanosecond date) NS/S) ; This shouldn't happen! (display (padding (+ sec 1) pad-with 2) port) (display (padding sec pad-with 2) port))))) (cons #\t (lambda (date pad-with port) (display #\tab port))) (cons #\T (lambda (date pad-with port) (display (date->string date "~H:~M:~S") port))) (cons #\U (lambda (date pad-with port) (let ((wkno (tm:date-week-number date 0))) (if (fx> (tm:days-before-first-week date 0) 0) (display (padding (fx+ wkno 1) #\0 2) port) (display (padding wkno #\0 2) port))))) (cons #\V (lambda (date pad-with port) (display (padding (tm:date-week-number date 1) #\0 2) port))) (cons #\w (lambda (date pad-with port) (display (tm:date-week-day date) port))) (cons #\W (lambda (date pad-with port) (let ((wkno (tm:date-week-number date 1))) (if (fx> (tm:days-before-first-week date 1) 0) (display (padding (fx+ wkno 1) #\0 2) port) (display (padding wkno #\0 2) port))))) (cons #\x (lambda (date pad-with port) (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port))) (cons #\X (lambda (date pad-with port) (display (date->string date (item@ LOCALE-TIME-FORMAT)) port))) (cons #\y (lambda (date pad-with port) (display (padding (fxtake-right-digits (tm:date-year date) 2) pad-with 2) port))) (cons #\Y (lambda (date pad-with port) (display (tm:date-year date) port))) (cons #\z (lambda (date pad-with port) (tz-printer (tm:date-zone-offset date) port))) (cons #\Z (lambda (date pad-with port) (locale-print-time-zone date port))) (cons #\1 (lambda (date pad-with port) (display (date->string date "~Y-~m-~d") port))) (cons #\2 (lambda (date pad-with port) (display (date->string date "~H:~M:~S~z") port))) (cons #\3 (lambda (date pad-with port) (display (date->string date "~H:~M:~S") port))) (cons #\4 (lambda (date pad-with port) (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port))) (cons #\5 (lambda (date pad-with port) (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) ) ) (define (date-printer loc date format-rem len-rem port) (when (fx< 0 len-rem) (let ((current-char (car format-rem)) (get-formatter (lambda (char) (and-let* ((associated (assoc char tm:display-directives))) (cdr associated))))) (cond ((not (char=? current-char #\~)) (display current-char port) (date-printer loc date (cdr format-rem) (fx- len-rem 1) port)) ((fx< len-rem 2) (error-bad-date-format loc (list->string format-rem))) (else (let ((pad-ch (cadr format-rem))) (cond ((char=? pad-ch #\-) (if (fx< len-rem 3) (error-bad-date-format loc (list->string format-rem)) (let ((formatter (get-formatter (caddr format-rem)))) (if (not formatter) (error-bad-date-format loc (list->string format-rem)) (begin (formatter date #f port) (date-printer loc date (cdddr format-rem) (fx- len-rem 3) port)))))) ((char=? pad-ch #\_) (if (fx< len-rem 3) (error-bad-date-format loc (list->string format-rem)) (let ((formatter (get-formatter (caddr format-rem)))) (if (not formatter) (error-bad-date-format loc (list->string format-rem)) (begin (formatter date #\space port) (date-printer loc date (cdddr format-rem) (fx- len-rem 3) port)))))) (else (let ((formatter (get-formatter pad-ch))) (if (not formatter) (error-bad-date-format loc (list->string format-rem)) (begin (formatter date #\0 port) (date-printer loc date (cddr format-rem) (fx- len-rem 2) port))))))))) )) ) (define (format-date dest fmt-str . r) (let ((port #f) (date (optional r #f))) (cond ((not dest) (set! port (open-output-string))) ((string? dest) (set! date fmt-str) (set! fmt-str dest) (set! port (open-output-string))) ((number? dest) (set! port (current-error-port))) ((port? dest) (set! port dest)) (else (set! port (current-output-port)))) (date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port) (or dest (not (string? dest))) (get-output-string port) ) ) (define (date->string date . format-string) (format-date (optional format-string "~c") date)) ;;; Input (define (digit->int ch) (case ch ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4) ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else (error-bad-date-template 'date-read "not a decimal digit" ch))) ) ;; read an integer upto n characters long on port; ;; upto -> #f if any length (define (integer-reader upto port) (let loop ((accum 0) (nchars 0)) (let ((ch (peek-char port))) (if (or (eof-object? ch) (not (char-numeric? ch)) (and upto (fx>= nchars upto))) accum (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1))) ) ) ) (define (make-integer-reader upto) (lambda (port) (integer-reader upto port) ) ) ;; read *exactly* n characters and convert to integer; could be padded (define (integer-reader-exact n port) (let ((padding-ok #t)) (let loop ((accum 0) (nchars 0)) (let ((ch (peek-char port))) (cond ((fx>= nchars n) accum) ((eof-object? ch) (error-bad-date-template 'string->date "premature ending to integer read" 'eof-object)) ((char-numeric? ch) (set! padding-ok #f) (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1))) (padding-ok (read-char port) ; consume padding (loop accum (fx+ nchars 1))) (else ; padding where it shouldn't be (error-bad-date-template 'string->date "non-numeric characters in integer read" ch))) ) ) ) ) (define (make-integer-exact-reader n) (lambda (port) (integer-reader-exact n port)) ) (define (zone-reader port) (let ((offset 0) (is-pos #t) (ch (read-char port)) ) (when (eof-object? ch) (error-bad-date-template 'string->date "invalid time zone +/-" 'eof-object)) (if (or (char=? ch #\Z) (char=? ch #\z)) 0 (begin (cond ((char=? ch #\+) (set! is-pos #t)) ((char=? ch #\-) (set! is-pos #f)) (else (error-bad-date-template 'string->date "invalid time zone +/-" ch))) (let ((ch (read-char port))) (when (eof-object? ch) (error-bad-date-template 'string->date "invalid time zone number" 'eof-object)) (set! offset (fx* (digit->int ch) (fx* 10 SEC/HR)))) ;; non-existing values are considered zero (let ((ch (read-char port))) (unless (eof-object? ch) (set! offset (fx+ offset (fx* (digit->int ch) SEC/HR))))) (let ((ch (read-char port))) (unless (eof-object? ch) (set! offset (fx+ offset (fx* (digit->int ch) 600))))) (let ((ch (read-char port))) (unless (eof-object? ch) (set! offset (fx+ offset (fx* (digit->int ch) 60))))) (if is-pos offset (fxneg offset)))) ) ) ;; Looking at a char, read the char string, run thru indexer, return index (define (locale-reader port indexer) (letrec ( (read-char-string (lambda () (let ((ch (peek-char port))) (when (char-alphabetic? ch) (write-char (read-char port)) (read-char-string)) ) ))) (let* ((str (with-output-to-string read-char-string)) (index (indexer str))) (unless index (error-bad-date-template 'string->date "invalid string for indexer" str)) index ) ) ) (define (make-locale-reader indexer) (lambda (port) (locale-reader port indexer)) ) (define (make-char-id-reader char) (lambda (port) (let ((rch (read-char port))) (if (char=? char rch) char (error-bad-date-template 'string->date "invalid character match" rch) ) ) ) ) ;; A List of formatted read directives. ;; Each entry is a list. ;; 1. the character directive; ;; a procedure, which takes a character as input & returns ;; 2. #t as soon as a character on the input port is acceptable ;; for input, ;; 3. a port reader procedure that knows how to read the current port ;; for a value. Its one parameter is the port. ;; 4. a action procedure, that takes the value (from 3.) and some ;; object (here, always the date) and (probably) side-effects it. ;; In some cases (e.g., ~A) the action is to do nothing (define read-directives (let ((ireader4 (make-integer-reader 4)) (ireader2 (make-integer-reader 2)) (ireader7 (make-integer-reader 7)) (ireaderf (make-integer-reader #f)) (eireader2 (make-integer-exact-reader 2)) (eireader4 (make-integer-exact-reader 4)) (locale-reader-abbr-weekday (make-locale-reader locale-abbr-weekday->index)) (locale-reader-long-weekday (make-locale-reader locale-long-weekday->index)) (locale-reader-abbr-month (make-locale-reader locale-abbr-month->index)) (locale-reader-long-month (make-locale-reader locale-long-month->index)) (char-fail (lambda (ch) #t)) (do-nothing noop #;(lambda (val object) (void)))) (list (list #\~ char-fail (make-char-id-reader #\~) do-nothing) (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) (list #\b char-alphabetic? locale-reader-abbr-month (lambda (val object) (tm:date-month-set! object val))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) (tm:date-month-set! object val))) (list #\d char-numeric? ireader2 (lambda (val object) (tm:date-day-set! object val))) (list #\e char-fail eireader2 (lambda (val object) (tm:date-day-set! object val))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) (tm:date-month-set! object val))) (list #\H char-numeric? ireader2 (lambda (val object) (tm:date-hour-set! object val))) (list #\k char-fail eireader2 (lambda (val object) (tm:date-hour-set! object val))) (list #\m char-numeric? ireader2 (lambda (val object) (tm:date-month-set! object val))) (list #\M char-numeric? ireader2 (lambda (val object) (tm:date-minute-set! object val))) (list #\N char-numeric? ireader7 (lambda (val object) (tm:date-nanosecond-set! object val))) (list #\S char-numeric? ireader2 (lambda (val object) (tm:date-second-set! object val))) (list #\y char-fail eireader2 (lambda (val object) (tm:date-year-set! object (tm:natural-year val)))) (list #\Y char-numeric? ireader4 (lambda (val object) (tm:date-year-set! object val))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) zone-reader (lambda (val object) (tm:date-zone-offset-set! object val))) ) ) ) (define (date-reader date format-rem len-rem port) (let loop ((format-rem format-rem) (len-rem len-rem)) (let ((skip-until (lambda (skipper) (let loop ((ch (peek-char port))) (if (eof-object? ch) (error-bad-date-template 'scan-date "" (list->string format-rem)) (unless (skipper ch) (read-char port) (loop (peek-char port)))))))) (when (fx< 0 len-rem) (let ((current-char (car format-rem))) (cond ((not (char=? current-char #\~)) (let ((port-char (read-char port))) (when (or (eof-object? port-char) (not (char=? current-char port-char))) (error-bad-date-template 'scan-date "" (list->string format-rem)))) (loop (cdr format-rem) (fx- len-rem 1))) ;; otherwise, it's an escape, we hope ((fx< len-rem 2) (error-bad-date-template 'scan-date "" (list->string format-rem))) (else (let* ((format-char (cadr format-rem)) (format-info (assoc format-char read-directives))) (unless format-info (error-bad-date-template 'scan-date "" (list->string format-rem))) (let ((skipper (cadr format-info)) (reader (caddr format-info)) (actor (cadddr format-info))) (skip-until skipper) (let ((val (reader port))) (if (eof-object? val) (error-bad-date-template 'scan-date "" (list->string format-rem)) (actor val date)))) (loop (cddr format-rem) (fx- len-rem 2))))) ) ) ) ) ) (define (scan-date src template-string) (let ((port #f) (newdate (tm:make-incomplete-date))) (let ((date-complete? (lambda () (and (tm:date-nanosecond newdate) (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate) (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate) (tm:date-zone-offset newdate)))) (date-ok (lambda () (check-date-elements 'scan-date (tm:date-nanosecond newdate) (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate) (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate) (tm:date-zone-offset newdate) (tm:date-zone-name newdate))))) (cond ((string? src) (set! port (open-input-string src))) ((port? src) (set! port src)) (src (set! port (current-input-port)))) (date-reader newdate (string->list template-string) (string-length template-string) port) (unless (date-complete?) (error-bad-date-template 'scan-date "date read incomplete" template-string newdate)) (date-ok) newdate ) ) ) (define (string->date src . template-string) (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))) ) ) ;module srfi-19-io