From 1a2b21b8a099fa7c9a6804d59008916a32e7fad1 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 1 Oct 2003 18:07:41 +0000 Subject: [PATCH] Implement ISO 8601 date/time strings. --- v7/src/runtime/datime.scm | 196 ++++++++++++++++++++++++++++++++++++- v7/src/runtime/runtime.pkg | 10 +- 2 files changed, 204 insertions(+), 2 deletions(-) diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm index 71b5a759f..2ac029ab1 100644 --- a/v7/src/runtime/datime.scm +++ b/v7/src/runtime/datime.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: datime.scm,v 14.36 2003/09/30 17:17:05 cph Exp $ +$Id: datime.scm,v 14.37 2003/10/01 18:07:38 cph Exp $ Copyright 1986,1987,1988,1989,1990,1993 Massachusetts Institute of Technology Copyright 1995,1996,1997,1999,2000,2003 Massachusetts Institute of Technology @@ -391,6 +391,200 @@ USA. (decoded-time->file-time (ctime-string->decoded-time string (if (default-object? zone) #f zone)))) +;;;; ISO 8601 date/time strings + +;;; This implements a subset of the ISO 8601 specification. It +;;; accepts only complete date+time representations. It does not +;;; support either truncation or expansion. On output, it uses a +;;; single format. + +(define (iso8601-string->decoded-time string) + (let ((v (parse-8601-date/time (string->parser-buffer string)))) + (if (not v) + (error:bad-range-argument string 'ISO8601-STRING->DECODED-TIME)) + (vector-ref v 0))) + +(define (decoded-time->iso8601-string dt) + (let ((d2 (lambda (n) (string-pad-left (number->string n) 2 #\0)))) + (string-append (number->string (decoded-time/year dt)) + "-" + (d2 (decoded-time/month dt)) + "-" + (d2 (decoded-time/day dt)) + "T" + (d2 (decoded-time/hour dt)) + ":" + (d2 (decoded-time/minute dt)) + ":" + (d2 (decoded-time/second dt)) + (let ((zone (decoded-time/zone dt))) + (if zone + (time-zone->string + (if (decoded-time/daylight-savings-time? dt) + (- zone 1) + zone)) + ""))))) + +(define (universal-time->local-iso8601-string time) + (decoded-time->iso8601-string (universal-time->local-decoded-time time))) + +(define (universal-time->global-iso8601-string time) + (decoded-time->iso8601-string (universal-time->global-decoded-time time))) + +(define (iso8601-string->universal-time string #!optional zone) + (decoded-time->universal-time + (iso8601-string->decoded-time string (if (default-object? zone) #f zone)))) + +(define (file-time->local-iso8601-string time) + (decoded-time->iso8601-string (file-time->local-decoded-time time))) + +(define (file-time->global-iso8601-string time) + (decoded-time->iso8601-string (file-time->global-decoded-time time))) + +(define (iso8601-string->file-time string #!optional zone) + (decoded-time->file-time + (iso8601-string->decoded-time string (if (default-object? zone) #f zone)))) + +(define parse-8601-date/time + (*parser + (encapsulate + (lambda (v) + (let ((date (vector-ref v 0)) + (time (vector-ref v 1)) + (zone (vector-ref v 2))) + (make-decoded-time (vector-ref time 2) + (vector-ref time 1) + (vector-ref time 0) + (vector-ref date 2) + (vector-ref date 1) + (vector-ref date 0) + (and zone + (+ (* (- (vector-ref zone 0)) + (vector-ref zone 1)) + (/ (vector-ref zone 2) 60)))))) + (complete + (seq parse-8601-date + "T" parse-8601-time + (alt parse-8601-zone (values #f))))))) + +(define parse-8601-date + (*parser + (alt (encapsulate (lambda (v) v) + (seq parse-8601-year + (alt (seq "-" parse-8601-month "-" parse-8601-day) + (seq parse-8601-month parse-8601-day)))) + (transform week-date->month-date + (seq parse-8601-year + (alt (seq "-W" parse-8601-week "-" parse-8601-week-day) + (seq "W" parse-8601-week parse-8601-week-day)))) + (transform ordinal-date->month-date + (seq parse-8601-year + (alt (seq "-" parse-8601-ordinal-day) + parse-8601-ordinal-day)))))) + +(define (week-date->month-date v) + (let ((year (vector-ref v 0)) + (week (vector-ref v 1)) + (day (vector-ref v 2))) + (let ((dt + (let ((dt (make-decoded-time 0 0 0 1 1 year 0))) + (universal-time->global-decoded-time + (+ (decoded-time->universal-time dt) + (* (+ (* 7 (- week 1)) + (- day (+ (decoded-time/day-of-week dt) 1))) + 86400)))))) + (and (fix:= (decoded-time/year dt) year) + (vector (vector (decoded-time/year dt) + (decoded-time/month dt) + (decoded-time/day dt))))))) + +(define (ordinal-date->month-date v) + (let ((year (vector-ref v 0)) + (day (vector-ref v 1))) + (let ((dt + (let ((dt (make-decoded-time 0 0 0 1 1 year 0))) + (universal-time->global-decoded-time + (+ (decoded-time->universal-time dt) + (* (- day 1) + 86400)))))) + (and (fix:= (decoded-time/year dt) year) + (vector (vector (decoded-time/year dt) + (decoded-time/month dt) + (decoded-time/day dt))))))) + +(define parse-8601-time + (*parser + (transform (lambda (v) + (if (fix:= (vector-ref v 0) 24) + (and (fix:= (vector-ref v 1) 0) + (fix:= (vector-ref v 2) 0) + (vector (vector 0 0 0))) + (vector v))) + (seq parse-8601-hour + (alt (seq ":" parse-8601-minute ":" parse-8601-second) + (seq parse-8601-minute parse-8601-second)))))) + +(define parse-8601-zone + (*parser + (encapsulate (lambda (v) v) + (alt (transform (lambda (v) v (vector 1 0 0)) + (match "Z")) + (seq parse-8601-sign + parse-8601-zone-hour + (alt (seq (? ":") parse-8601-minute) + (values 0))))))) + +(define (8601-number-parser n-digits low high) + (let ((parse-digits + (case n-digits + ((1) + (*parser + (map string->number + (match (char-set char-set:numeric))))) + ((2) + (*parser + (map string->number + (match (seq (char-set char-set:numeric) + (char-set char-set:numeric)))))) + ((3) + (*parser + (map string->number + (match (seq (char-set char-set:numeric) + (char-set char-set:numeric) + (char-set char-set:numeric)))))) + ((4) + (*parser + (map string->number + (match (seq (char-set char-set:numeric) + (char-set char-set:numeric) + (char-set char-set:numeric) + (char-set char-set:numeric)))))) + (else + (error:bad-range-argument n-digits '8601-NUMBER-PARSER))))) + (lambda (b) + (let ((v (parse-digits b))) + (and v + (<= low (vector-ref v 0) high) + v))))) + +(define parse-8601-year (8601-number-parser 4 1582 9999)) +(define parse-8601-month (8601-number-parser 2 1 12)) +(define parse-8601-week (8601-number-parser 2 1 53)) +(define parse-8601-day (8601-number-parser 2 1 31)) +(define parse-8601-week-day (8601-number-parser 1 1 7)) +(define parse-8601-ordinal-day (8601-number-parser 3 1 366)) +(define parse-8601-hour (8601-number-parser 2 0 24)) +(define parse-8601-zone-hour (8601-number-parser 2 0 12)) +(define parse-8601-minute (8601-number-parser 2 0 59)) +(define parse-8601-second (8601-number-parser 2 0 59)) + +(define parse-8601-sign + (*parser + (alt (map (lambda (v) v 1) (match "+")) + (map (lambda (v) v -1) (match "-"))))) + +;;;; Utilities + (define (month/max-days month) (guarantee-month month 'MONTH/MAX-DAYS) (vector-ref '#(31 29 31 30 31 30 31 31 30 31 30 31) (- month 1))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index aaff4a2ef..cd7f6ba3d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.462 2003/09/30 17:17:22 cph Exp $ +$Id: runtime.pkg,v 14.463 2003/10/01 18:07:41 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -1158,6 +1158,7 @@ USA. day-of-week/short-string decode-universal-time decoded-time->ctime-string + decoded-time->iso8601-string decoded-time->string decoded-time->universal-time decoded-time/date-string @@ -1175,13 +1176,18 @@ USA. encode-universal-time epoch file-time->global-ctime-string + file-time->global-iso8601-string file-time->global-time-string file-time->local-ctime-string + file-time->local-iso8601-string file-time->local-time-string file-time->string get-decoded-time get-universal-time global-decoded-time + iso8601-string->decoded-time + iso8601-string->file-time + iso8601-string->universal-time local-decoded-time make-decoded-time month/long-string @@ -1197,9 +1203,11 @@ USA. time-zone? universal-time->global-ctime-string universal-time->global-decoded-time + universal-time->global-iso8601-string universal-time->global-time-string universal-time->local-ctime-string universal-time->local-decoded-time + universal-time->local-iso8601-string universal-time->local-time-string universal-time->string)) -- 2.25.1