1 ! Copyright (C) 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: math math.order math.parser math.functions kernel
\r
4 sequences io accessors arrays io.streams.string splitting
\r
5 combinators accessors calendar calendar.format.macros present ;
\r
8 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
\r
10 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
\r
12 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
\r
14 : write-00 ( n -- ) pad-00 write ;
\r
16 : write-0000 ( n -- ) pad-0000 write ;
\r
18 : write-00000 ( n -- ) pad-00000 write ;
\r
20 : hh ( time -- ) hour>> write-00 ;
\r
22 : mm ( time -- ) minute>> write-00 ;
\r
24 : ss ( time -- ) second>> >integer write-00 ;
\r
26 : D ( time -- ) day>> number>string write ;
\r
28 : DD ( time -- ) day>> write-00 ;
\r
30 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
\r
32 : MM ( time -- ) month>> write-00 ;
\r
34 : MONTH ( time -- ) month>> month-abbreviation write ;
\r
36 : YYYY ( time -- ) year>> write-0000 ;
\r
38 : YYYYY ( time -- ) year>> write-00000 ;
\r
41 read1 swap member? [ "Parse error" throw ] unless ;
\r
43 : read-00 ( -- n ) 2 read string>number ;
\r
45 : read-000 ( -- n ) 3 read string>number ;
\r
47 : read-0000 ( -- n ) 4 read string>number ;
\r
49 GENERIC: day. ( obj -- )
\r
51 M: integer day. ( n -- )
\r
52 number>string dup length 2 < [ bl ] when write ;
\r
54 M: timestamp day. ( timestamp -- )
\r
57 GENERIC: month. ( obj -- )
\r
59 M: array month. ( pair -- )
\r
61 [ month-name write bl number>string print ]
\r
62 [ 1 zeller-congruence ]
\r
63 [ (days-in-month) day-abbreviations2 " " join print ] 2tri
\r
64 over " " <repetition> concat write
\r
67 1+ + 7 mod zero? [ nl ] [ bl ] if
\r
70 M: timestamp month. ( timestamp -- )
\r
71 [ year>> ] [ month>> ] bi 2array month. ;
\r
73 GENERIC: year. ( obj -- )
\r
75 M: integer year. ( n -- )
\r
76 12 [ 1+ 2array month. nl ] with each ;
\r
78 M: timestamp year. ( timestamp -- )
\r
81 : timestamp>mdtm ( timestamp -- str )
\r
82 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
\r
84 : (timestamp>string) ( timestamp -- )
\r
85 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
\r
87 : timestamp>string ( timestamp -- str )
\r
88 [ (timestamp>string) ] with-string-writer ;
\r
90 : (write-gmt-offset) ( duration -- )
\r
93 : write-gmt-offset ( gmt-offset -- )
\r
95 { +eq+ [ drop "GMT" write ] }
\r
96 { +lt+ [ "-" write before (write-gmt-offset) ] }
\r
97 { +gt+ [ "+" write (write-gmt-offset) ] }
\r
100 : timestamp>rfc822 ( timestamp -- str )
\r
101 #! RFC822 timestamp format
\r
102 #! Example: Tue, 15 Nov 1994 08:12:31 +0200
\r
104 [ (timestamp>string) " " write ]
\r
105 [ gmt-offset>> write-gmt-offset ]
\r
107 ] with-string-writer ;
\r
109 : timestamp>http-string ( timestamp -- str )
\r
110 #! http timestamp format
\r
111 #! Example: Tue, 15 Nov 1994 08:12:31 GMT
\r
112 >gmt timestamp>rfc822 ;
\r
114 : (timestamp>cookie-string) ( timestamp -- )
\r
116 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
\r
118 : timestamp>cookie-string ( timestamp -- str )
\r
119 [ (timestamp>cookie-string) ] with-string-writer ;
\r
121 : (write-rfc3339-gmt-offset) ( duration -- )
\r
122 [ hh ":" write ] [ mm ] bi ;
\r
124 : write-rfc3339-gmt-offset ( duration -- )
\r
126 { +eq+ [ drop "Z" write ] }
\r
127 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
\r
128 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
\r
131 : (timestamp>rfc3339) ( timestamp -- )
\r
133 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
\r
134 [ gmt-offset>> write-rfc3339-gmt-offset ]
\r
137 : timestamp>rfc3339 ( timestamp -- str )
\r
138 [ (timestamp>rfc3339) ] with-string-writer ;
\r
140 : signed-gmt-offset ( dt ch -- dt' )
\r
141 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
\r
143 : read-rfc3339-gmt-offset ( ch -- dt )
\r
144 dup CHAR: Z = [ drop instant ] [
\r
147 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
\r
149 ] dip signed-gmt-offset
\r
152 : read-ymd ( -- y m d )
\r
153 read-0000 "-" expect read-00 "-" expect read-00 ;
\r
155 : read-hms ( -- h m s )
\r
156 read-00 ":" expect read-00 ":" expect read-00 ;
\r
158 : read-rfc3339-seconds ( s -- s' ch )
\r
160 [ string>number ] [ length 10 swap ^ ] bi / +
\r
163 : (rfc3339>timestamp) ( -- timestamp )
\r
167 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
\r
168 read-rfc3339-gmt-offset
\r
171 : rfc3339>timestamp ( str -- timestamp )
\r
172 [ (rfc3339>timestamp) ] with-string-reader ;
\r
174 ERROR: invalid-timestamp-format ;
\r
176 : check-timestamp ( obj/f -- obj )
\r
177 [ invalid-timestamp-format ] unless* ;
\r
179 : read-token ( seps -- token )
\r
180 [ read-until ] keep member? check-timestamp drop ;
\r
182 : read-sp ( -- token ) " " read-token ;
\r
184 : checked-number ( str -- n )
\r
185 string>number check-timestamp ;
\r
187 : parse-rfc822-gmt-offset ( string -- dt )
\r
188 dup "GMT" = [ drop instant ] [
\r
190 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
\r
191 ] dip signed-gmt-offset
\r
194 : (rfc822>timestamp) ( -- timestamp )
\r
196 "," read-token day-abbreviations3 member? check-timestamp drop
\r
197 read1 CHAR: \s assert=
\r
198 read-sp checked-number >>day
\r
199 read-sp month-abbreviations index 1+ check-timestamp >>month
\r
200 read-sp checked-number >>year
\r
201 ":" read-token checked-number >>hour
\r
202 ":" read-token checked-number >>minute
\r
203 " " read-token checked-number >>second
\r
204 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
206 : rfc822>timestamp ( str -- timestamp )
\r
207 [ (rfc822>timestamp) ] with-string-reader ;
\r
209 : check-day-name ( str -- )
\r
210 [ day-abbreviations3 member? ] [ day-names member? ] bi or
\r
211 check-timestamp drop ;
\r
213 : (cookie-string>timestamp-1) ( -- timestamp )
\r
215 "," read-token check-day-name
\r
216 read1 CHAR: \s assert=
\r
217 "-" read-token checked-number >>day
\r
218 "-" read-token month-abbreviations index 1+ check-timestamp >>month
\r
219 read-sp checked-number >>year
\r
220 ":" read-token checked-number >>hour
\r
221 ":" read-token checked-number >>minute
\r
222 " " read-token checked-number >>second
\r
223 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
225 : cookie-string>timestamp-1 ( str -- timestamp )
\r
226 [ (cookie-string>timestamp-1) ] with-string-reader ;
\r
228 : (cookie-string>timestamp-2) ( -- timestamp )
\r
230 read-sp check-day-name
\r
231 read-sp month-abbreviations index 1+ check-timestamp >>month
\r
232 read-sp checked-number >>day
\r
233 ":" read-token checked-number >>hour
\r
234 ":" read-token checked-number >>minute
\r
235 " " read-token checked-number >>second
\r
236 read-sp checked-number >>year
\r
237 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
239 : cookie-string>timestamp-2 ( str -- timestamp )
\r
240 [ (cookie-string>timestamp-2) ] with-string-reader ;
\r
242 : cookie-string>timestamp ( str -- timestamp )
\r
244 [ cookie-string>timestamp-1 ]
\r
245 [ cookie-string>timestamp-2 ]
\r
246 [ rfc822>timestamp ]
\r
247 } attempt-all-quots ;
\r
249 : (ymdhms>timestamp) ( -- timestamp )
\r
250 read-ymd " " expect read-hms instant <timestamp> ;
\r
252 : ymdhms>timestamp ( str -- timestamp )
\r
253 [ (ymdhms>timestamp) ] with-string-reader ;
\r
255 : (hms>timestamp) ( -- timestamp )
\r
256 0 0 0 read-hms instant <timestamp> ;
\r
258 : hms>timestamp ( str -- timestamp )
\r
259 [ (hms>timestamp) ] with-string-reader ;
\r
261 : (ymd>timestamp) ( -- timestamp )
\r
262 read-ymd 0 0 0 instant <timestamp> ;
\r
264 : ymd>timestamp ( str -- timestamp )
\r
265 [ (ymd>timestamp) ] with-string-reader ;
\r
267 : (timestamp>ymd) ( timestamp -- )
\r
268 { YYYY "-" MM "-" DD } formatted ;
\r
270 : timestamp>ymd ( timestamp -- str )
\r
271 [ (timestamp>ymd) ] with-string-writer ;
\r
273 : (timestamp>hms) ( timestamp -- )
\r
274 { hh ":" mm ":" ss } formatted ;
\r
276 : timestamp>hms ( timestamp -- str )
\r
277 [ (timestamp>hms) ] with-string-writer ;
\r
279 : timestamp>ymdhms ( timestamp -- str )
\r
282 { (timestamp>ymd) " " (timestamp>hms) } formatted
\r
283 ] with-string-writer ;
\r
285 : file-time-string ( timestamp -- string )
\r
290 dup now [ year>> ] bi@ =
\r
291 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
\r
294 ] with-string-writer ;
\r
296 M: timestamp present timestamp>string ;
\r