1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
;;;; date.jl -- Date manipulation
;;; Copyright (C) 1997 John Harper <john@dcs.warwick.ac.uk>
;;; $Id: date.jl,v 1.11 2000/09/08 14:57:47 john Exp $
;;; This file is part of Jade.
;;; Jade is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;; Jade is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with Jade; see the file COPYING. If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(declare (unsafe-for-call/cc))
(define-structure rep.util.date
(export parse-date
date-vec-day-abbrev
date-vec-day
date-vec-month-abbrev
date-vec-month
date-vec-year
date-vec-hour
date-vec-minute
date-vec-second
date-vec-timezone
date-vec-epoch-time)
(open rep
rep.system
rep.regexp)
(define-structure-alias date rep.util.date)
(define date-month-alist '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)
("January" . 1) ("February" . 2) ("March" . 3)
("April" . 4) ("June" . 6) ("July" . 7)
("August" . 8) ("September" . 9) ("October" . 10)
("November" . 11) ("December" . 12))
"Alist of (MONTH-NAME . MONTH-NUM).")
(define date-timezone-alist
'(("UT" . 0) ("GMT" . 0)
("EST" . -300) ("EDT" . -240)
("CST" . -360) ("CDT" . -300)
("MST" . -420) ("MDT" . -360)
("PST" . -480) ("PDT" . -420))
"Alist of (TIMEZONE . MINUTES-DIFFERENCE).")
(define date-two-digit-year-prefix (substring (current-time-string) 20 22)
"A two-digit string that will be prepended to year specifications that
only have two, lower order, digits. This is picked up automatically from
the current year, i.e. 1997 -> \"19\", 2001 -> \"20\".")
;; Date parsing
;; Constants defining date structure fields
(defconst date-vec-day-abbrev 0)
(defconst date-vec-day 1)
(defconst date-vec-month-abbrev 2)
(defconst date-vec-month 3)
(defconst date-vec-year 4)
(defconst date-vec-hour 5)
(defconst date-vec-minute 6)
(defconst date-vec-second 7)
(defconst date-vec-timezone 8)
(defconst date-vec-epoch-time 9)
;; Parse the date header at position POINT in STRING, returns vector
;; [DAY-ABBREV DAY MONTH-ABBREV MONTH YEAR HOUR MINUTE SECOND
;; TZ-STRING TIME_T]
(defun parse-date (string #!optional point)
"Parse the date specifiction in STRING, optionally starting at the POINT'th
character in the string. This will parse dates in RFC-822 mail messages."
(unless point (setq point 0))
(let
((day-abbrev "")
(day -1)
(month-abbrev "")
(month -1)
(year -1)
(hour 0)
(minute 0)
(second 0)
(timezone 0)
time_t tem)
(while (< point (length string))
(cond
((string-looking-at "[\t ]*([0-9]+)([\t ]+|$)" string point)
(let*
((start (match-start 1))
(end (match-end 1))
(value (string->number (substring string start end))))
;; Could be year or day of month
(if (or (>= day 0) (> (- end start) 2))
;; Assume year
(if (= (- end start) 2)
;; two-digit year
(setq year (+ (* 100 (string->number
date-two-digit-year-prefix)) value))
(setq year value))
(setq day value))
(setq point end)))
((string-looking-at
"[\t ]*([0-9]+):([0-9]+)(:[0-9]+)?[\t ]*([A-Z]+|[+-][0-9]+)?[\t ]*"
string point)
;; Time spec.
(setq point (match-end))
(setq hour (string->number (substring string (match-start 1)
(match-end 1)))
minute (string->number (substring string (match-start 2)
(match-end 2)))
second (if (equal (match-start 3) (match-end 3))
0
(string->number (substring string (1+ (match-start 3))
(match-end 3))))
timezone (if (equal (match-start 4) (match-end 4))
"UT"
(substring string (match-start 4) (match-end 4))))
(if (setq tem (assoc timezone date-timezone-alist))
(setq timezone (cdr tem))
;; Try +-HHMM
(if (string-looking-at "[+-]([0-9][0-9])([0-9][0-9])" timezone)
(setq timezone (* (if (= (aref timezone 0) ?+) 1 -1)
(+ (* 60 (string->number
(substring timezone
(match-start 1)
(match-end 1))))
(string->number
(substring timezone
(match-start 2)
(match-end 2))))))
;; whatever..
(setq timezone 0))))
((string-looking-at
"[\t ]*(Mon|Tue|Wed|Thu|Fri|Sat|Sun)[a-z]*[\t ]*,?[\t ]*"
string point t)
;; Found day spec
(setq day-abbrev (substring string (match-start 1) (match-end 1)))
(setq point (match-end)))
((string-looking-at
"[\t ]*(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[a-z]*[\t ]*"
string point t)
;; Month name
(setq month-abbrev (substring string (match-start 1) (match-end 1)))
(setq month (cdr (assoc month-abbrev date-month-alist)))
(setq point (match-end)))
((string-looking-at
"[\t ]*([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9])[\t ]*"
string point)
;; ISO 8601 calendar date YYYY-MM-DD
(setq year (string->number (expand-last-match "\\1")))
(setq month (string->number (expand-last-match "\\2")))
(setq month-abbrev (car (rassq month date-month-alist)))
(setq day (string->number (expand-last-match "\\3")))
;; XXX day of week calculation
(setq point (match-end)))
(t
;; Garbage in -- garbage out
(setq point (length string)))))
(when (< year 0)
(setq year (string->number (current-time-string nil "%Y"))))
(when (< month 0)
(setq month (string->number (current-time-string nil "%m"))))
(when (< day 0)
(setq day (string->number (current-time-string nil "%d"))))
;; Use Gauss' algorithm (?) to find seconds since 1970
;; This subroutine is copied from my VMM operating system,
;; which was in turn copied from Linux
(let
((g-month (- month 2))
(g-year year)
total-seconds total-days)
(when (>= 0 g-month)
;; Put feb last since it has leap day
(setq g-month (+ g-month 12)
g-year (1- g-year)))
;; (DAYS . SECONDS)
(setq total-days (+ (- (quotient g-year 4)
(quotient g-year 100))
(quotient g-year 400)
(quotient (* 367 g-month) 12)
day
(* g-year 365)
-719499)
total-seconds (+ second (* 60 (+ minute
(- timezone)
(* 60 hour)))))
(setq time_t (fix-time (cons total-days total-seconds))))
(when (and (string= day-abbrev "") time_t)
;; January 1, 1970 was a Thursday
(let
((dow (% (+ (car time_t) 4) 7)))
(when (< dow 0)
(setq dow (+ dow 7)))
(setq day-abbrev
(aref ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"] dow))))
(vector day-abbrev day month-abbrev month
year hour minute second timezone time_t))))
|
