diff options
| -rw-r--r-- | cybertiggyr-time/time.lisp | 1287 | ||||
| -rw-r--r-- | mulk-journal.asd | 3 |
2 files changed, 1289 insertions, 1 deletions
diff --git a/cybertiggyr-time/time.lisp b/cybertiggyr-time/time.lisp new file mode 100644 index 0000000..fbe3d20 --- /dev/null +++ b/cybertiggyr-time/time.lisp @@ -0,0 +1,1287 @@ +;;; -*- Mode: Lisp -*- +;;; +;;; $Header: /home/gene/library/website/docsrc/pdl/RCS/time.lisp,v 395.1 2008/04/20 17:25:47 gene Exp $ +;;; +;;; Copyright (c) 2004, 2006 Gene Michael Stover. All rights reserved. +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation; either version 2.1 of the +;;; License, or (at your option) any later version. +;;; +;;; This program 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 Lesser General Public +;;; License along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +;;; USA + +(defpackage "CYBERTIGGYR-TIME" + (:documentation "CyberTiggyr's Time-related library") + (:use "COMMON-LISP")) +(in-package "CYBERTIGGYR-TIME") +(export '*default-day*) +(export '*default-hour*) +(export '*default-language*) +(export '*default-minute*) +(export '*default-month*) +(export '*default-recognizers*) +(export '*default-second*) +(export '*default-year*) +(export '*default-zone*) +(export '*format-time-date*) +(export '*format-time-full*) +(export '*format-time-iso8601-long*) +(export '*format-time-iso8601-short*) +(export '*format-time-time*) +(export 'format-time) +(export 'parse-time) +(export 'recognize-fmt) + +(defvar *debug* nil) + +(defvar *default-second* (constantly 0)) +(proclaim '(type function *default-second*)) + +(defvar *default-minute* (constantly 0)) +(proclaim '(type function *default-minute*)) + +(defvar *default-hour* (constantly 12) + "Function which returns the hour to assume when there is no hour. +The default value of *DEFAULT-HOUR* is a function which returns noon, +which is 12.") +(proclaim '(type function *default-hour*)) + +(defvar *default-day* + #'(lambda () + (multiple-value-bind + (ss mm hh dd) (decode-universal-time (get-universal-time)) + (declare (ignore ss mm hh)) + dd)) + "Function which returns the day to assume when there is no day. The +default value of *DEFAULT-DAY* is a function which returns the current +day.") +(proclaim '(type function *default-day*)) + +(defvar *default-month* + #'(lambda () + (multiple-value-bind + (ss mm hh dd mo) (decode-universal-time (get-universal-time)) + (declare (ignore ss mm hh dd)) + mo)) + "Function which returns the month to assume when there is no month. The +default value of *DEFAULT-MONTH* is a function which returns the current +month.") +(proclaim '(type function *default-month*)) + +(defvar *default-year* + #'(lambda () + (multiple-value-bind + (ss mm hh dd mo yy) (decode-universal-time (get-universal-time)) + (declare (ignore ss mm hh dd mo)) + yy)) + "Function which returns the year to assume when there is no year. The +default value of *DEFAULT-YEAR* is a function which returns the current +year.") +(proclaim '(type function *default-year*)) + +(defstruct broken-time + ;; Seconds. Can be a fractional number of seconds, though when converted + ;; to a Lisp Universal Time, you might loose the fractional part. + (ss 0 :type number) + + (mm 0 :type integer) + (hh 0 :type integer) + (dd 0 :type integer) + (mo 0 :type integer) + (yr 0 :type integer) + + dow + dst? + zone + + ;; AM, PM, or o'clock flag. Should be the symbol AM for AM, + ;; the symbol PM for PM, the symbol OCLOCK for o'clock, or + ;; nil for literal hours. + ampm) + +(defun create-broken (x) + "Return a new BROKEN with members initialized from X. X may be a +universal time or an association list." + (etypecase x + (number ; X is a universal time. + (multiple-value-bind (ss mm hh dd mo yr dow dst? zone) + (decode-universal-time x) + (make-broken-time :ss ss :mm mm :hh hh :dd dd :mo mo :yr yr + :dow dow :dst? dst? :zone zone :ampm nil))) + (list ; X is an assoc-list + (labels + ((moo (field default) + (or (cdr (assoc field x)) (funcall default)))) + (make-broken-time + :ss (moo :second *default-second*) + :mm (moo :minute *default-minute*) + :hh (moo :hour *default-hour*) + :dd (moo :day *default-day*) + :mo (moo :month *default-month*) + :yr (moo :year *default-year*) + :dow (moo :day-of-week (constantly nil)) + :dst? (moo :dst? (constantly nil)) + :zone (moo :zone (constantly nil)) + :ampm (moo :ampm (constantly nil))))))) + +(defvar *format-time-months* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash '(1 :english) ht) '("January" "Jan") + (gethash '(2 :english) ht) '("February" "Feb") + (gethash '(3 :english) ht) '("March" "Mar") + (gethash '(4 :english) ht) '("April" "Apr") + (gethash '(5 :english) ht) '("May" "May") + (gethash '(6 :english) ht) '("June" "Jun") + (gethash '(7 :english) ht) '("July" "Jul") + (gethash '(8 :english) ht) '("August" "Aug") + (gethash '(9 :english) ht) '("September" "Sep") + (gethash '(10 :english) ht) '("October" "Oct") + (gethash '(11 :english) ht) '("November" "Nov") + (gethash '(12 :english) ht) '("December" "Dec")) + ht)) + +(defvar *format-time-weekdays* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash '(0 :english) ht) '("Monday" "Mon") + (gethash '(1 :english) ht) '("Tuesday" "Tue") + (gethash '(2 :english) ht) '("Wednesday" "Wed") + (gethash '(3 :english) ht) '("Thursday" "Thu") + (gethash '(4 :english) ht) '("Friday" "Fri") + (gethash '(5 :english) ht) '("Saturday" "Sat") + (gethash '(6 :english) ht) '("Sunday" "Sun")) + ht)) + +(defvar *format-time-fns* (make-hash-table :test #'equal)) + +(macrolet ((deffmt (key str fn) + `(setf (gethash ,key *format-time-fns*) + #'(lambda (broken language strm) + (format strm ,str (funcall ,fn broken language)))))) + ;; Abbreviated weekday + (deffmt "%a" "~A" + #'(lambda (broken language) + (second (gethash (list (broken-time-dow broken) language) + *format-time-weekdays*)))) + + ;; Full weekday + (deffmt "%A" "~A" + #'(lambda (broken language) + (first (gethash (list (broken-time-dow broken) language) + *format-time-weekdays*)))) + + ;; Abbreviated month + (deffmt "%b" "~A" + #'(lambda (broken language) + (second + (gethash (list (broken-time-mo broken) language) *format-time-months*)))) + + ;; Full month + (deffmt "%B" "~A" + #'(lambda (broken language) + (first + (gethash (list (broken-time-mo broken) language) *format-time-months*)))) + + ;; Day of month, two digits + (deffmt "%d" "~2,'0D" + #'(lambda (broken language) + (declare (ignore language)) + (broken-time-dd broken))) + + ;; Hour, 00 to 23, two digits + (deffmt "%H" "~2,'0D" #'(lambda (broken language) + (declare (ignore language)) + (broken-time-hh broken))) + + ;; Hour, 01 to 12, two digits + (deffmt "%I" "~2,'0D" #'(lambda (broken language) + (declare (ignore language)) + (if (zerop (mod (broken-time-hh broken) 12)) + 12 + (mod (broken-time-hh broken) 12)))) + + ;; Day of year. Todo. Use "%j" key. + + ;; Month as two-digit number + (deffmt "%m" "~2,'0D" #'(lambda (broken language) + (declare (ignore language)) + (broken-time-mo broken))) + + ;; Minute, two digits + (deffmt "%M" "~2,'0D" #'(lambda (broken language) + (declare (ignore language)) + (broken-time-mm broken))) + + ;; AM or PM. Hard-coded to those two values, but should alter for the + ;; language. Do other languages divide the hours into more than English's + ;; two, 12-hour groups? + (deffmt "%p" "~A" #'(lambda (broken language) + (declare (ignore language)) + (if (<= 1 (broken-time-hh broken) 12) + "AM" + "PM"))) + + ;; Seconds. Two digits. + (deffmt "%S" "~2,'0D" #'(lambda (broken language) + (declare (ignore language)) + (broken-time-ss broken))) + + ;; Year, two digits. DON'T Todo. Two-digit years are wrong. + + ;; Year. Four digits. + (deffmt "%Y" "~4D" #'(lambda (broken language) + (declare (ignore language)) + (broken-time-yr broken))) + + ;; Time zone. This should be language-dependant. It should lookup from + ;; a table. I'll just print whatever Lisp decoded into the BROKEN-ZONE + ;; for now, but later, I'll need to print something more useful. + ;; According to ISO, it can be the number of hours ahead of GMT. That + ;; number depends on the time zone from the BROKEN time, & also on + ;; Daylight Savings Time. It's reasonable to trust that Common Lisp + ;; set the DST flag correctly in the BROKEN time, but Common Lisp does + ;; not give us information about the size of the DST offset, so we'll + ;; assume one hour. (This is yet another reason that Daylight Savings + ;; time is Daylight Stupid time.) + (deffmt "%Z" "~@D" #'(lambda (broken language) + (declare (ignore language)) + (- 0 + (broken-time-zone broken) + (if (broken-time-dst? broken) -1 0))))) + +(labels + ;; end-of-token returns true when the next character is a % or we're + ;; at end of input. + ((end-of-token (strm) + (or (eq (peek-char nil strm nil strm) strm) + (eql (peek-char nil strm nil strm) #\%))) + ;; Next-token returns the next token, whether it is a two-char token + ;; beginning with % or all characters up to but excluding the next + ;; % or the end of input. + (next-token (strm) + (cond ((eq (peek-char nil strm nil strm) strm) + ;; End of input. + strm) + ((eql (peek-char nil strm nil strm) #\%) + ;; Percent character. So the token is this % + ;; character & the character which follows it. + (coerce (make-array + 2 + :element-type 'character + :initial-contents (list + (read-char strm) + (read-char strm))) + 'string)) + (t + ;; The next character is not %, so the next token + ;; is all characters until the next % or the end + ;; of input. + (do ((lst () (cons (read-char strm) lst))) + ((end-of-token strm) + (coerce (nreverse lst) 'string))))))) + (defun convert-fmt-string-to-list (fmt) + "Given a FMT string for FORMAT-TIME, return a list of substrings parsed +from the FMT string." + (with-input-from-string (strm fmt) + (do ((lst () (cons (next-token strm) lst))) + ((eq (peek-char nil strm nil strm) strm) + (nreverse lst)))))) + +(defvar *default-language* :english) +(defvar *default-zone* nil) + +(defun format-time (strm fmt + &optional + (ut (get-universal-time)) + (zone *default-zone*) + (language *default-language*)) + (declare (type number ut) (type symbol language)) + (assert (or (eq t strm) (eq nil strm) (output-stream-p strm))) + (cond ((null strm) + ;; When STRM is NIL, we write the output to a new string & + ;; return that. Easy way to accomplish that is recursively. + (with-output-to-string (x) + (format-time x fmt ut zone language))) + ((eq t strm) + ;; When STRM is T, we write to standard output. + (format-time *standard-output* fmt ut zone language)) + ((null fmt) + ;; FMT is the empty list, so we don't do anything. There's + ;; nothing to output. + nil) + ((stringp fmt) + ;; Need to convert FMT from a string to a list that describes + ;; the output, then process the list recursively. + (format-time strm (convert-fmt-string-to-list fmt) ut zone language)) + ((and (consp fmt) (gethash (first fmt) *format-time-fns*)) + ;; FMT is a list, & its FIRST is in the table of functions. So we + ;; use the associated function, then process the rest of FMT + ;; recursively. + (let ((fn (gethash (car fmt) *format-time-fns*))) + (declare (type function fn)) + (funcall fn (create-broken ut) language strm)) + (format-time strm (rest fmt) ut language zone)) + ((consp fmt) + ;; FMT is a list, but its FIRST is not in the table, so we print + ;; the FIRST, the recurse on the REST. + (format strm "~A" (first fmt)) + (format-time strm (rest fmt) ut language zone)) + (t + ;; Whatever FMT is, we don't know how to deal with it explicitly, + ;; so we output it verbatim. + (format strm "~A" fmt)))) + +(defvar *format-time-iso8601-short* '("%Y" "%m" "%d" "T" "%H" "%M" "%S" " " "%Z") + "Format list for FORMAT-TIME to print a date-&-time in the compact +ISO 8061 format. It's compact because it's all numbers (as required +by the ISO format), & there are no field separators except for the T +between the date & the time.") + +(defvar *format-time-iso8601-long* + '("%Y" "-" "%m" "-" "%d" "T" "%H" ":" "%M" ":" "%S" " " "%Z") + "Format list for FORMAT-TIME to print a date-&-time in the verbose +ISO 8061 format. It's verbose because it separates the fields +of the date with -, fields of the time with :, & the date from +the time with T. So it is arguably human-readable.") + +(defvar *format-time-date* '("%d" " " "%b" " " "%Y") + "Format list for FORMAT-TIME to print a date in a compact, human readable +format. It's the day-of-month, abbreviated month name, & the year.") + +(defvar *format-time-time* '("%H" ":" "%M" " " "%Z") + "Format list for FORMAT-TIME to print a human-readable time. The hours +are on a 24-hour clock.") + +(defvar *format-time-full* + '("%A" ", " "%Y" " " "%B" " " "%d" ", " "%H" ":" "%M" " " "%Z") + "It's like ISO format except that it's supposed to be readable by +humans.") + +(defun end-of-stream? (strm) + "Return true if STRM is at its end. Does not consume characters. STRM +is a character input stream." + (eq (peek-char nil strm nil strm) strm)) + +(defun xdigit? (x) + "Return true if X is a character AND is a digit." + (and (characterp x) (digit-char-p x))) + +(defun normalize-hour (broken) + (cond ((eq (broken-time-ampm broken) :am) + (broken-time-hh broken)) + ((eq (broken-time-ampm broken) :pm) + (mod (+ (broken-time-hh broken) 12) 24)) + ((eq (broken-time-ampm broken) :oclock) + (broken-time-hh broken)) + (t + (broken-time-hh broken)))) + +(defun normalize-broken (x) + "Given a BROKEN-TIME, some components of +which may be missing, some of which may be screwy -- like a 2-digit +year, this function inserts all missing components, possibly performs +some other adjustments, & returns a new BROKEN-TIME. An exception is +time-zone; if it's missing, it won't be inserted." + (make-broken-time + :ss (broken-time-ss x) + :mm (broken-time-mm x) + :hh (normalize-hour x) + :dd (broken-time-dd x) + :mo (broken-time-mo x) + :yr (broken-time-yr x) + :zone (broken-time-zone x))) + +(defun broken-to-ut (x) + "Given a BROKEN time structure, conver them +to a universal time & return the universal time. All of the date-&-time +components must be present in the BROKEN time." + ;; Notice how we handle the time zone. First, it must already be a + ;; number of hours or NIL. Second, the time zone in the BROKEN-TIME is + ;; the difference, in hours, between GMT & the time zone of the + ;; BROKEN-TIME, while ENCODE-UNIVERSAL-TIME represents time zones in an + ;; opposite way. So we must negate the time zone. + (let ((y (normalize-broken x))) + (encode-universal-time (broken-time-ss y) + (broken-time-mm y) + (broken-time-hh y) + (broken-time-dd y) + (broken-time-mo y) + (broken-time-yr y) + (if (broken-time-zone y) + (- (broken-time-zone y)) + nil)))) + +(defvar *default-day* #'(lambda () + (fourth + (multiple-value-list + (decode-universal-time + (get-universal-time))))) + "Function which returns the day of month to assume when there is no +day of month. The default value of *DEFAULT-DAY* is a function which +returns today's day of month.") + +(proclaim '(type function *default-day*)) + +(defvar *default-month* #'(lambda () + (fifth + (multiple-value-list + (decode-universal-time + (get-universal-time))))) + "Function which returns the month to assume when there is no +month. The default value of *DEFAULT-MONTH* is a function which +returns the current month.") + +(proclaim '(type function *default-month*)) + +(defvar *default-year* #'(lambda () + (sixth + (multiple-value-list + (decode-universal-time + (get-universal-time))))) + "Function which returns the year to assume when there is no +year. The default value of *DEFAULT-YEAR* is a function which +returns the current year.") + +(proclaim '(type function *default-year*)) + +(defun next-fn (strm fn) + "Consume & collect characters from STRM as long as they satisfy +FN. FN is a function of one argument which should be a character." + (declare (type function fn)) + (labels ((xend-p (strm) + (or (eq (peek-char nil strm nil strm) strm) + (not (funcall fn (peek-char nil strm nil strm)))))) + (if (xend-p strm) + ;; Stream is already at end. + nil + (do ((lst () (cons (read-char strm) lst))) + ((xend-p strm) + (coerce (nreverse lst) 'string)))))) + +(defun next-number (strm) + "Consume characters from STRM as long as they are digits. Then +convert to a number & return the number." + (let ((x (next-fn strm #'(lambda (ch) + (or (digit-char-p ch) + (char-equal ch #\.)))))) + (and x (car (multiple-value-list (read-from-string x)))))) + +(defun next-word (strm) + "Consume & collect characters from STRM as long as they are alphanumeric. +Converts all characters to upper case. Returns the token as a string. +Return NIL if the stream is already at the end when you call this function." + (let ((x (next-fn strm #'(lambda (ch) + (or (alpha-char-p ch) + (char-equal ch #\')))))) + (and x (string-upcase x)))) + +(defun next-token (strm) + ;; Discard white-space. + (peek-char t strm nil strm) + (cond ((eq (peek-char nil strm nil strm) strm) + ;; End of input + nil) + ((digit-char-p (peek-char nil strm nil strm)) + (next-number strm)) + ((alpha-char-p (peek-char nil strm nil strm)) + (next-word strm)) + ((member (peek-char nil strm nil strm) '(#\, #\: #\- #\+)) + (coerce (list (read-char strm)) 'string)) + (t + ;; This character is a token unto itself. + (read-char strm)))) + +(defun tokenize (str) + "Return a list of tokens. Where possible & convenient, tokens are +converted to symbols & numbers. Otherwise, tokens are strings or +single characters, always upper case." + (with-input-from-string (strm str) + (do (( lst () (cons token lst)) + (token (next-token strm) (next-token strm))) + ((null token) + (nreverse lst))))) + +(defun is-second? (x) + (and (numberp x) (<= 0 x 59))) + +(defun is-minute? (x) + (and (numberp x) (<= 0 x 59))) + +(defun is-hour? (x) + (and (numberp x) (<= 0 x 24))) + +(defun is-day? (x) + (and (numberp x) (<= 1 x 31))) + +(let ((ht (make-hash-table :test #'equal))) + (setf (gethash 1 ht) 1 + (gethash 2 ht) 2 + (gethash 3 ht) 3 + (gethash 4 ht) 4 + (gethash 5 ht) 5 + (gethash 6 ht) 6 + (gethash 7 ht) 7 + (gethash 8 ht) 8 + (gethash 9 ht) 9 + (gethash 10 ht) 10 + (gethash 11 ht) 11 + (gethash 12 ht) 12 + (gethash "january" ht) 1 + (gethash "february" ht) 2 + (gethash "march" ht) 3 + (gethash "april" ht) 4 + (gethash "may" ht) 5 + (gethash "june" ht) 6 + (gethash "july" ht) 7 + (gethash "august" ht) 8 + (gethash "september" ht) 9 + (gethash "october" ht) 10 + (gethash "november" ht) 11 + (gethash "december" ht) 12 + (gethash "jan" ht) 1 + (gethash "feb" ht) 2 + (gethash "mar" ht) 3 + (gethash "apr" ht) 4 + ;; (gethash "may" ht) 5 + (gethash "jun" ht) 6 + (gethash "jul" ht) 7 + (gethash "aug" ht) 8 + (gethash "sep" ht) 9 + (gethash "oct" ht) 10 + (gethash "nov" ht) 11 + (gethash "dec" ht) 12) + (defun make-month (x) + (car (multiple-value-list + (if (stringp x) + (gethash (string-downcase x) ht) + (gethash x ht)))))) + +(defun is-year? (x) + (numberp x)) + +(defvar *zones* + (let ((ht (make-hash-table :test #'equal))) + (setf + (gethash "+0" ht) 0 + (gethash "+00" ht) 0 + (gethash "+0000" ht) 0 + (gethash "+0030" ht) (/ 30 60) + (gethash "+00:00" ht) 0 + (gethash "+00:30" ht) (/ 30 60) + (gethash "+01" ht) 1 + (gethash "+0100" ht) 1 + (gethash "+0130" ht) (+ 1 (/ 30 60)) + (gethash "+01:00" ht) 1 + (gethash "+01:30" ht) (+ 1 (/ 30 60)) + (gethash "+02" ht) 2 + (gethash "+0200" ht) 2 + (gethash "+0230" ht) (+ 2 (/ 30 60)) + (gethash "+02:00" ht) 2 + (gethash "+02:30" ht) (+ 2 (/ 30 60)) + (gethash "+03" ht) 3 + (gethash "+0300" ht) 3 + (gethash "+0330" ht) (+ 3 (/ 30 60)) + (gethash "+03:00" ht) 3 + (gethash "+03:30" ht) (+ 3 (/ 30 60)) + (gethash "+04" ht) 4 + (gethash "+0400" ht) 4 + (gethash "+0430" ht) (+ 4 (/ 30 60)) + (gethash "+04:00" ht) 4 + (gethash "+04:30" ht) (+ 4 (/ 30 60)) + (gethash "+05" ht) 5 + (gethash "+0500" ht) 5 + (gethash "+0530" ht) (+ 5 (/ 30 60)) + (gethash "+05:00" ht) 5 + (gethash "+05:30" ht) (+ 5 (/ 30 60)) + (gethash "+06" ht) 6 + (gethash "+0600" ht) 6 + (gethash "+0630" ht) (+ 6 (/ 30 60)) + (gethash "+06:00" ht) 6 + (gethash "+06:30" ht) (+ 6 (/ 30 60)) + (gethash "+07" ht) 7 + (gethash "+0700" ht) 7 + (gethash "+0730" ht) (+ 7 (/ 30 60)) + (gethash "+07:00" ht) 7 + (gethash "+07:30" ht) (+ 7 (/ 30 60)) + (gethash "+08" ht) 8 + (gethash "+0800" ht) 8 + (gethash "+0830" ht) (+ 8 (/ 30 60)) + (gethash "+08:00" ht) 8 + (gethash "+08:30" ht) (+ 8 (/ 30 60)) + (gethash "+09" ht) 9 + (gethash "+0900" ht) 9 + (gethash "+0930" ht) (+ 9 (/ 30 60)) + (gethash "+09:00" ht) 9 + (gethash "+09:30" ht) (+ 9 (/ 30 60)) + (gethash "+0:30" ht) (/ 30 60) + (gethash "+1" ht) 1 + (gethash "+10" ht) 10 + (gethash "+1000" ht) 10 + (gethash "+1030" ht) (+ 10 (/ 30 60)) + (gethash "+10:00" ht) 10 + (gethash "+10:30" ht) (+ 10 (/ 30 60)) + (gethash "+11" ht) 11 + (gethash "+1100" ht) 11 + (gethash "+1130" ht) (+ 11 (/ 30 60)) + (gethash "+11:00" ht) 11 + (gethash "+11:30" ht) (+ 11 (/ 30 60)) + (gethash "+12" ht) 12 + (gethash "+1200" ht) 12 + (gethash "+1230" ht) (+ 12 (/ 30 60)) + (gethash "+12:00" ht) 12 + (gethash "+12:30" ht) (+ 12 (/ 30 60)) + (gethash "+2" ht) 2 + (gethash "+3" ht) 3 + (gethash "+4" ht) 4 + (gethash "+5" ht) 5 + (gethash "+6" ht) 6 + (gethash "+7" ht) 7 + (gethash "+8" ht) 8 + (gethash "+9" ht) 9 + (gethash "-0" ht) -0 + (gethash "-00" ht) -0 + (gethash "-0000" ht) -0 + (gethash "-0030" ht) (- -0 (/ 30 60)) + (gethash "-00:00" ht) -0 + (gethash "-00:30" ht) (- (/ 30 60)) + (gethash "-01" ht) -1 + (gethash "-0100" ht) -1 + (gethash "-0130" ht) (- -1 (/ 30 60)) + (gethash "-01:00" ht) -1 + (gethash "-01:30" ht) (- -1 (/ 30 60)) + (gethash "-02" ht) -2 + (gethash "-0200" ht) -2 + (gethash "-0230" ht) (- -2 (/ 30 60)) + (gethash "-02:00" ht) -2 + (gethash "-02:30" ht) (- -2 (/ 30 60)) + (gethash "-03" ht) -3 + (gethash "-0300" ht) -3 + (gethash "-0330" ht) (- -3 (/ 30 60)) + (gethash "-03:00" ht) -3 + (gethash "-03:30" ht) (- -3 (/ 30 60)) + (gethash "-04" ht) -4 + (gethash "-0400" ht) -4 + (gethash "-0430" ht) (- -4 (/ 30 60)) + (gethash "-04:00" ht) -4 + (gethash "-04:30" ht) (- -4 (/ 30 60)) + (gethash "-05" ht) -5 + (gethash "-0500" ht) -5 + (gethash "-0530" ht) (- -5 (/ 30 60)) + (gethash "-05:00" ht) -5 + (gethash "-05:30" ht) (- -5 (/ 30 60)) + (gethash "-06" ht) -6 + (gethash "-0600" ht) -6 + (gethash "-0630" ht) (- -6 (/ 30 60)) + (gethash "-06:00" ht) -6 + (gethash "-06:30" ht) (- -6 (/ 30 60)) + (gethash "-07" ht) -7 + (gethash "-0700" ht) -7 + (gethash "-0730" ht) (- -7 (/ 30 60)) + (gethash "-07:00" ht) -7 + (gethash "-07:30" ht) (- -7 (/ 30 60)) + (gethash "-08" ht) -8 + (gethash "-0800" ht) -8 + (gethash "-0830" ht) (- -8 (/ 30 60)) + (gethash "-08:00" ht) -8 + (gethash "-08:30" ht) (- -8 (/ 30 60)) + (gethash "-09" ht) -9 + (gethash "-0900" ht) -9 + (gethash "-0930" ht) (- -9 (/ 30 60)) + (gethash "-09:00" ht) -9 + (gethash "-09:30" ht) (- -9 (/ 30 60)) + (gethash "-0:00" ht) -0 + (gethash "-0:30" ht) (- (/ 30 60)) + (gethash "-1" ht) -1 + (gethash "-10" ht) -10 + (gethash "-1000" ht) -10 + (gethash "-1030" ht) (- -10 (/ 30 60)) + (gethash "-10:00" ht) -10 + (gethash "-10:30" ht) (- -10 (/ 30 60)) + (gethash "-11" ht) -11 + (gethash "-1100" ht) -11 + (gethash "-1130" ht) (- -11 (/ 30 60)) + (gethash "-11:00" ht) -11 + (gethash "-11:30" ht) (- -11 (/ 30 60)) + (gethash "-12" ht) -12 + (gethash "-1200" ht) -12 + (gethash "-1230" ht) (- -12 (/ 30 60)) + (gethash "-12:00" ht) -12 + (gethash "-12:30" ht) (- -12 (/ 30 60)) + (gethash "-1:00" ht) -1 + (gethash "-1:30" ht) (- -1 (/ 30 60)) + (gethash "-2" ht) -2 + (gethash "-2:00" ht) -2 + (gethash "-2:30" ht) (- -2 (/ 30 60)) + (gethash "-3" ht) -3 + (gethash "-3:00" ht) -3 + (gethash "-3:30" ht) (- -3 (/ 30 60)) + (gethash "-4" ht) -4 + (gethash "-4:00" ht) -4 + (gethash "-4:30" ht) (- -4 (/ 30 60)) + (gethash "-5" ht) -5 + (gethash "-5:00" ht) -5 + (gethash "-5:30" ht) (- -5 (/ 30 60)) + (gethash "-6" ht) -6 + (gethash "-6:00" ht) -6 + (gethash "-6:30" ht) (- -6 (/ 30 60)) + (gethash "-7" ht) -7 + (gethash "-7:00" ht) -7 + (gethash "-7:30" ht) (- -7 (/ 30 60)) + (gethash "-8" ht) -8 + (gethash "-8:00" ht) -8 + (gethash "-8:30" ht) (- -8 (/ 30 60)) + (gethash "-9" ht) -9 + (gethash "-9:00" ht) -9 + (gethash "-9:30" ht) (- -9 (/ 30 60)) + (gethash "0" ht) 0 + (gethash "1" ht) 1 + (gethash "10" ht) 10 + (gethash "11" ht) 11 + (gethash "12" ht) 12 + (gethash "2" ht) 2 + (gethash "3" ht) 3 + (gethash "4" ht) 4 + (gethash "5" ht) 5 + (gethash "6" ht) 6 + (gethash "7" ht) 7 + (gethash "8" ht) 8 + (gethash "9" ht) 9 + (gethash "CDT" ht) -5 ; Central Daylight stupid Time (U.S.) ??? + (gethash "CST" ht) -6 ; Central Standard Time (U.S.) ??? + (gethash "EDT" ht) -4 ; Eastern Daylight Time (U.S.) + (gethash "EST" ht) -5 ; Eastern Standard Time (U.S.) + (gethash "GMT" ht) 0 + (gethash "PDT" ht) -7 ; Pacific Daylight stupid Time (U.S.) + (gethash "PST" ht) -8 ; Pacific Standard Time (U.S.) + (gethash -1 ht) -1 + (gethash -10 ht) -10 + (gethash -11 ht) -11 + (gethash -12 ht) -12 + (gethash -2 ht) -2 + (gethash -3 ht) -3 + (gethash -4 ht) -4 + (gethash -5 ht) -5 + (gethash -6 ht) -6 + (gethash -7 ht) -7 + (gethash -8 ht) -8 + (gethash -9 ht) -9 + (gethash 0 ht) 0 + (gethash 1 ht) 1 + (gethash 10 ht) 10 + (gethash 11 ht) 11 + (gethash 12 ht) 12 + (gethash 2 ht) 2 + (gethash 3 ht) 3 + (gethash 4 ht) 4 + (gethash 5 ht) 5 + (gethash 6 ht) 6 + (gethash 7 ht) 7 + (gethash 8 ht) 8 + (gethash 9 ht) 9 + ) + ht)) + +(defun make-zone (x) + (car + (multiple-value-list (gethash (typecase x + (number x) + (string (string-upcase x)) + (t x)) + *zones*)))) + +(defun recognize-minimal-iso (str) + "The string is minimal ISO if, after trimming leading & trailing crap, +the string is 14 characters & they are all digits." + (declare (type string str)) + (and (eql 14 (length str)) + (every #'digit-char-p str) + (list (cons 'year (read-from-string (subseq str 0 4))) + (cons 'month (read-from-string (subseq str 4 6))) + (cons 'day (read-from-string (subseq str 6 8))) + (cons 'hour (read-from-string (subseq str 8 10))) + (cons 'minute (read-from-string (subseq str 10 12))) + (cons 'second (read-from-string (subseq str 12)))))) + +(defun recognize-tee-iso (str) + "Tee-ISO is like minimal ISO except that is has a T character in the +middle of it." + ;; If it looks like it might be Tee ISO, we remove the T, which hopefully + ;; converts it to minimal ISO. Then call the minimal ISO function on it. + (declare (type string str)) + (and (eql (length str) 15) + (char-equal (char str 8) #\T) + (recognize-minimal-iso (concatenate 'string + (subseq str 0 8) + (subseq str 9))))) + +(defun recognize-verbose-iso (str tokens) + (declare (ignore str) (type list tokens)) + (let* (ss mm hh dd mo yy zone) + (and (is-year? (setq yy (pop tokens))) + (equal (pop tokens) "-") + (setq mo (make-month (pop tokens))) + (equal (pop tokens) "-") + (is-day? (setq dd (pop tokens))) + (stringp (first tokens)) + (string-equal (pop tokens) "T") + (is-hour? (setq hh (pop tokens))) + (equal (pop tokens) ":") + (is-minute? (setq mm (pop tokens))) + (equal (pop tokens) ":") + (is-second? (setq ss (pop tokens))) + ;; Time zone is another special case. The tokenizer turns time + ;; zones such as "-7" into two tokens: the string "-" & the + ;; number 7. It does the same for "+7", which becomes "+" and + ;; 7. We must merge them into a single token again. Some + ;; time zones will still be a single token already; "PST" + ;; is an example. + (setq zone (pop tokens)) + (if zone + (setq zone + (make-zone + (cond ((and (stringp zone) (string-equal zone "+")) + (with-input-from-string (strm (format nil "~A" + (pop tokens))) + (ignore-errors (read strm nil nil)))) + ((and (stringp zone) (string-equal zone "-")) + (with-input-from-string (strm (format nil "-~A" + (pop tokens))) + (ignore-errors (read strm nil nil)))) + (t zone)))) + t) ; Zone is nil, unspecified + ;; end of time zone special case + (endp tokens) + (make-broken-time :ss ss :mm mm :hh hh :dd dd :mo mo :yr yy + :zone zone)))) + +(defun recognize-now (str tokens) + "Parse the string 'now', in any mix of case & with or without leading or +trailing crap ... er, I mean whitespace characters. NOW is the current +time with resolution to the second." + (declare (ignore tokens)) + (when (and (stringp str) + (string-equal (string-trim '(#\Tab #\Space #\Newline) str) "now")) + (get-universal-time))) + +(defun recognize-today (str tokens) + "Parse the string 'today', in any mix of case & with or without leading or +trailing crap ... er, I mean whitespace characters. Today is the current +year, month, & day, the default hour, 0 for minutes, & 0 for seconds. It +assumes GMT so that today executed at the same time in different time +zones will give you the same universal time." + (declare (ignore tokens)) + (when (and (stringp str) + (string-equal + (string-trim '(#\Tab #\Space #\Newline) str) "today")) + (multiple-value-bind (ss mm hh dd mo yy) + (decode-universal-time (get-universal-time)) + (setq ss 0 + mm 0 + hh (funcall *default-hour*)) + (encode-universal-time ss mm hh dd mo yy 0)))) + +(defun recognize-yyyymmdd-nw (str tokens) + "Recognize YYYY MM DD, with only whitespace separating the tokens. +There is no time zone." + (declare (ignore str) (type list tokens)) + (let* (dd mo yy) + (and (is-year? (setq yy (pop tokens))) + (setq mo (make-month (pop tokens))) + (is-day? (setq dd (pop tokens))) + (endp tokens) + (make-broken-time :ss 0 :mm 0 :hh (funcall *default-hour*) + :dd dd :mo mo :yr yy :zone nil)))) + +(defun recognize-yyyymmdd (str tokens) + "Recognize YYYYMMDD with no whitespace. All characters in the string +must be digits, & the string must be of length 8." + (declare (type string str) (ignore tokens)) + (and (eql (length str) 8) + (every #'digit-char-p str) + (make-broken-time :ss 0 :mm 0 :hh (funcall *default-hour*) + :dd (parse-integer str :start 6 :end 8) + :mo (parse-integer str :start 4 :end 6) + :yr (parse-integer str :start 0 :end 4) + :zone nil))) + +(defun collect-token (width good-char? strm) + "Collect characters from character input stream STRM until we have +WIDTH characters or the next character is not acceptable according to +GOOD-CHAR?, which is a function. Return the characters we collected, +as a string." + (peek-char t strm nil) ; skip leading space characters + (do ((lst () (cons (read-char strm) lst)) + (count 0 (1+ count))) + ((or (> count width) + (end-of-stream? strm) + (not (funcall good-char? (peek-char nil strm)))) + ;; Return the digits we've collected, as a string. + (string-upcase (coerce (nreverse lst) 'string))))) + +(defun make-numeric-parser (width min max field) + "Return a function which parses a numeric token of at most WIDTH digits, +translating to a number not less than MIN & not more than MAX. For example, +if WIDTH, MIN, & MAX are 4, 100, & 9000, you get a function which parses at +most 4 digits that form a number N in the range 100 <= N <= 9000." + (declare (type integer width min max) (type symbol field)) + #'(lambda (strm) + (let ((n + (with-input-from-string + (strm2 (collect-token width #'digit-char-p strm)) + (ignore-errors (read strm2 nil nil))))) + (if (and (numberp n) (<= min n max)) + ;; It's a number & within our range, so return a CONS. + (cons field n) + ;; Else, it's not a number, or it's out of our range, so fail. + nil)))) +(proclaim + '(ftype (function (integer integer integer symbol) function) + make-numeric-parser)) + +(defun make-word-parser (width ht field) + "Return a function which parses consecutive alpha- & numeric characters, +up to WIDTH of them, & then converts them to a Lisp object via the HT +hash table." + (declare (type integer width) (type hash-table ht) (type symbol field)) + #'(lambda (strm) + (let* ((token (collect-token width #'alphanumericp strm)) + x) + ;; Ensure that any characters in TOKEN are upper-case. + (when (stringp token) + (setq token (string-upcase token))) + (setq x (gethash token ht)) + (if x + ;; The token is in the hash table, so return the value from + ;; the hash table. + (cons field x) + ;; Else, the token isn't in the hash table, so fail. + nil)))) +(proclaim + '(ftype (function (integer hash-table symbol) function) make-word-parser)) + +(defun parse-literal (literal strm) + "Match & consume the literal characters in the string LITERAL from the +input stream STRM. If all the charactrs in LITERAL match the next +characters from STRM, return CONS :LITERAL LITERAL. Otherwise, Nil." + (declare (type string literal)) + (with-input-from-string (lstrm literal) + (peek-char t strm nil) ; skip leading space characters + (peek-char t lstrm nil) ; ditto + (do () + ((or (end-of-stream? lstrm) + (end-of-stream? strm) + (not (char-equal (peek-char nil lstrm) (peek-char nil strm))))) + ;; Not end of stream(s), & the next characters are equivalent, so + ;; consume them. A special case is space characters. If the next + ;; characters are spaces, consume them with PEEK-CHAR so that we + ;; consume consecutive white-space characters. + (cond ((member (peek-char nil lstrm nil) '(#\Space #\Tab #\Newline) + :test #'char-equal) + ;; Next character is a white-space, so use PEEK-CHAR to + ;; consume consecutive space characters from both streams. + (peek-char t lstrm nil) + (peek-char t strm nil)) + (t + ;; Next character is not white-space, so consume just it. + (read-char lstrm nil) + (read-char strm nil)))) + ;; If we're at the end of the LITERAL string's input stream, then we + ;; matched everything in it, which is success. Otherwise, fail. + (if (end-of-stream? lstrm) + (cons :literal literal) + ;; Else, the match failed. + nil))) + +(defun parse-percent-percent (strm) + "Recognize the literal '%' character. This is for the '%%' format token." + (parse-literal "%" strm)) + +(defun parse-time-zone-minus-hour (strm hour) + "Parse the minutes, assuming we've already parsed the hour." + ;; If the next character is a colon, skip it. + (declare (type number hour)) + (when (eql (peek-char nil strm nil) #\:) + (read-char strm)) + ;; Now we expect exactly two digits. + (let* ((min1 (when (xdigit? (peek-char nil strm nil)) + (read-char strm))) + (min2 (when (xdigit? (peek-char nil strm nil)) + (read-char strm)))) + (cond ((and (xdigit? min1) (xdigit? min2)) + ;; We have two digits for the minute. We also have the hour, which + ;; is a number. Convert the two to a scalar. That's the zone. + (cons :zone + (+ hour + (/ (read-from-string (format nil "~C~C" min1 min2)) + 60)))) + ((and (null min1) (null min2)) + ;; We didn't get any digits. This is not an error. It means + ;; there were no digits for the minute at all. So we return + ;; just the hour as it is. + (cons :zone hour)) + (t + ;; We got just one digit. This is an error, so we fail. + nil)))) + +(defun parse-time-zone-minus (strm) + "Parse the rest of a time zone assuming it begins with a - character. +It starts with a two-digit hour." + (let* ((hour1 (when (xdigit? (peek-char nil strm nil)) + (read-char strm))) + (hour2 (when (xdigit? (peek-char nil strm nil)) + (read-char strm)))) + (cond ((and (xdigit? hour1) (xdigit? hour2)) + ;; We have two digits for the hour. That's good. We try to + ;; parse a minute part, too, but if we can't get that, we + ;; still return the hour that we have. + (parse-time-zone-minus-hour strm + (- (read-from-string + (format nil "~C~C" hour1 hour2))))) + ((and (xdigit? hour1) (eql (peek-char nil strm nil) #\:)) + ;; We got one digit, & the next character is a colon, so we + ;; go for the minutes. + (parse-time-zone-minus-hour strm (- (read-from-string + (format nil "~C" hour1))))) + ((xdigit? hour1) + ;; We got one digt & the next character is not a digit & not a + ;; colon, so we stop here with just the hour. + (cons :zone + (- + (with-input-from-string (strm (format nil "~C" hour1)) + (read strm))))) + (t ;; Else we didn't get two digits for the hour, so fail. + nil)))) + +(defun parse-time-zone-plus (strm) + "Parse a time zone assuming the first character of it was a + character." + (let ((x (parse-time-zone-minus strm))) + (if (numberp (cdr x)) + (cons (car x) (- (cdr x))) + x))) + +(defun time-zone-char? (x) + "Return true if & only if X is a character & is acceptable in a time +zone." + (and (characterp x) + (or (eql x #\+) (eql x #\-) (eql x #\:) (alphanumericp x)))) + +(defun parse-time-zone (strm) + "Jeezus fucking Krist I hate time zones. A bitch to parse. And a +stupid idea to begin with. Fuuuuuck. +Recognize a time zone token from STRM. If the next character is + or -, +we expect a two-digit number of hours to follow, such as 7 or 5. After +those numbers, the next character may be ':' (which is ignored), & then +two-digit number of minutes. If the first token of STRM is alpha instead +of + or -, we collect alpha-numeric characters into a token, then translate +them to a numeric time zone via a hash table." + (peek-char t strm nil) ; skip space characters + ;; Width is 6 because the longest time zone you'll see is something + ;; like "+08:30", which is 6. + (let* ((token (collect-token 6 #'time-zone-char? strm)) + (x (gethash token *zones*))) + (when *debug* + (format t "~&~A: debug:" 'parse-time-zone) + (format t "~& token is ~S" token) + (format t "~& x is ~S" x)) + (if x + (cons :zone x) + nil))) + +(defvar *months* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "1" ht) 1 + (gethash "2" ht) 2 + (gethash "3" ht) 3 + (gethash "4" ht) 4 + (gethash "5" ht) 5 + (gethash "6" ht) 6 + (gethash "7" ht) 7 + (gethash "8" ht) 8 + (gethash "9" ht) 9 + (gethash "10" ht) 10 + (gethash "11" ht) 11 + (gethash "12" ht) 12 + (gethash "JAN" ht) 1 + (gethash "FEB" ht) 2 + (gethash "MAR" ht) 3 + (gethash "APR" ht) 4 + (gethash "MAY" ht) 5 + (gethash "JUN" ht) 6 + (gethash "JUL" ht) 7 + (gethash "AUG" ht) 8 + (gethash "SEP" ht) 9 + (gethash "SEPT" ht) 9 + (gethash "OCT" ht) 10 + (gethash "NOV" ht) 11 + (gethash "DEC" ht) 12 + (gethash "JANUARY" ht) 1 + (gethash "FEBRUARY" ht) 2 + (gethash "MARCH" ht) 3 + (gethash "APRIL" ht) 4 + ;; MAY 5 + (gethash "JUNE" ht) 6 + (gethash "JULY" ht) 7 + (gethash "AUGUST" ht) 8 + (gethash "SEPTEMBER" ht) 9 + (gethash "OCTOBER" ht) 10 + (gethash "NOVEMBER" ht) 11 + (gethash "DECEMBER" ht) 12) + ht) + "Map month names & abbreviations to their numbers.") + +(defvar *weekdays* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "SUN" ht) t + (gethash "MON" ht) t + (gethash "TUE" ht) t + (gethash "TUES" ht) t + (gethash "WED" ht) t + (gethash "THU" ht) t + (gethash "THUR" ht) t + (gethash "FRI" ht) t + (gethash "SAT" ht) t + (gethash "SUNDAY" ht) t + (gethash "MONDAY" ht) t + (gethash "TUESDAY" ht) t + (gethash "WEDNESDAY" ht) t + (gethash "THURSDAY" ht) t + (gethash "FRIDAY" ht) t + (gethash "SATURDAY" ht) t) + ht) + "Map weekday names & abbreviations to truth. We don't use the weekday +when figuring the universal time, so we don't map to anything other than +true. The true simply indicates that we recognize the term as a weekday +name.") + +(defvar *ampm* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "AM" ht) :am + (gethash "A" ht) :am + (gethash "PM" ht) :pm + (gethash "P" ht) :pm + (gethash "O'CLOCK" ht) :oclock) + ht) + "Map AM, PM, & O'CLOCK strings to symbols for use when figuring the +universal time from a broken time.") + +(defvar *term-parsers* + (let ((ht (make-hash-table :test #'equal))) + (setf (gethash "%%" ht) #'parse-percent-percent + (gethash "%A" ht) (make-word-parser 20 *weekdays* :weekday) + (gethash "%B" ht) (make-word-parser 20 *months* :month) + (gethash "%H" ht) (make-numeric-parser 2 0 24 :hour) + (gethash "%M" ht) (make-numeric-parser 2 0 59 :minute) + (gethash "%Y" ht) (make-numeric-parser 4 0 9999 :year) + (gethash "%Z" ht) #'parse-time-zone + (gethash "%a" ht) (make-word-parser 20 *weekdays* :weekday) + (gethash "%b" ht) (make-word-parser 20 *months* :month) + (gethash "%d" ht) (make-numeric-parser 2 0 31 :day) + (gethash "%m" ht) (make-numeric-parser 2 1 12 :month) + (gethash "%p" ht) (make-word-parser 2 *ampm* :ampm) + (gethash "%S" ht) (make-numeric-parser 2 0 59 :second) + (gethash "%y" ht) (make-numeric-parser 2 0 99 :year) + ;; (gethash "%I" ht) need to convert the 12-hour hour to 24-hour hour + ) + ht) + "Maps format descriptors to the functions that parse them. Keys are +format descriptors, which are strings such as '%Y'. Values are functions +which extract & return a CONS for an assoc-list or NIL.") + +(defun recognize-fmt (strm fmt-lst) + "STRM is an input stream to parse. FMT-LST is list of terms from fmt +string." + ;; Apply funcs for terms, collecting results. + (let ((x (mapcar #'(lambda (term) + (let ((fn (gethash term *term-parsers*)) + x) + (if fn + ;; Call the FN to parse the term. It'll + ;; return a pair or Nil. + (setq x (funcall fn strm)) + ;; Else there is no function, so assume the + ;; term is literal. + (setq x (parse-literal term strm))) + x)) + fmt-lst))) + (when *debug* + (format t "~&~A: trace: ~S" 'recognize-fmt x)) + (peek-char t strm nil) ; consume remaining spaces, if any + (cond ((not (end-of-stream? strm)) + ;; Not at end of STRM. means we didn't consume all input. Fail. + (when *debug* + (format t "~&~A: debug: not at end of stream" 'recognize-fmt) + (format t "~& Next character is ~S." (peek-char nil strm))) + nil) + ((member nil x) + (when *debug* + (format t "~&~A: debug: At least one term didn't parse." + 'recognize-fmt)) + nil) + (t + ;; Good + (create-broken x))))) + +(defun make-fmt-recognizer (fmt) + (let ((fmt-lst (convert-fmt-string-to-list fmt))) + #'(lambda (str tokens) + (declare (type string str) (ignore tokens)) + (with-input-from-string (strm str) + (recognize-fmt strm fmt-lst))))) + +(defvar *default-recognizers* + (list (make-fmt-recognizer "%Y-%m-%dT%H:%M:%S") + (make-fmt-recognizer "%Y-%m-%dT%H:%M:%S%Z") + (make-fmt-recognizer "%Y-%B-%dT%H:%M:%S") + (make-fmt-recognizer "%Y-%B-%dT%H:%M:%S%Z") + (make-fmt-recognizer "%Y%B%d%Z") + (make-fmt-recognizer "%Y-%B-%d%Z") + (make-fmt-recognizer "%Y%m%d%Z") + (make-fmt-recognizer "%Y-%m-%d%Z") + (make-fmt-recognizer "%Y%B%d") + (make-fmt-recognizer "%Y-%B-%d") + (make-fmt-recognizer "%Y%m%d") + (make-fmt-recognizer "%Y-%m-%d") + (make-fmt-recognizer "%B %d, %Y, %H:%M %p") + 'recognize-now + 'recognize-today + 'recognize-yyyymmdd-nw + 'recognize-yyyymmdd + (make-fmt-recognizer "%Y-%m-%dT%H:%M") + (make-fmt-recognizer "%Y-%m-%dT%H:%M%Z") + (make-fmt-recognizer "%Y-%B-%dT%H:%M") + (make-fmt-recognizer "%Y-%B-%dT%H:%M%Z") + (make-fmt-recognizer "%B%d,%Y") ; silly American date + (make-fmt-recognizer "%m/%d/%Y"))) ; stupid American date + +(defun parse-time (str &optional (recognizers *default-recognizers*)) + "Parse a string containing a date-&-time. Return a universal time. +If the string can't be recognized, return NIL." + ;; Find a function which can parse the string. + (declare (type string str) (type list recognizers)) + (let ((x (find-if #'(lambda (fn) + (funcall fn str (tokenize str))) + recognizers))) + (if x + ;; Get the result from the recongizer. + (let ((y (funcall x str (tokenize str)))) + ;; If the result is a number, assume it's a universal time & + ;; return it as-is. If it's a BROKEN-TIME, must convert it + ;; to a universal time. Anything else is an error, for which + ;; we return NIL. + (typecase y + (integer y) + (broken-time (broken-to-ut y)) + (list (broken-to-ut (create-broken y))) + (t nil))) + ;; Else, we couldn't find a function that parsed it + nil))) + +;;; --- end of file --- diff --git a/mulk-journal.asd b/mulk-journal.asd index 49a1e12..4a9978d 100644 --- a/mulk-journal.asd +++ b/mulk-journal.asd @@ -27,7 +27,8 @@ #:yaclml #:lisp-cgi-utils #:alexandria #:xml-emitter #:split-sequence #:clsql #:clsql-uffi #:clsql-sqlite3 #:drakma #:cybertiggyr-time) - :components ((:file "defpackage") + :components ((:file "cybertiggyr-time/time.lisp") + (:file "defpackage") (:file "macros") (:file "globals") (:file "utils") |