summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--cybertiggyr-time/time.lisp1287
-rw-r--r--mulk-journal.asd3
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")