source: project/release/4/rfc3339/trunk/rfc3339.scm @ 18883

Last change on this file since 18883 was 18883, checked in by Jim Ursetto, 10 years ago

rfc3339: initial import

File size: 7.3 KB
Line 
1;;; RFC3339 datetime parser
2
3;; Copyright (c) 2010 Jim Ursetto.  All Rights Reserved.
4;; License: BSD.
5
6(module rfc3339
7  (
8   ;; rfc3339 record
9   make-rfc3339 rfc3339?
10   rfc3339-year rfc3339-month rfc3339-day rfc3339-hours
11   rfc3339-minutes rfc3339-seconds rfc3339-fractions rfc3339-offset
12
13   ;; main interface
14   string->rfc3339 rfc3339->string
15   rfc3339->seconds
16   time->rfc3339
17
18   ;; convenience functions
19   rfc3339->vector vector->rfc3339
20   rfc3339
21   seconds->rfc3339
22   rfc3339->utc-time rfc3339->local-time
23   utc-time->rfc3339
24   )
25
26;;; date handling
27
28(import scheme chicken)
29(require-library posix extras)
30(import (only posix seconds->utc-time seconds->local-time utc-time->seconds))
31(import (only extras fprintf))
32(use regex) (import irregex)
33(use matchable)
34
35(define +rx:datetime+
36  (irregex '(: (submatch (= 4 num)) #\-
37               (submatch (= 2 num)) #\-
38               (submatch (= 2 num)) (or #\t #\T)
39               (submatch (= 2 num)) #\:
40               (submatch (= 2 num)) #\:
41               (submatch (= 2 num))
42               (? (submatch #\. (+ num)))
43               (submatch (+ any)))))
44(define +rx:datetime-tz+
45  (irregex '(: (submatch (or #\+ #\-))
46               (submatch (= 2 num)) #\:
47               (submatch (= 2 num)))))
48
49(define-record-type rfc3339
50  (make-rfc3339 year month day hours minutes seconds fractions offset)
51  rfc3339?
52  (year rfc3339-year)
53  (month rfc3339-month)
54  (day rfc3339-day)
55  (hours rfc3339-hours)
56  (minutes rfc3339-minutes)
57  (seconds rfc3339-seconds)
58  (fractions rfc3339-fractions)
59  (offset rfc3339-offset))
60
61;; Parses an RFC3339 format date like "yyyy-mm-ddThh:mm:ss(.sss...)(Z|[+-]hh:mm)".
62;; Returns a non-normalized vector #(year month day hours minutes seconds fractional-second tz-offset)
63;; YEAR is the year AD e.g. 2010, MONTH is the month 1-12 (January = 1), DAY is the day 1-31,
64;; HOURS is the hour 0-24, MINUTES is the minutes 0-59, SECONDS is the seconds 0-59,
65;; FRACTIONAL-SECOND is a floating-point number 0 <= x < 1,
66;; TZ-OFFSET is the number of seconds west of UTC.
67;; As this vector is non-normalized, some of these values may be out of range.  The format
68;; itself necessarily imposes some range limits, but we do not currently check the values;
69;; therefore minutes may actually be in the range 00-99.  However, values will be
70;; normalized when converted into seconds since epoch or a time value (10-element vector).
71(define string->rfc3339
72  (let ((s->n string->number))
73    (lambda (str)
74      (define (extract-tz tz)
75        (if (or (string=? tz "Z")
76                (string=? tz "z"))
77            0
78            (match (string-match +rx:datetime-tz+ tz)
79                    ((_ polarity hh mm)
80                     (let ((sec (+ (* (s->n hh) 3600)
81                                   (* (s->n mm) 60))))
82                       (if (string=? "+" polarity) (- sec) sec)))
83                   (else #f))))
84      (match (string-match +rx:datetime+ str)
85             ((_ y m d hh mm ss fs tz)
86              (and-let* ((etz (extract-tz tz)))
87                (make-rfc3339 (s->n y) (s->n m) (s->n d) (s->n hh) (s->n mm) (s->n ss)
88                              (if fs (s->n fs) 0)
89                              etz)))
90             (else #f)))))
91
92;; Converts an rfc3339 record into seconds since the UNIX epoch (1970-01-01 00:00:00 UTC).
93;; Out of range values are allowed as the record is normalized during conversion.
94(define rfc3339->seconds
95  (lambda (R)
96    (match (rfc3339->vector R)
97           (#(y m d hh mm ss fs tzoff)
98            (+ tzoff
99               (utc-time->seconds ;; This call is extremely slow on OS X.
100                (vector ss mm hh d (- m 1) (- y 1900) 0 0 #f 0)))))))
101
102;; Converts a 10-element time vector, such as that returned by seconds->utc-time or
103;; seconds->local-time, to an rfc3339 record.  The timezone offset field is honored.
104;; Values are not range-checked.
105;;
106;; See utc-time->rfc3339 if you notice that seconds->utc-time does not return
107;; a timezone offset of 0 on your system.
108(define time->rfc3339
109  (lambda (time)
110    ;; assumes normalized time!
111    (match time
112           (#(ss mm hh d m-1 y-1900 _ _ _ tzoff)
113            (make-rfc3339
114             (+ y-1900 1900) (+ m-1 1) d hh mm ss 0 tzoff)))))
115
116;; Convert rfc3339 record to a RFC3339 string.  The "T" and "Z" characters
117;; in the result string are always uppercase.  All fields are, by definition,
118;; present except for fractional seconds, which are omitted if 0.
119;; RFC3339 record values are not normalized before conversion,
120;; so some values could be out of range; however values /are/ clamped to
121;; the range 0-99 (or 0-9999 for years).
122(define (rfc3339->string dtv)
123  ;; Yes, this is terrible.
124  (define (c2 x)
125    (cond ((< x 0) "00")
126          ((>= x 100) "99")
127          (else (let ((s (number->string (inexact->exact x))))
128                  (if (< x 10) (string-append "0" s) s)))))
129  (define (c4 x)
130    (cond ((< x 0) "0000")
131          ((>= x 10000) "9999")
132          (else (let ((s (number->string (inexact->exact x))))
133                  (cond ((< x 10) (string-append "000" s))
134                        ((< x 100) (string-append "00" s))
135                        ((< x 1000) (string-append "0" s))
136                        (else s))))))
137  (define (cf x)   ;; Selectable padding would be nice.  Needs fmt.
138    (cond ((= x 0) "")
139          ((< x 0) "")
140          ((>= x 1) "") ;?
141          (else (let ((s (number->string x)))
142                  (cond ((not s) "") ;?
143                        ((eq? (string-ref s 0) #\0)
144                         (substring s 1))
145                        (else ""))))))
146  (define (tzstr tzoff)
147    (if (zero? tzoff)
148        "Z"
149        (string-append
150         (if (< tzoff 0) "+" "-")
151         (c2 (quotient (abs tzoff) 3600)) ":"
152         (c2 (quotient (remainder (abs tzoff) 3600) 60)))))
153  (match (rfc3339->vector dtv)
154         (#(y m d hh mm ss fs tzoff)
155          (string-append (c4 y)  "-" (c2 m)  "-" (c2 d) "T"
156                         (c2 hh) ":" (c2 mm) ":" (c2 ss)
157                         (cf fs) (tzstr tzoff)))))
158
159(define-record-printer (rfc3339 x out)
160  (fprintf out "#<rfc3339 ~s>" (rfc3339->string x)))
161
162;;; convenience functions
163
164(define (rfc3339->vector R)
165  (vector (rfc3339-year R) (rfc3339-month R) (rfc3339-day R)
166          (rfc3339-hours R) (rfc3339-minutes R) (rfc3339-seconds R)
167          (rfc3339-fractions R) (rfc3339-offset R)))
168(define (vector->rfc3339 R)
169  (apply make-rfc3339 (vector->list R)))
170
171(define (rfc3339 x)
172  (cond ((string? x)
173         (string->rfc3339 x))
174        ((vector? x)
175         (vector->rfc3339 x))
176        (else (error 'rfc3339 "argument must be a string or vector"))))
177
178(define (seconds->rfc3339 sec)
179  (utc-time->rfc3339 (seconds->utc-time sec)))  ;; utc-time->rfc3339 just in case
180(define (rfc3339->utc-time R)
181  (seconds->utc-time (rfc3339->seconds R)))
182(define (rfc3339->local-time R)
183  (seconds->local-time (rfc3339->seconds R)))
184
185;; Convert UTC time to RFC3339.  Normally you should use
186;; time->rfc3339, but versions of Chicken < x.x.x may not zero out the
187;; timezone offset in the return value from seconds->utc-time.  This
188;; provides a convenient workaround.
189(define (utc-time->rfc3339 tm)
190  (define (vector-copy v)
191    (let ((len (vector-length v)))
192      (do ((vec (make-vector len))
193           (i 0 (+ i 1)))
194          ((= i len) vec)
195        (vector-set! vec i (vector-ref v i)))))
196  (let ((tm (vector-copy tm)))
197    (vector-set! tm 8 #f)
198    (vector-set! tm 9 0)
199    (time->rfc3339 tm)))
200
201
202)
Note: See TracBrowser for help on using the repository browser.