/[rfc2822]/rfc2822/date.lisp
ViewVC logotype

Contents of /rfc2822/date.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Wed Aug 13 14:03:52 2003 UTC (10 years, 8 months ago) by eenge
Branch: MAIN, eenge
CVS Tags: init, HEAD
Changes since 1.1: +0 -0 lines
initial import
1 ;;;; $Id: date.lisp,v 1.1.1.1 2003/08/13 14:03:52 eenge Exp $
2 ;;;; $Source: /tiger/var/lib/cvsroots/rfc2822/rfc2822/date.lisp,v $
3
4 ;;;; Authored by Erik Enge, <erik@nittin.net>.
5 ;;;;
6 ;;;; See the COPYING file for licensing information.
7
8 ;;;; As you will see, if have chosen "sec" and "time-" instead of
9 ;;;; "second" and "time"; the reason is that CL-USER already defines
10 ;;;; these and that CMUCL complains about it. I think the real fix is
11 ;;;; to not :use :cl. I'll do that once I'm done with the code,
12 ;;;; because I don't really like having to do cl-user:.
13
14 (in-package :rfc2822)
15
16 ;;
17 ;; Date
18 ;;
19
20 (let* ((month-symbol '((:january "Jan")
21 (:february "Feb")
22 (:march "Mar")
23 (:april "Apr")
24 (:may "May")
25 (:june "Jun")
26 (:july "Jul")
27 (:august "Aug")
28 (:september "Sep")
29 (:october "Oct")
30 (:november "Nov")
31 (:december "Dec")
32 (nil nil)))
33 (day-symbol '((:monday "Mon")
34 (:tuesday "Tue")
35 (:wednesday "Wed")
36 (:thursday "Thu")
37 (:friday "Fri")
38 (nil nil)))
39 (month-string (mapcar #'reverse month-symbol))
40 (day-string (mapcar #'reverse day-symbol)))
41 (defun get-month-string (symbol)
42 (second (assoc symbol month-symbol)))
43 (defun get-month-symbol (string)
44 (second (assoc string month-string :test #'equal)))
45 (defun get-day-string (symbol)
46 (second (assoc symbol day-symbol)))
47 (defun get-day-symbol (string)
48 (second (assoc string day-string :test #'equal))))
49
50 (defclass date ()
51 ((zone
52 :accessor zone
53 :initarg :zone
54 :documentation "The zone specifies the offset from Coordinated
55 Universal Time (UTC, formerly referred to as \"Greenwich Mean Time\")
56 that the date and time-of-day represent. The \"+\" or \"-\" indicates
57 whether the time-of-day is ahead of (i.e., east of) or behind (i.e.,
58 west of) Universal Time. The first two digits indicate the number of
59 hours difference from Universal Time, and the last two digits indicate
60 the number of minutes difference from Universal Time. (Hence, +hhmm
61 means +(hh * 60 + mm) minutes, and -hhmm means -(hh * 60 + mm)
62 minutes). The form \"+0000\" SHOULD be used to indicate a time zone
63 at Universal Time. Though \"-0000\" also indicates Universal Time, it
64 is used to indicate that the time was generated on a system that may
65 be in a local time zone other than Universal Time and therefore
66 indicates that the date-time contains no information about the local
67 time zone.")
68 (seconds
69 :accessor seconds
70 :initarg :seconds
71 :initform nil)
72 (minutes
73 :accessor minutes
74 :initarg :minutes
75 :initform nil)
76 (hours
77 :accessor hours
78 :initarg :hours
79 :initform nil)
80 (day
81 :accessor day
82 :initarg :day
83 :documentation "The day is the numeric day of the month.")
84 (month-name
85 :accessor month-name
86 :initarg :month-name)
87 (year
88 :accessor year
89 :initarg :year
90 :documentation "The year is any numeric year 1900 or later.")
91 (day-of-week
92 :accessor day-of-week
93 :initarg :day-of-week
94 :initform nil))
95 (:documentation "Represents an RFC2822 date"))
96
97 (defun parse-day-of-week (string)
98 "Get day-of-week from string or nil"
99 (multiple-value-bind (start end)
100 (cl-ppcre:scan (get-scanner :day-of-week) (string-trim " " string))
101 (if (and start end)
102 (subseq string start end)
103 nil)))
104
105 (defun parse-day (string)
106 "Get day from string or nil"
107 (multiple-value-bind (start end)
108 (cl-ppcre:scan (get-scanner :day) string)
109 (if (and start end)
110 (parse-integer (subseq string start end))
111 nil)))
112
113 (defun parse-month (string)
114 "Get month from string or nil"
115 (multiple-value-bind (start end)
116 (cl-ppcre:scan (get-scanner :month) string)
117 (if (and start end)
118 (subseq string start end)
119 nil)))
120
121 (defun parse-year (string)
122 "Get year from string or nil"
123 (multiple-value-bind (start end)
124 (cl-ppcre:scan (get-scanner :year) string)
125 (if (and start end)
126 (parse-integer (subseq string start end))
127 nil)))
128
129 (defun parse-second (time-string)
130 "Get second from string (parsed by parse-time)"
131 (let ((list (cl-ppcre:split ":" time-string)))
132 (when (third list)
133 (parse-integer (first (cl-ppcre:split " " (third list)))))))
134
135 (defun parse-minute (time-string)
136 "Get minute from string (parsed by parse-time)"
137 (let ((list (cl-ppcre:split ":" time-string)))
138 (parse-integer (second list))))
139
140 (defun parse-hour (time-string)
141 "Get hour from string (parsed by parse-time)"
142 (let ((list (cl-ppcre:split ":" time-string)))
143 (parse-integer (car (last (cl-ppcre:split " " (first list)))))))
144
145 (defun parse-zone (string)
146 "Get zone from string or nil"
147 (let ((time (parse-time string)))
148 (when time
149 (multiple-value-bind (start end)
150 (cl-ppcre:scan (get-scanner :zone) time)
151 (if (and start end)
152 (parse-integer (subseq time start end))
153 nil)))))
154
155 (defun parse-time (string)
156 "Get time from string or nil"
157 (multiple-value-bind (start end)
158 (cl-ppcre:scan (get-scanner :time) string)
159 (if (and start end)
160 (subseq string start end)
161 nil)))
162
163 (defun parse-date (string)
164 "Parse string and make a date from it."
165 (let ((time (parse-time string)))
166 (if time
167 (make-instance 'date
168 :zone (parse-zone string)
169 :seconds (parse-second time)
170 :minutes (parse-minute time)
171 :hours (parse-hour time)
172 :day (parse-day string)
173 :month-name (get-month-symbol (parse-month string))
174 :year (parse-year string)
175 :day-of-week (get-day-symbol (parse-day-of-week string)))
176 (make-instance 'date
177 :zone (parse-zone string)
178 :day (parse-day string)
179 :month-name (get-month-symbol (parse-month string))
180 :year (parse-year string)
181 :day-of-week (get-day-symbol (parse-day-of-week string))))))
182
183 (defmethod write-object ((date date) &key (stream nil))
184 "Write representation of object to stream or return string"
185 (let ((pp-zone (format nil "~A~4,'0d" (if (minusp (zone date))
186 "-"
187 "+")
188 (if (minusp (zone date))
189 (* (zone date) -1)
190 (zone date))))
191 (pp-hours (format nil "~2,'0d" (hours date)))
192 (pp-minutes (format nil "~2,'0d" (minutes date)))
193 (pp-seconds (format nil "~2,'0d" (seconds date))))
194 (cond
195 ((and (seconds date) (day-of-week date))
196 (format stream "~A, ~A ~A ~A ~A:~A:~A ~A~%"
197 (get-day-string (day-of-week date))
198 (day date)
199 (get-month-string (month-name date))
200 (year date)
201 pp-hours
202 pp-minutes
203 pp-seconds
204 pp-zone))
205 ((seconds date)
206 (format stream "~A ~A ~A ~A:~A:~A ~A~%"
207 (day date)
208 (get-month-string (month-name date))
209 (year date)
210 pp-hours
211 pp-minutes
212 pp-seconds
213 pp-zone))
214 ((day-of-week date)
215 (format stream "~A, ~A ~A ~A ~A:~A ~A~%"
216 (get-day-string (day-of-week date))
217 (day date)
218 (get-month-string (month-name date))
219 (year date)
220 pp-hours
221 pp-minutes
222 pp-zone)))))

  ViewVC Help
Powered by ViewVC 1.1.5