| 1 |
(in-package :bknr.utils) |
|---|
| 2 |
|
|---|
| 3 |
;;; ********************************************************************** |
|---|
| 4 |
;;; This code was written as part of the CMU Common Lisp project at |
|---|
| 5 |
;;; Carnegie Mellon University, and has been placed in the public domain. |
|---|
| 6 |
;;; |
|---|
| 7 |
|
|---|
| 8 |
;;; It was subsequently borrowed and modified slightly by Daniel |
|---|
| 9 |
;;; Barlow <dan@telent.net> to become part of the net-telent-date |
|---|
| 10 |
;;; package. Daniel, Tue May 22 05:45:27 BST 2001 |
|---|
| 11 |
|
|---|
| 12 |
;;; ********************************************************************** |
|---|
| 13 |
|
|---|
| 14 |
;;; Parsing routines for time and date strings. PARSE-TIME returns the |
|---|
| 15 |
;;; universal time integer for the time and/or date given in the string. |
|---|
| 16 |
|
|---|
| 17 |
;;; Written by Jim Healy, June 1987. |
|---|
| 18 |
|
|---|
| 19 |
;;; ********************************************************************** |
|---|
| 20 |
|
|---|
| 21 |
(defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`)) |
|---|
| 22 |
(defvar time-dividers '(#\: #\.)) |
|---|
| 23 |
(defvar date-dividers '(#\\ #\/ #\-)) |
|---|
| 24 |
|
|---|
| 25 |
(defvar *error-on-mismatch* nil |
|---|
| 26 |
"If t, an error will be signalled if parse-time is unable |
|---|
| 27 |
to determine the time/date format of the string.") |
|---|
| 28 |
|
|---|
| 29 |
;;; Set up hash tables for month, weekday, zone, and special strings. |
|---|
| 30 |
;;; Provides quick, easy access to associated information for these items. |
|---|
| 31 |
|
|---|
| 32 |
;;; Hashlist takes an association list and hashes each pair into the |
|---|
| 33 |
;;; specified tables using the car of the pair as the key and the cdr as |
|---|
| 34 |
;;; the data object. |
|---|
| 35 |
|
|---|
| 36 |
(defmacro hashlist (list table) |
|---|
| 37 |
`(dolist (item ,list) |
|---|
| 38 |
(setf (gethash (car item) ,table) (cdr item)))) |
|---|
| 39 |
|
|---|
| 40 |
(defparameter weekday-table-size 23) |
|---|
| 41 |
(defparameter month-table-size 31) |
|---|
| 42 |
(defparameter zone-table-size 11) |
|---|
| 43 |
(defparameter special-table-size 11) |
|---|
| 44 |
|
|---|
| 45 |
(defvar *weekday-strings* (make-hash-table :test #'equal |
|---|
| 46 |
:size weekday-table-size)) |
|---|
| 47 |
|
|---|
| 48 |
(defvar *month-strings* (make-hash-table :test #'equal |
|---|
| 49 |
:size month-table-size)) |
|---|
| 50 |
|
|---|
| 51 |
(defvar *zone-strings* (make-hash-table :test #'equal |
|---|
| 52 |
:size zone-table-size)) |
|---|
| 53 |
|
|---|
| 54 |
(defvar *special-strings* (make-hash-table :test #'equal |
|---|
| 55 |
:size special-table-size)) |
|---|
| 56 |
|
|---|
| 57 |
;;; Load-time creation of the hash tables. |
|---|
| 58 |
|
|---|
| 59 |
(hashlist '(("monday" . 0) ("mon" . 0) |
|---|
| 60 |
("tuesday" . 1) ("tues" . 1) ("tue" . 1) |
|---|
| 61 |
("wednesday" . 2) ("wednes" . 2) ("wed" . 2) |
|---|
| 62 |
("thursday" . 3) ("thurs" . 3) ("thu" . 3) |
|---|
| 63 |
("friday" . 4) ("fri" . 4) |
|---|
| 64 |
("saturday" . 5) ("sat" . 5) |
|---|
| 65 |
("sunday" . 6) ("sun" . 6)) |
|---|
| 66 |
*weekday-strings*) |
|---|
| 67 |
|
|---|
| 68 |
(hashlist '(("january" . 1) ("jan" . 1) |
|---|
| 69 |
("february" . 2) ("feb" . 2) |
|---|
| 70 |
("march" . 3) ("mar" . 3) |
|---|
| 71 |
("april" . 4) ("apr" . 4) |
|---|
| 72 |
("may" . 5) ("june" . 6) |
|---|
| 73 |
("jun" . 6) ("july" . 7) |
|---|
| 74 |
("jul" . 7) ("august" . 8) |
|---|
| 75 |
("aug" . 8) ("september" . 9) |
|---|
| 76 |
("sept" . 9) ("sep" . 9) |
|---|
| 77 |
("october" . 10) ("oct" . 10) |
|---|
| 78 |
("november" . 11) ("nov" . 11) |
|---|
| 79 |
("december" . 12) ("dec" . 12)) |
|---|
| 80 |
*month-strings*) |
|---|
| 81 |
|
|---|
| 82 |
(hashlist '(("gmt" . 0) ("est" . 5) |
|---|
| 83 |
("edt" . 4) ("cst" . 6) |
|---|
| 84 |
("cdt" . 5) ("mst" . 7) |
|---|
| 85 |
("mdt" . 6) ("pst" . 8) |
|---|
| 86 |
("pdt" . 7)) |
|---|
| 87 |
*zone-strings*) |
|---|
| 88 |
|
|---|
| 89 |
(hashlist '(("yesterday" . yesterday) ("today" . today) |
|---|
| 90 |
("tomorrow" . tomorrow) ("now" . now)) |
|---|
| 91 |
*special-strings*) |
|---|
| 92 |
|
|---|
| 93 |
;;; Time/date format patterns are specified as lists of symbols repre- |
|---|
| 94 |
;;; senting the elements. Optional elements can be specified by |
|---|
| 95 |
;;; enclosing them in parentheses. Note that the order in which the |
|---|
| 96 |
;;; patterns are specified below determines the order of search. |
|---|
| 97 |
|
|---|
| 98 |
;;; Choices of pattern symbols are: second, minute, hour, day, month, |
|---|
| 99 |
;;; year, time-divider, date-divider, am-pm, zone, izone, weekday, |
|---|
| 100 |
;;; noon-midn, and any special symbol. |
|---|
| 101 |
|
|---|
| 102 |
(defparameter *default-date-time-patterns* |
|---|
| 103 |
'( |
|---|
| 104 |
;; Date formats. |
|---|
| 105 |
((weekday) month (date-divider) day (date-divider) year (noon-midn)) |
|---|
| 106 |
((weekday) day (date-divider) month (date-divider) year (noon-midn)) |
|---|
| 107 |
((weekday) month (date-divider) day (noon-midn)) |
|---|
| 108 |
(year (date-divider) month (date-divider) day (noon-midn)) |
|---|
| 109 |
(month (date-divider) year (noon-midn)) |
|---|
| 110 |
(year (date-divider) month (noon-midn)) |
|---|
| 111 |
|
|---|
| 112 |
((noon-midn) (weekday) month (date-divider) day (date-divider) year) |
|---|
| 113 |
((noon-midn) (weekday) day (date-divider) month (date-divider) year) |
|---|
| 114 |
((noon-midn) (weekday) month (date-divider) day) |
|---|
| 115 |
((noon-midn) year (date-divider) month (date-divider) day) |
|---|
| 116 |
((noon-midn) month (date-divider) year) |
|---|
| 117 |
((noon-midn) year (date-divider) month) |
|---|
| 118 |
|
|---|
| 119 |
;; Time formats. |
|---|
| 120 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 121 |
(date-divider) (zone)) |
|---|
| 122 |
(noon-midn) |
|---|
| 123 |
(hour (noon-midn)) |
|---|
| 124 |
|
|---|
| 125 |
;; Time/date combined formats. |
|---|
| 126 |
((weekday) month (date-divider) day (date-divider) year |
|---|
| 127 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 128 |
(am-pm) (date-divider) (zone)) |
|---|
| 129 |
((weekday) day (date-divider) month (date-divider) year |
|---|
| 130 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 131 |
(am-pm) (date-divider) (zone)) |
|---|
| 132 |
((weekday) month (date-divider) day |
|---|
| 133 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 134 |
(am-pm) (date-divider) (zone)) |
|---|
| 135 |
(year (date-divider) month (date-divider) day |
|---|
| 136 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 137 |
(am-pm) (date-divider) (zone)) |
|---|
| 138 |
(month (date-divider) year |
|---|
| 139 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 140 |
(am-pm) (date-divider) (zone)) |
|---|
| 141 |
(year (date-divider) month |
|---|
| 142 |
hour (time-divider) (minute) (time-divider) (secondp) |
|---|
| 143 |
(am-pm) (date-divider) (zone)) |
|---|
| 144 |
|
|---|
| 145 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 146 |
(date-divider) (zone) (weekday) month (date-divider) |
|---|
| 147 |
day (date-divider) year) |
|---|
| 148 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 149 |
(date-divider) (zone) (weekday) day (date-divider) |
|---|
| 150 |
month (date-divider) year) |
|---|
| 151 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 152 |
(date-divider) (zone) (weekday) month (date-divider) |
|---|
| 153 |
day) |
|---|
| 154 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 155 |
(date-divider) (zone) year (date-divider) month |
|---|
| 156 |
(date-divider) day) |
|---|
| 157 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 158 |
(date-divider) (zone) month (date-divider) year) |
|---|
| 159 |
(hour (time-divider) (minute) (time-divider) (secondp) (am-pm) |
|---|
| 160 |
(date-divider) (zone) year (date-divider) month) |
|---|
| 161 |
|
|---|
| 162 |
;; Weird, non-standard formats. |
|---|
| 163 |
(weekday month day hour (time-divider) minute (time-divider) |
|---|
| 164 |
secondp (am-pm) |
|---|
| 165 |
(zone) year) |
|---|
| 166 |
((weekday) day (date-divider) month (date-divider) year hour |
|---|
| 167 |
(time-divider) minute (time-divider) (secondp) (am-pm) |
|---|
| 168 |
(date-divider) (zone)) |
|---|
| 169 |
((weekday) month (date-divider) day (date-divider) year hour |
|---|
| 170 |
(time-divider) minute (time-divider) (secondp) (am-pm) |
|---|
| 171 |
(date-divider) (zone)) |
|---|
| 172 |
|
|---|
| 173 |
;; Special-string formats. |
|---|
| 174 |
(now (yesterday)) |
|---|
| 175 |
((yesterday) now) |
|---|
| 176 |
(now (today)) |
|---|
| 177 |
((today) now) |
|---|
| 178 |
(now (tomorrow)) |
|---|
| 179 |
((tomorrow) now) |
|---|
| 180 |
(yesterday (noon-midn)) |
|---|
| 181 |
((noon-midn) yesterday) |
|---|
| 182 |
(today (noon-midn)) |
|---|
| 183 |
((noon-midn) today) |
|---|
| 184 |
(tomorrow (noon-midn)) |
|---|
| 185 |
((noon-midn) tomorrow) |
|---|
| 186 |
)) |
|---|
| 187 |
|
|---|
| 188 |
;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C. |
|---|
| 189 |
(defparameter *http-date-time-patterns* |
|---|
| 190 |
'( |
|---|
| 191 |
;; RFC1123/RFC822 and RFC850. |
|---|
| 192 |
((weekday) day (date-divider) month (date-divider) year |
|---|
| 193 |
hour time-divider minute (time-divider) (secondp) izone) |
|---|
| 194 |
((weekday) day (date-divider) month (date-divider) year |
|---|
| 195 |
hour time-divider minute (time-divider) (secondp) (zone)) |
|---|
| 196 |
|
|---|
| 197 |
;; ANSI-C. |
|---|
| 198 |
((weekday) month day |
|---|
| 199 |
hour time-divider minute (time-divider) (secondp) year))) |
|---|
| 200 |
|
|---|
| 201 |
|
|---|
| 202 |
;;; The decoded-time structure holds the time/date values which are |
|---|
| 203 |
;;; eventually passed to 'encode-universal-time' after parsing. |
|---|
| 204 |
|
|---|
| 205 |
;;; Note: Currently nothing is done with the day of the week. It might |
|---|
| 206 |
;;; be appropriate to add a function to see if it matches the date. |
|---|
| 207 |
|
|---|
| 208 |
(defstruct decoded-time |
|---|
| 209 |
(second 0 :type integer) ; Value between 0 and 59. |
|---|
| 210 |
(minute 0 :type integer) ; Value between 0 and 59. |
|---|
| 211 |
(hour 0 :type integer) ; Value between 0 and 23. |
|---|
| 212 |
(day 1 :type integer) ; Value between 1 and 31. |
|---|
| 213 |
(month 1 :type integer) ; Value between 1 and 12. |
|---|
| 214 |
(year 1900 :type integer) ; Value above 1899 or between 0 and 99. |
|---|
| 215 |
(zone 0 :type rational) ; Value between -24 and 24 inclusive. |
|---|
| 216 |
(dotw 0 :type integer)) ; Value between 0 and 6. |
|---|
| 217 |
|
|---|
| 218 |
;;; Make-default-time returns a decoded-time structure with the default |
|---|
| 219 |
;;; time values already set. The default time is currently 00:00 on |
|---|
| 220 |
;;; the current day, current month, current year, and current time-zone. |
|---|
| 221 |
|
|---|
| 222 |
(defun make-default-time (def-sec def-min def-hour def-day |
|---|
| 223 |
def-mon def-year def-zone def-dotw) |
|---|
| 224 |
(let ((default-time (make-decoded-time))) |
|---|
| 225 |
(multiple-value-bind (sec min hour day mon year dotw dst zone) |
|---|
| 226 |
(get-decoded-time) |
|---|
| 227 |
(declare (ignore dst)) |
|---|
| 228 |
(if def-sec |
|---|
| 229 |
(if (eq def-sec :current) |
|---|
| 230 |
(setf (decoded-time-second default-time) sec) |
|---|
| 231 |
(setf (decoded-time-second default-time) def-sec)) |
|---|
| 232 |
(setf (decoded-time-second default-time) 0)) |
|---|
| 233 |
(if def-min |
|---|
| 234 |
(if (eq def-min :current) |
|---|
| 235 |
(setf (decoded-time-minute default-time) min) |
|---|
| 236 |
(setf (decoded-time-minute default-time) def-min)) |
|---|
| 237 |
(setf (decoded-time-minute default-time) 0)) |
|---|
| 238 |
(if def-hour |
|---|
| 239 |
(if (eq def-hour :current) |
|---|
| 240 |
(setf (decoded-time-hour default-time) hour) |
|---|
| 241 |
(setf (decoded-time-hour default-time) def-hour)) |
|---|
| 242 |
(setf (decoded-time-hour default-time) 0)) |
|---|
| 243 |
(if def-day |
|---|
| 244 |
(if (eq def-day :current) |
|---|
| 245 |
(setf (decoded-time-day default-time) day) |
|---|
| 246 |
(setf (decoded-time-day default-time) def-day)) |
|---|
| 247 |
(setf (decoded-time-day default-time) day)) |
|---|
| 248 |
(if def-mon |
|---|
| 249 |
(if (eq def-mon :current) |
|---|
| 250 |
(setf (decoded-time-month default-time) mon) |
|---|
| 251 |
(setf (decoded-time-month default-time) def-mon)) |
|---|
| 252 |
(setf (decoded-time-month default-time) mon)) |
|---|
| 253 |
(if def-year |
|---|
| 254 |
(if (eq def-year :current) |
|---|
| 255 |
(setf (decoded-time-year default-time) year) |
|---|
| 256 |
(setf (decoded-time-year default-time) def-year)) |
|---|
| 257 |
(setf (decoded-time-year default-time) year)) |
|---|
| 258 |
(if def-zone |
|---|
| 259 |
(if (eq def-zone :current) |
|---|
| 260 |
(setf (decoded-time-zone default-time) zone) |
|---|
| 261 |
(setf (decoded-time-zone default-time) def-zone)) |
|---|
| 262 |
(setf (decoded-time-zone default-time) zone)) |
|---|
| 263 |
(if def-dotw |
|---|
| 264 |
(if (eq def-dotw :current) |
|---|
| 265 |
(setf (decoded-time-dotw default-time) dotw) |
|---|
| 266 |
(setf (decoded-time-dotw default-time) def-dotw)) |
|---|
| 267 |
(setf (decoded-time-dotw default-time) dotw)) |
|---|
| 268 |
default-time))) |
|---|
| 269 |
|
|---|
| 270 |
;;; Converts the values in the decoded-time structure to universal time |
|---|
| 271 |
;;; by calling encode-universal-time. |
|---|
| 272 |
;;; If zone is in numerical form, tweeks it appropriately. |
|---|
| 273 |
|
|---|
| 274 |
(defun convert-to-unitime (parsed-values) |
|---|
| 275 |
(let ((zone (decoded-time-zone parsed-values))) |
|---|
| 276 |
(encode-universal-time (decoded-time-second parsed-values) |
|---|
| 277 |
(decoded-time-minute parsed-values) |
|---|
| 278 |
(decoded-time-hour parsed-values) |
|---|
| 279 |
(decoded-time-day parsed-values) |
|---|
| 280 |
(decoded-time-month parsed-values) |
|---|
| 281 |
(decoded-time-year parsed-values) |
|---|
| 282 |
(if (or (> zone 24) (< zone -24)) |
|---|
| 283 |
(let ((new-zone (/ zone 100))) |
|---|
| 284 |
(cond ((minusp new-zone) (- new-zone)) |
|---|
| 285 |
((plusp new-zone) (- 24 new-zone)) |
|---|
| 286 |
;; must be zero (GMT) |
|---|
| 287 |
(t new-zone))) |
|---|
| 288 |
zone)))) |
|---|
| 289 |
|
|---|
| 290 |
;;; Sets the current values for the time and/or date parts of the |
|---|
| 291 |
;;; decoded time structure. |
|---|
| 292 |
|
|---|
| 293 |
(defun set-current-value (values-structure &key (time nil) (date nil) |
|---|
| 294 |
(zone nil)) |
|---|
| 295 |
(multiple-value-bind (sec min hour day mon year dotw dst tz) |
|---|
| 296 |
(get-decoded-time) |
|---|
| 297 |
(declare (ignore dst)) |
|---|
| 298 |
(when time |
|---|
| 299 |
(setf (decoded-time-second values-structure) sec) |
|---|
| 300 |
(setf (decoded-time-minute values-structure) min) |
|---|
| 301 |
(setf (decoded-time-hour values-structure) hour)) |
|---|
| 302 |
(when date |
|---|
| 303 |
(setf (decoded-time-day values-structure) day) |
|---|
| 304 |
(setf (decoded-time-month values-structure) mon) |
|---|
| 305 |
(setf (decoded-time-year values-structure) year) |
|---|
| 306 |
(setf (decoded-time-dotw values-structure) dotw)) |
|---|
| 307 |
(when zone |
|---|
| 308 |
(setf (decoded-time-zone values-structure) tz)))) |
|---|
| 309 |
|
|---|
| 310 |
;;; Special function definitions. To define a special substring, add |
|---|
| 311 |
;;; a dotted pair consisting of the substring and a symbol in the |
|---|
| 312 |
;;; *special-strings* hashlist statement above. Then define a function |
|---|
| 313 |
;;; here which takes one argument- the decoded time structure- and |
|---|
| 314 |
;;; sets the values of the structure to whatever is necessary. Also, |
|---|
| 315 |
;;; add a some patterns to the patterns list using whatever combinations |
|---|
| 316 |
;;; of special and pre-existing symbols desired. |
|---|
| 317 |
|
|---|
| 318 |
(defun yesterday (parsed-values) |
|---|
| 319 |
(set-current-value parsed-values :date t :zone t) |
|---|
| 320 |
(setf (decoded-time-day parsed-values) |
|---|
| 321 |
(1- (decoded-time-day parsed-values)))) |
|---|
| 322 |
|
|---|
| 323 |
(defun today (parsed-values) |
|---|
| 324 |
(set-current-value parsed-values :date t :zone t)) |
|---|
| 325 |
|
|---|
| 326 |
(defun tomorrow (parsed-values) |
|---|
| 327 |
(set-current-value parsed-values :date t :zone t) |
|---|
| 328 |
(setf (decoded-time-day parsed-values) |
|---|
| 329 |
(1+ (decoded-time-day parsed-values)))) |
|---|
| 330 |
|
|---|
| 331 |
(defun now (parsed-values) |
|---|
| 332 |
(set-current-value parsed-values :time t)) |
|---|
| 333 |
|
|---|
| 334 |
;;; Predicates for symbols. Each symbol has a corresponding function |
|---|
| 335 |
;;; defined here which is applied to a part of the datum to see if |
|---|
| 336 |
;;; it matches the qualifications. |
|---|
| 337 |
|
|---|
| 338 |
(defun am-pm (string) |
|---|
| 339 |
(and (simple-string-p string) |
|---|
| 340 |
(cond ((string= string "am") 'am) |
|---|
| 341 |
((string= string "pm") 'pm) |
|---|
| 342 |
(t nil)))) |
|---|
| 343 |
|
|---|
| 344 |
(defun noon-midn (string) |
|---|
| 345 |
(and (simple-string-p string) |
|---|
| 346 |
(cond ((string= string "noon") 'noon) |
|---|
| 347 |
((string= string "midnight") 'midn) |
|---|
| 348 |
(t nil)))) |
|---|
| 349 |
|
|---|
| 350 |
(defun weekday (string) |
|---|
| 351 |
(and (simple-string-p string) (gethash string *weekday-strings*))) |
|---|
| 352 |
|
|---|
| 353 |
(defun month (thing) |
|---|
| 354 |
(or (and (simple-string-p thing) (gethash thing *month-strings*)) |
|---|
| 355 |
(and (integerp thing) (<= 1 thing 12)))) |
|---|
| 356 |
|
|---|
| 357 |
(defun zone (thing) |
|---|
| 358 |
(or (and (simple-string-p thing) (gethash thing *zone-strings*)) |
|---|
| 359 |
(if (integerp thing) |
|---|
| 360 |
(let ((zone (/ thing 100))) |
|---|
| 361 |
(and (integerp zone) (<= -24 zone 24)))))) |
|---|
| 362 |
|
|---|
| 363 |
;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. |
|---|
| 364 |
(defun izone (thing) |
|---|
| 365 |
(if (integerp thing) |
|---|
| 366 |
(multiple-value-bind (hours mins) |
|---|
| 367 |
(truncate thing 100) |
|---|
| 368 |
(and (<= -24 hours 24) (<= -59 mins 59))))) |
|---|
| 369 |
|
|---|
| 370 |
(defun special-string-p (string) |
|---|
| 371 |
(and (simple-string-p string) (gethash string *special-strings*))) |
|---|
| 372 |
|
|---|
| 373 |
(defun secondp (number) |
|---|
| 374 |
(and (integerp number) (<= 0 number 59))) |
|---|
| 375 |
|
|---|
| 376 |
(defun minute (number) |
|---|
| 377 |
(and (integerp number) (<= 0 number 59))) |
|---|
| 378 |
|
|---|
| 379 |
(defun hour (number) |
|---|
| 380 |
(and (integerp number) (<= 0 number 23))) |
|---|
| 381 |
|
|---|
| 382 |
(defun day (number) |
|---|
| 383 |
(and (integerp number) (<= 1 number 31))) |
|---|
| 384 |
|
|---|
| 385 |
(defun year (number) |
|---|
| 386 |
(and (integerp number) |
|---|
| 387 |
(or (<= 0 number 99) |
|---|
| 388 |
(<= 1900 number)))) |
|---|
| 389 |
|
|---|
| 390 |
(defun time-divider (character) |
|---|
| 391 |
(and (characterp character) |
|---|
| 392 |
(member character time-dividers :test #'char=))) |
|---|
| 393 |
|
|---|
| 394 |
(defun date-divider (character) |
|---|
| 395 |
(and (characterp character) |
|---|
| 396 |
(member character date-dividers :test #'char=))) |
|---|
| 397 |
|
|---|
| 398 |
;;; Match-substring takes a string argument and tries to match it with |
|---|
| 399 |
;;; the strings in one of the four hash tables: *weekday-strings*, *month- |
|---|
| 400 |
;;; strings*, *zone-strings*, *special-strings*. It returns a specific |
|---|
| 401 |
;;; keyword and/or the object it finds in the hash table. If no match |
|---|
| 402 |
;;; is made then it immediately signals an error. |
|---|
| 403 |
|
|---|
| 404 |
(defun match-substring (substring) |
|---|
| 405 |
(let ((substring (nstring-downcase substring))) |
|---|
| 406 |
(or (let ((test-value (month substring))) |
|---|
| 407 |
(if test-value (cons 'month test-value))) |
|---|
| 408 |
(let ((test-value (weekday substring))) |
|---|
| 409 |
(if test-value (cons 'weekday test-value))) |
|---|
| 410 |
(let ((test-value (am-pm substring))) |
|---|
| 411 |
(if test-value (cons 'am-pm test-value))) |
|---|
| 412 |
(let ((test-value (noon-midn substring))) |
|---|
| 413 |
(if test-value (cons 'noon-midn test-value))) |
|---|
| 414 |
(let ((test-value (zone substring))) |
|---|
| 415 |
(if test-value (cons 'zone test-value))) |
|---|
| 416 |
(let ((test-value (special-string-p substring))) |
|---|
| 417 |
(if test-value (cons 'special test-value))) |
|---|
| 418 |
(if *error-on-mismatch* |
|---|
| 419 |
(error "\"~A\" is not a recognized word or abbreviation." |
|---|
| 420 |
substring) |
|---|
| 421 |
(return-from match-substring nil))))) |
|---|
| 422 |
|
|---|
| 423 |
;;; Decompose-string takes the time/date string and decomposes it into a |
|---|
| 424 |
;;; list of alphabetic substrings, numbers, and special divider characters. |
|---|
| 425 |
;;; It matches whatever strings it can and replaces them with a dotted pair |
|---|
| 426 |
;;; containing a symbol and value. |
|---|
| 427 |
|
|---|
| 428 |
(defun decompose-string (string &key (start 0) (end (length string)) (radix 10)) |
|---|
| 429 |
(do ((string-index start) |
|---|
| 430 |
(next-negative nil) |
|---|
| 431 |
(parts-list nil)) |
|---|
| 432 |
((eq string-index end) (nreverse parts-list)) |
|---|
| 433 |
(let ((next-char (char string string-index)) |
|---|
| 434 |
(prev-char (if (= string-index start) |
|---|
| 435 |
nil |
|---|
| 436 |
(char string (1- string-index))))) |
|---|
| 437 |
(cond ((alpha-char-p next-char) |
|---|
| 438 |
;; Alphabetic character - scan to the end of the substring. |
|---|
| 439 |
(do ((scan-index (1+ string-index) (1+ scan-index))) |
|---|
| 440 |
((or (eq scan-index end) |
|---|
| 441 |
(not (alpha-char-p (char string scan-index)))) |
|---|
| 442 |
(let ((match-symbol (match-substring |
|---|
| 443 |
(subseq string string-index scan-index)))) |
|---|
| 444 |
(if match-symbol |
|---|
| 445 |
(push match-symbol parts-list) |
|---|
| 446 |
(return-from decompose-string nil))) |
|---|
| 447 |
(setf string-index scan-index)))) |
|---|
| 448 |
((digit-char-p next-char radix) |
|---|
| 449 |
;; Numeric digit - convert digit-string to a decimal value. |
|---|
| 450 |
(do ((scan-index string-index (1+ scan-index)) |
|---|
| 451 |
(numeric-value 0 (+ (* numeric-value radix) |
|---|
| 452 |
(digit-char-p (char string scan-index) radix)))) |
|---|
| 453 |
((or (eq scan-index end) |
|---|
| 454 |
(not (digit-char-p (char string scan-index) radix))) |
|---|
| 455 |
;; If next-negative is t, set the numeric value to it's |
|---|
| 456 |
;; opposite and reset next-negative to nil. |
|---|
| 457 |
(when next-negative |
|---|
| 458 |
(setf next-negative nil) |
|---|
| 459 |
(setf numeric-value (- numeric-value))) |
|---|
| 460 |
(push numeric-value parts-list) |
|---|
| 461 |
(setf string-index scan-index)))) |
|---|
| 462 |
((and (char= next-char #\-) |
|---|
| 463 |
(or (not prev-char) |
|---|
| 464 |
(member prev-char whitespace-chars :test #'char=))) |
|---|
| 465 |
;; If we see a minus sign before a number, but not after one, |
|---|
| 466 |
;; it is not a date divider, but a negative offset from GMT, so |
|---|
| 467 |
;; set next-negative to t and continue. |
|---|
| 468 |
(setf next-negative t) |
|---|
| 469 |
(incf string-index)) |
|---|
| 470 |
((member next-char time-dividers :test #'char=) |
|---|
| 471 |
;; Time-divider - add it to the parts-list with symbol. |
|---|
| 472 |
(push (cons 'time-divider next-char) parts-list) |
|---|
| 473 |
(incf string-index)) |
|---|
| 474 |
((member next-char date-dividers :test #'char=) |
|---|
| 475 |
;; Date-divider - add it to the parts-list with symbol. |
|---|
| 476 |
(push (cons 'date-divider next-char) parts-list) |
|---|
| 477 |
(incf string-index)) |
|---|
| 478 |
((member next-char whitespace-chars :test #'char=) |
|---|
| 479 |
;; Whitespace character - ignore it completely. |
|---|
| 480 |
(incf string-index)) |
|---|
| 481 |
((char= next-char #\() |
|---|
| 482 |
;; Parenthesized string - scan to the end and ignore it. |
|---|
| 483 |
(do ((scan-index string-index (1+ scan-index))) |
|---|
| 484 |
((or (eq scan-index end) |
|---|
| 485 |
(char= (char string scan-index) #\))) |
|---|
| 486 |
(setf string-index (1+ scan-index))))) |
|---|
| 487 |
(t |
|---|
| 488 |
;; Unrecognized character - barf voraciously. |
|---|
| 489 |
(if *error-on-mismatch* |
|---|
| 490 |
(error |
|---|
| 491 |
'simple-error |
|---|
| 492 |
:format-control "Can't parse time/date string.~%>>> ~A~ |
|---|
| 493 |
~%~VT^-- Bogus character encountered here." |
|---|
| 494 |
:format-arguments (list string (+ string-index 4))) |
|---|
| 495 |
(return-from decompose-string nil))))))) |
|---|
| 496 |
|
|---|
| 497 |
;;; Match-pattern-element tries to match a pattern element with a datum |
|---|
| 498 |
;;; element and returns the symbol associated with the datum element if |
|---|
| 499 |
;;; successful. Otherwise nil is returned. |
|---|
| 500 |
|
|---|
| 501 |
(defun match-pattern-element (pattern-element datum-element) |
|---|
| 502 |
(cond ((listp datum-element) |
|---|
| 503 |
(let ((datum-type (if (eq (car datum-element) 'special) |
|---|
| 504 |
(cdr datum-element) |
|---|
| 505 |
(car datum-element)))) |
|---|
| 506 |
(if (eq datum-type pattern-element) datum-element))) |
|---|
| 507 |
((funcall pattern-element datum-element) |
|---|
| 508 |
(cons pattern-element datum-element)) |
|---|
| 509 |
(t nil))) |
|---|
| 510 |
|
|---|
| 511 |
;;; Match-pattern matches a pattern against a datum, returning the |
|---|
| 512 |
;;; pattern if successful and nil otherwise. |
|---|
| 513 |
|
|---|
| 514 |
(defun match-pattern (pattern datum datum-length) |
|---|
| 515 |
(if (>= (length pattern) datum-length) |
|---|
| 516 |
(let ((form-list nil)) |
|---|
| 517 |
(do ((pattern pattern (cdr pattern)) |
|---|
| 518 |
(datum datum (cdr datum))) |
|---|
| 519 |
((or (null pattern) (null datum)) |
|---|
| 520 |
(cond ((and (null pattern) (null datum)) |
|---|
| 521 |
(nreverse form-list)) |
|---|
| 522 |
((null pattern) nil) |
|---|
| 523 |
((null datum) (dolist (element pattern |
|---|
| 524 |
(nreverse form-list)) |
|---|
| 525 |
(if (not (listp element)) |
|---|
| 526 |
(return nil)))))) |
|---|
| 527 |
(let* ((pattern-element (car pattern)) |
|---|
| 528 |
(datum-element (car datum)) |
|---|
| 529 |
(optional (listp pattern-element)) |
|---|
| 530 |
(matching (match-pattern-element (if optional |
|---|
| 531 |
(car pattern-element) |
|---|
| 532 |
pattern-element) |
|---|
| 533 |
datum-element))) |
|---|
| 534 |
(cond (matching (let ((form-type (car matching))) |
|---|
| 535 |
(unless (or (eq form-type 'time-divider) |
|---|
| 536 |
(eq form-type 'date-divider)) |
|---|
| 537 |
(push matching form-list)))) |
|---|
| 538 |
(optional (push datum-element datum)) |
|---|
| 539 |
(t (return-from match-pattern nil)))))))) |
|---|
| 540 |
|
|---|
| 541 |
;;; Deal-with-noon-midn sets the decoded-time values to either noon |
|---|
| 542 |
;;; or midnight depending on the argument form-value. Form-value |
|---|
| 543 |
;;; can be either 'noon or 'midn. |
|---|
| 544 |
|
|---|
| 545 |
(defun deal-with-noon-midn (form-value parsed-values) |
|---|
| 546 |
(cond ((eq form-value 'noon) |
|---|
| 547 |
(setf (decoded-time-hour parsed-values) 12)) |
|---|
| 548 |
((eq form-value 'midn) |
|---|
| 549 |
(setf (decoded-time-hour parsed-values) 0)) |
|---|
| 550 |
(t (error "Unrecognized symbol: ~A" form-value))) |
|---|
| 551 |
(setf (decoded-time-minute parsed-values) 0) |
|---|
| 552 |
(setf (decoded-time-second parsed-values) 0)) |
|---|
| 553 |
|
|---|
| 554 |
;;; Deal-with-am-pm sets the decoded-time values to be in the am |
|---|
| 555 |
;;; or pm depending on the argument form-value. Form-value can |
|---|
| 556 |
;;; be either 'am or 'pm. |
|---|
| 557 |
|
|---|
| 558 |
(defun deal-with-am-pm (form-value parsed-values) |
|---|
| 559 |
(let ((hour (decoded-time-hour parsed-values))) |
|---|
| 560 |
(cond ((eq form-value 'am) |
|---|
| 561 |
(cond ((eq hour 12) |
|---|
| 562 |
(setf (decoded-time-hour parsed-values) 0)) |
|---|
| 563 |
((not (<= 0 hour 12)) |
|---|
| 564 |
(if *error-on-mismatch* |
|---|
| 565 |
(error "~D is not an AM hour, dummy." hour))))) |
|---|
| 566 |
((eq form-value 'pm) |
|---|
| 567 |
(if (<= 0 hour 11) |
|---|
| 568 |
(setf (decoded-time-hour parsed-values) |
|---|
| 569 |
(mod (+ hour 12) 24)))) |
|---|
| 570 |
(t (error "~A isn't AM/PM - this shouldn't happen." form-value))))) |
|---|
| 571 |
|
|---|
| 572 |
;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. |
|---|
| 573 |
(defun deal-with-izone (form-value parsed-values) |
|---|
| 574 |
(multiple-value-bind (hours mins) |
|---|
| 575 |
(truncate form-value 100) |
|---|
| 576 |
(setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60)))))) |
|---|
| 577 |
|
|---|
| 578 |
;;; Set-time-values uses the association list of symbols and values |
|---|
| 579 |
;;; to set the time in the decoded-time structure. |
|---|
| 580 |
|
|---|
| 581 |
(defun set-time-values (string-form parsed-values) |
|---|
| 582 |
(dolist (form-part string-form t) |
|---|
| 583 |
(let ((form-type (car form-part)) |
|---|
| 584 |
(form-value (cdr form-part))) |
|---|
| 585 |
(case form-type |
|---|
| 586 |
(secondp (setf (decoded-time-second parsed-values) form-value)) |
|---|
| 587 |
(minute (setf (decoded-time-minute parsed-values) form-value)) |
|---|
| 588 |
(hour (setf (decoded-time-hour parsed-values) form-value)) |
|---|
| 589 |
(day (setf (decoded-time-day parsed-values) form-value)) |
|---|
| 590 |
(month (setf (decoded-time-month parsed-values) form-value)) |
|---|
| 591 |
(year (setf (decoded-time-year parsed-values) form-value)) |
|---|
| 592 |
(zone (setf (decoded-time-zone parsed-values) form-value)) |
|---|
| 593 |
(izone (deal-with-izone form-value parsed-values)) |
|---|
| 594 |
(weekday (setf (decoded-time-dotw parsed-values) form-value)) |
|---|
| 595 |
(am-pm (deal-with-am-pm form-value parsed-values)) |
|---|
| 596 |
(noon-midn (deal-with-noon-midn form-value parsed-values)) |
|---|
| 597 |
(special (funcall form-value parsed-values)) |
|---|
| 598 |
(t (error "Unrecognized symbol in form list: ~A." form-type)))))) |
|---|
| 599 |
|
|---|
| 600 |
(defun parse-time (time-string &key (start 0) (end (length time-string)) |
|---|
| 601 |
(error-on-mismatch nil) |
|---|
| 602 |
(patterns *default-date-time-patterns*) |
|---|
| 603 |
(default-seconds nil) (default-minutes nil) |
|---|
| 604 |
(default-hours nil) (default-day nil) |
|---|
| 605 |
(default-month nil) (default-year nil) |
|---|
| 606 |
(default-zone nil) (default-weekday nil)) |
|---|
| 607 |
"Tries very hard to make sense out of the argument time-string and |
|---|
| 608 |
returns a single integer representing the universal time if |
|---|
| 609 |
successful. If not, it returns nil. If the :error-on-mismatch |
|---|
| 610 |
keyword is true, parse-time will signal an error instead of |
|---|
| 611 |
returning nil. Default values for each part of the time/date |
|---|
| 612 |
can be specified by the appropriate :default- keyword. These |
|---|
| 613 |
keywords can be given a numeric value or the keyword :current |
|---|
| 614 |
to set them to the current value. The default-default values |
|---|
| 615 |
are 00:00:00 on the current date, current time-zone." |
|---|
| 616 |
(setq *error-on-mismatch* error-on-mismatch) |
|---|
| 617 |
(let* ((string-parts (decompose-string time-string :start start :end end)) |
|---|
| 618 |
(parts-length (length string-parts)) |
|---|
| 619 |
(string-form (dolist (pattern patterns) |
|---|
| 620 |
(let ((match-result (match-pattern pattern |
|---|
| 621 |
string-parts |
|---|
| 622 |
parts-length))) |
|---|
| 623 |
(if match-result (return match-result)))))) |
|---|
| 624 |
(if string-form |
|---|
| 625 |
(let ((parsed-values (make-default-time default-seconds default-minutes |
|---|
| 626 |
default-hours default-day |
|---|
| 627 |
default-month default-year |
|---|
| 628 |
default-zone default-weekday))) |
|---|
| 629 |
(set-time-values string-form parsed-values) |
|---|
| 630 |
(convert-to-unitime parsed-values)) |
|---|
| 631 |
(if *error-on-mismatch* |
|---|
| 632 |
(error "\"~A\" is not a recognized time/date format." time-string) |
|---|
| 633 |
nil)))) |
|---|
| 634 |
|
|---|
| 635 |
|
|---|
