1 USING: math math.order math.parser math.functions kernel sequences io
\r
2 accessors arrays io.streams.string splitting
\r
3 combinators accessors debugger
\r
4 calendar calendar.format.macros ;
\r
7 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
\r
9 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;
\r
11 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;
\r
13 : write-00 ( n -- ) pad-00 write ;
\r
15 : write-0000 ( n -- ) pad-0000 write ;
\r
17 : write-00000 ( n -- ) pad-00000 write ;
\r
19 : hh ( time -- ) hour>> write-00 ;
\r
21 : mm ( time -- ) minute>> write-00 ;
\r
23 : ss ( time -- ) second>> >integer write-00 ;
\r
25 : D ( time -- ) day>> number>string write ;
\r
27 : DD ( time -- ) day>> write-00 ;
\r
29 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
\r
31 : MM ( time -- ) month>> write-00 ;
\r
33 : MONTH ( time -- ) month>> month-abbreviation write ;
\r
35 : YYYY ( time -- ) year>> write-0000 ;
\r
37 : YYYYY ( time -- ) year>> write-00000 ;
\r
40 read1 swap member? [ "Parse error" throw ] unless ;
\r
42 : read-00 ( -- n ) 2 read string>number ;
\r
44 : read-000 ( -- n ) 3 read string>number ;
\r
46 : read-0000 ( -- n ) 4 read string>number ;
\r
48 GENERIC: day. ( obj -- )
\r
50 M: integer day. ( n -- )
\r
51 number>string dup length 2 < [ bl ] when write ;
\r
53 M: timestamp day. ( timestamp -- )
\r
56 GENERIC: month. ( obj -- )
\r
58 M: array month. ( pair -- )
\r
60 [ month-name write bl number>string print ]
\r
61 [ 1 zeller-congruence ]
\r
62 [ (days-in-month) day-abbreviations2 " " join print ] 2tri
\r
63 over " " <repetition> concat write
\r
66 1+ + 7 mod zero? [ nl ] [ bl ] if
\r
69 M: timestamp month. ( timestamp -- )
\r
70 [ year>> ] [ month>> ] bi 2array month. ;
\r
72 GENERIC: year. ( obj -- )
\r
74 M: integer year. ( n -- )
\r
75 12 [ 1+ 2array month. nl ] with each ;
\r
77 M: timestamp year. ( timestamp -- )
\r
80 : (timestamp>string) ( timestamp -- )
\r
81 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
\r
83 : timestamp>string ( timestamp -- str )
\r
84 [ (timestamp>string) ] with-string-writer ;
\r
86 : (write-gmt-offset) ( duration -- )
\r
89 : write-gmt-offset ( gmt-offset -- )
\r
91 { +eq+ [ drop "GMT" write ] }
\r
92 { +lt+ [ "-" write before (write-gmt-offset) ] }
\r
93 { +gt+ [ "+" write (write-gmt-offset) ] }
\r
96 : timestamp>rfc822 ( timestamp -- str )
\r
97 #! RFC822 timestamp format
\r
98 #! Example: Tue, 15 Nov 1994 08:12:31 +0200
\r
100 [ (timestamp>string) " " write ]
\r
101 [ gmt-offset>> write-gmt-offset ]
\r
103 ] with-string-writer ;
\r
105 : timestamp>http-string ( timestamp -- str )
\r
106 #! http timestamp format
\r
107 #! Example: Tue, 15 Nov 1994 08:12:31 GMT
\r
108 >gmt timestamp>rfc822 ;
\r
110 : (timestamp>cookie-string) ( timestamp -- )
\r
112 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
\r
114 : timestamp>cookie-string ( timestamp -- str )
\r
115 [ (timestamp>cookie-string) ] with-string-writer ;
\r
117 : (write-rfc3339-gmt-offset) ( duration -- )
\r
118 [ hh ":" write ] [ mm ] bi ;
\r
120 : write-rfc3339-gmt-offset ( duration -- )
\r
122 { +eq+ [ drop "Z" write ] }
\r
123 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
\r
124 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
\r
127 : (timestamp>rfc3339) ( timestamp -- )
\r
129 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
\r
130 [ gmt-offset>> write-rfc3339-gmt-offset ]
\r
133 : timestamp>rfc3339 ( timestamp -- str )
\r
134 [ (timestamp>rfc3339) ] with-string-writer ;
\r
136 : signed-gmt-offset ( dt ch -- dt' )
\r
137 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
\r
139 : read-rfc3339-gmt-offset ( ch -- dt )
\r
140 dup CHAR: Z = [ drop instant ] [
\r
143 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
\r
145 r> signed-gmt-offset
\r
148 : read-ymd ( -- y m d )
\r
149 read-0000 "-" expect read-00 "-" expect read-00 ;
\r
151 : read-hms ( -- h m s )
\r
152 read-00 ":" expect read-00 ":" expect read-00 ;
\r
154 : read-rfc3339-seconds ( s -- s' ch )
\r
155 "+-Z" read-until >r
\r
156 [ string>number ] [ length 10 swap ^ ] bi / + r> ;
\r
158 : (rfc3339>timestamp) ( -- timestamp )
\r
162 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
\r
163 read-rfc3339-gmt-offset
\r
166 : rfc3339>timestamp ( str -- timestamp )
\r
167 [ (rfc3339>timestamp) ] with-string-reader ;
\r
169 ERROR: invalid-timestamp-format ;
\r
171 : check-timestamp ( obj/f -- obj )
\r
172 [ invalid-timestamp-format ] unless* ;
\r
174 : read-token ( seps -- token )
\r
175 [ read-until ] keep member? check-timestamp drop ;
\r
177 : read-sp ( -- token ) " " read-token ;
\r
179 : checked-number ( str -- n )
\r
180 string>number check-timestamp ;
\r
182 : parse-rfc822-gmt-offset ( string -- dt )
\r
183 dup "GMT" = [ drop instant ] [
\r
185 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
\r
186 r> signed-gmt-offset
\r
189 : (rfc822>timestamp) ( -- timestamp )
\r
191 "," read-token day-abbreviations3 member? check-timestamp drop
\r
192 read1 CHAR: \s assert=
\r
193 read-sp checked-number >>day
\r
194 read-sp month-abbreviations index 1+ check-timestamp >>month
\r
195 read-sp checked-number >>year
\r
196 ":" read-token checked-number >>hour
\r
197 ":" read-token checked-number >>minute
\r
198 " " read-token checked-number >>second
\r
199 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
201 : rfc822>timestamp ( str -- timestamp )
\r
202 [ (rfc822>timestamp) ] with-string-reader ;
\r
204 : check-day-name ( str -- )
\r
205 [ day-abbreviations3 member? ] [ day-names member? ] bi or
\r
206 check-timestamp drop ;
\r
208 : (cookie-string>timestamp-1) ( -- timestamp )
\r
210 "," read-token check-day-name
\r
211 read1 CHAR: \s assert=
\r
212 "-" read-token checked-number >>day
\r
213 "-" read-token month-abbreviations index 1+ check-timestamp >>month
\r
214 read-sp checked-number >>year
\r
215 ":" read-token checked-number >>hour
\r
216 ":" read-token checked-number >>minute
\r
217 " " read-token checked-number >>second
\r
218 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
220 : cookie-string>timestamp-1 ( str -- timestamp )
\r
221 [ (cookie-string>timestamp-1) ] with-string-reader ;
\r
223 : (cookie-string>timestamp-2) ( -- timestamp )
\r
225 read-sp check-day-name
\r
226 read-sp month-abbreviations index 1+ check-timestamp >>month
\r
227 read-sp checked-number >>day
\r
228 ":" read-token checked-number >>hour
\r
229 ":" read-token checked-number >>minute
\r
230 " " read-token checked-number >>second
\r
231 read-sp checked-number >>year
\r
232 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
234 : cookie-string>timestamp-2 ( str -- timestamp )
\r
235 [ (cookie-string>timestamp-2) ] with-string-reader ;
\r
237 : cookie-string>timestamp ( str -- timestamp )
\r
239 [ cookie-string>timestamp-1 ]
\r
240 [ cookie-string>timestamp-2 ]
\r
241 [ rfc822>timestamp ]
\r
242 } attempt-all-quots ;
\r
244 : (ymdhms>timestamp) ( -- timestamp )
\r
245 read-ymd " " expect read-hms instant <timestamp> ;
\r
247 : ymdhms>timestamp ( str -- timestamp )
\r
248 [ (ymdhms>timestamp) ] with-string-reader ;
\r
250 : (hms>timestamp) ( -- timestamp )
\r
251 0 0 0 read-hms instant <timestamp> ;
\r
253 : hms>timestamp ( str -- timestamp )
\r
254 [ (hms>timestamp) ] with-string-reader ;
\r
256 : (ymd>timestamp) ( -- timestamp )
\r
257 read-ymd 0 0 0 instant <timestamp> ;
\r
259 : ymd>timestamp ( str -- timestamp )
\r
260 [ (ymd>timestamp) ] with-string-reader ;
\r
262 : (timestamp>ymd) ( timestamp -- )
\r
263 { YYYY "-" MM "-" DD } formatted ;
\r
265 : timestamp>ymd ( timestamp -- str )
\r
266 [ (timestamp>ymd) ] with-string-writer ;
\r
268 : (timestamp>hms) ( timestamp -- )
\r
269 { hh ":" mm ":" ss } formatted ;
\r
271 : timestamp>hms ( timestamp -- str )
\r
272 [ (timestamp>hms) ] with-string-writer ;
\r
274 : timestamp>ymdhms ( timestamp -- str )
\r
277 { (timestamp>ymd) " " (timestamp>hms) } formatted
\r
278 ] with-string-writer ;
\r
280 : file-time-string ( timestamp -- string )
\r
285 dup now [ year>> ] bi@ =
\r
286 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
\r
289 ] with-string-writer ;
\r