home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / edb / db-time.el < prev    next >
Encoding:
Text File  |  1993-06-14  |  35.9 KB  |  1,082 lines
  1. ;;; db-time.el --- part of EDB, the Emacs database
  2.  
  3. ;; See database.el for copyright notice, distribution conditions, etc.
  4.  
  5. ;; Author: Michael Ernst <mernst@theory.lcs.mit.edu>
  6. ;;    Alan K. Stebbens, UCSB <aks@hub.ucsb.edu>
  7. ;; Keywords: EDB
  8.  
  9. ;;; Commentary:
  10.  
  11. ;; Library of date and time types for EDB database fields.
  12. ;; This file is an extension of db-types.el.
  13.  
  14. ;; This file defines the date and time record types, plus several kinds of
  15. ;; date- and time-related display types, with variations on formatting.
  16.  
  17. ;; For efficiency, the types are defined in terms of the displayspec
  18. ;; abstraction instead of via format strings.  Improvements and additions
  19. ;; are welcome.
  20.  
  21. ;;; Code:
  22.  
  23.  
  24. (require 'db-util)
  25.  
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; Dates
  29. ;;;
  30.  
  31. ;;; The definition of the displayspec and recordfieldspecs is at the end of
  32. ;;; the date section.
  33.  
  34. ;;;
  35. ;;; Abstraction:  dotted list of (year month . day), all integers.
  36. ;;;
  37.  
  38. (defun make-date (year month day)
  39.   "Make an EDB date object with arguments YEAR MONTH DAY."
  40.   (cons year (cons month day)))
  41.  
  42. (defun date-year (date) (car date))
  43. (defun date-month (date) (car (cdr date)))
  44. (defun date-day (date) (cdr (cdr date)))
  45. (proclaim-inline date-year date-month date-day)
  46.  
  47. (defun make-empty-date ()
  48.   "Return a date object containing no information."
  49.   (make-date nil nil nil))
  50.  
  51. (defun zero-or-empty-date-p (date)
  52.   "Return t if all the date's slots contain nil or 0, nil otherwise."
  53.   (and (let ((year (date-year date))) (or (not year) (zerop year)))
  54.        (let ((month (date-month date))) (or (not month) (zerop month)))
  55.        (let ((day (date-day date))) (or (not day) (zerop day)))))
  56.  
  57. (defun date-year-short (date)
  58.   "Extract the year and return it modulo 1900."
  59.   (% (date-year date) 1900))
  60.  
  61. (defun date-year-long (date)
  62.   "Extract the year as a four digit value."
  63.   (let ((yy (date-year date)))
  64.     (cond ((< yy 50) (+ 2000 yy))
  65.       ((< yy 99) (+ 1900 yy))
  66.       (t yy))))
  67.  
  68. (proclaim-inline make-date make-empty-date date-year-short)
  69.  
  70. ;;; Years
  71.  
  72. (defun leap-year-p (year)
  73.   "Return t if YEAR is a Gregorian leap year."
  74.   (or
  75.    (and (=  (% year   4) 0)
  76.     (/= (% year 100) 0))
  77.    (= (% year 400) 0)))
  78.  
  79. (defun date->day-of-year (date)
  80.   "Return the day number within the year for Gregorian DATE."
  81.   ;;
  82.   ;; An explanation of the calculation can be found in PascAlgorithms by
  83.   ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
  84.   ;;
  85.   (let* ((month (date-month date))
  86.      (day   (date-day date))
  87.      (year  (date-year date))
  88.          (day-of-year (+ day (* 31 (1- month)))))
  89.     (if (> month 2)
  90.     (progn
  91.       (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
  92.       (if (leap-year-p year)
  93.           (setq day-of-year (1+ day-of-year)))))
  94.     day-of-year))
  95.  
  96. (defun date->absolute-days (date)
  97.   "Return the number of days elapsed between the Gregorian 12/31/1 BC and DATE.
  98. The Gregorian date Sunday, December 31, 1 BC is imaginary."
  99.   (let ((mm (date-month date))
  100.     (dd (date-day date))
  101.     (yy (1- (date-year-long date))))
  102.     (+ (date->day-of-year date)        ;+ days in this year
  103.        (* 365 yy)            ;+ days in prior years
  104.        (/ yy 4)                ;+ Julian leap years
  105.        (- (/ yy 100))            ;- century years
  106.        (/ yy 400)            ;+ Gregorian leap years
  107.        )))
  108.    
  109. ;;; Weekdays
  110.  
  111. ;; Sunday must come first -- absolute dates begin on Sunday, Dec 31, 1BC.
  112. (defconst weekday-array
  113.   '["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
  114.   "An array of weekday names.")
  115.  
  116. (defconst weekday-alist
  117.  '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3)
  118.    ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6)
  119.    ("Tues" . 2) ("Thurs" . 4)
  120.    ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
  121.    ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
  122.  
  123. (defun integer->weekday (dayx)
  124.   "Convert INDEX into its corresponding weekday name."
  125.   (aref weekday-array (% dayx 7)))
  126.  
  127. (defun integer->weekday-abbrev (dayx)
  128.   "Convert INDEX into its corresponding three-letter abbreviated weekday name."
  129.   (substring (integer->weekday dayx) 0 3))
  130.  
  131. (defun date->weekday-index (date)
  132.   "Return the weekday index for DATE."
  133.   (% (date->absolute-days date) 7))
  134.  
  135. (defun date->weekday-name (date)
  136.   "Return the weekday name for the DATE."
  137.   (integer->weekday (date->weekday-index date)))
  138.  
  139. (defun date->weekday-abbrev (date)
  140.   "Return the abbreviated weekday name for the DATE"
  141.   (substring (date->weekday-name date) 0 3))
  142.  
  143. (proclaim-inline integer->weekday integer->weekday-abbrev
  144.          date->weekday-index date->weekday-name date->weekday-abbrev)
  145.  
  146. ;;; Months
  147.  
  148. (defconst monthlength-array
  149.   [0 31 28 31 30 31 30 31 31 30 31 30 31])
  150.  
  151. ;; I could add a fancy leap year check.
  152. (defun date-month-day-compatible (date)
  153.   (if (date-day date)
  154.       (if (date-month date)
  155.       (<= (date-day date) (aref monthlength-array (date-month date)))
  156.     (error "Date has a day but no month"))
  157.     t))
  158.  
  159. ;; These sub-alists aren't really necessary; they're only used to make the
  160. ;; associated arrays.  And the full alist is used, of course.  But it uses
  161. ;; different cons cells, which is a waste.
  162. (defconst full-monthname-alist
  163.   '(("January" . 1) ("February" . 2) ("March" . 3) ("April" . 4)
  164.     ("May" . 5) ("June" . 6) ("July" . 7) ("August" . 8)
  165.     ("September" . 9) ("October" . 10) ("November" . 11) ("December" . 12)))
  166.  
  167. (defconst monthabbrev-alist
  168.   '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
  169.     ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
  170.  
  171. (defconst monthname-alist
  172.   (append monthabbrev-alist
  173.       full-monthname-alist
  174.       '(("Sept" . 9))))
  175.  
  176. ;; Why do I need this in an array?  (Why not?)  (Well, it's extra space.)
  177. (defconst monthabbrev-array
  178.   (vconcat '("") (mapcar (function car) monthabbrev-alist)))
  179.  
  180. (defconst monthname-array
  181.   (vconcat '("") (mapcar (function car) full-monthname-alist)))
  182.  
  183. ;; MONTHNAME shouldn't include a trailing period, even if it's an abbreviation.
  184. (defun monthname->integer (monthname)
  185.   ;; (setq monthname (capitalize (string-right-trim "." monthname)))
  186.   (cdr (assoc (capitalize monthname) monthname-alist)))
  187.  
  188. (defun integer->monthname (monthno)
  189.   (aref monthname-array monthno))
  190.  
  191. (defun integer->monthabbrev (monthno)
  192.   (aref monthabbrev-array monthno))
  193.  
  194. (proclaim-inline monthname->integer integer->monthname integer->monthabbrev)
  195.  
  196.  
  197. ;;; Ordering functions
  198.  
  199. (defun date-order-absolute (date1 date2)
  200.   (let ((result (number-or-nil-order-nil-greatest
  201.          (date-year date1) (date-year date2))))
  202.     (if (zerop result)
  203.     (date-order-within-year date1 date2)
  204.       result)))
  205.  
  206. (defun date-order-within-year (date1 date2)
  207.   (let ((result (number-or-nil-order-nil-greatest
  208.           (date-month date1) (date-month date2))))
  209.     (if (zerop result)
  210.     (number-or-nil-order-nil-greatest (date-day date1) (date-day date2))
  211.       result)))
  212.  
  213.  
  214. ;;;
  215. ;;; Regexps
  216. ;;;
  217.  
  218. (defconst monthname-regexp
  219.   (concat "\\("
  220.       (mapconcat (function car)
  221.              monthname-alist
  222.              "\\|")
  223.       "\\)\\.?"))
  224.  
  225. (defconst weekday-regexp
  226.   (concat "\\("
  227.       (mapconcat (function car)
  228.              weekday-alist
  229.              "\\|")
  230.       "\\)\\.?"))
  231.  
  232. (defconst monthnumber-regexp "\\(0?[1-9]\\|1[0-2]\\)")
  233. (defconst monthnumber-regexp-two-char "\\(0[1-9]\\|1[0-2]\\)")
  234.  
  235. (defconst monthday-regexp "\\(0?[1-9]\\|[12][0-9]\\|3[01]\\)")
  236. (defconst monthday-regexp-two-char "\\([0-2][0-9]\\|3[01]\\)")
  237.  
  238. ;; Note no surrounding ()!
  239. (defconst full-year-regexp "[0-2][0-9][0-9][0-9]")
  240. (defconst short-year-regexp "[0-9][0-9]")
  241.  
  242. ;; Note no internal grouping; is that intentional?
  243. ;; That is, this only counts as one grouping when counting regexp matches,
  244. ;; because I didn't use any internal \\( \\).
  245. (defconst year-regexp (concat "\\(" full-year-regexp
  246.                   "\\|" short-year-regexp "\\)"))
  247.  
  248. ;; ;; I think this works; but I don't think I want to use it.
  249. ;; (defconst year-regexp-maybe (concat year-regexp "*"))
  250.  
  251. (defconst elt-separator-regexp "[ -.,/']+")
  252.  
  253.  
  254. ;; I could limit the separators some, but it's
  255. ;; easier to use the same ones everywhere.
  256. (defconst date-regexps
  257.   (list
  258.    ;; MMDDYY
  259.    (cons (concat monthname-regexp
  260.          elt-separator-regexp
  261.          monthday-regexp
  262.          "\\("
  263.          elt-separator-regexp
  264.          year-regexp
  265.          "\\)?")
  266.      '(4 nil 1 2))
  267.    (cons (concat monthnumber-regexp
  268.          elt-separator-regexp
  269.          monthday-regexp
  270.          "\\("
  271.          elt-separator-regexp
  272.          year-regexp
  273.          "\\)?")
  274.      '(4 1 nil 2))
  275.    ;; DDMMYY
  276.    (cons (concat monthday-regexp
  277.          elt-separator-regexp
  278.          monthname-regexp
  279.          "\\("
  280.          elt-separator-regexp
  281.          year-regexp
  282.          "\\)?")
  283.      '(4 nil 2 1))
  284.    (cons (concat "\\("
  285.          monthday-regexp
  286.          elt-separator-regexp
  287.          "\\)?"
  288.          monthname-regexp
  289.          elt-separator-regexp
  290.          year-regexp)
  291.      '(4 nil 3 2))
  292.    (cons (concat monthday-regexp
  293.          elt-separator-regexp
  294.          monthnumber-regexp
  295.          elt-separator-regexp
  296.          "\\(" full-year-regexp "\\)")
  297.      '(3 2 nil 1))
  298.    ;; YYMMDD
  299.    ;; Using year-regexp instead of full-year-regexp is ambiguous (consider
  300.    ;; 11-11-11), but we already tried MMDDYY and it failed.
  301.    (cons (concat year-regexp
  302.          elt-separator-regexp
  303.          monthname-regexp
  304.          elt-separator-regexp
  305.          monthday-regexp)
  306.      '(1 nil 2 3))
  307.    (cons (concat year-regexp
  308.          elt-separator-regexp
  309.          monthnumber-regexp
  310.          elt-separator-regexp
  311.          monthday-regexp)
  312.      '(1 2 nil 3))
  313.    ;; YYMMDD, no separators
  314.    ;; This is ambiguous.
  315.    (cons (concat year-regexp
  316.          monthnumber-regexp-two-char "?"
  317.          monthday-regexp-two-char "?")
  318.      '(1 2 nil 3))
  319.    ;; WWMMDDYY
  320.    (cons (concat weekday-regexp
  321.          elt-separator-regexp
  322.          monthname-regexp
  323.          elt-separator-regexp
  324.          monthday-regexp
  325.          "\\("
  326.          elt-separator-regexp
  327.          year-regexp
  328.          "\\)?")
  329.      '(5 nil 2 3))
  330.    ;; WWDDMMYY
  331.    (cons (concat weekday-regexp
  332.          elt-separator-regexp
  333.          monthday-regexp
  334.          elt-separator-regexp
  335.          monthname-regexp
  336.          "\\("
  337.          elt-separator-regexp
  338.          year-regexp
  339.          "\\)?")
  340.      '(5 nil 3 2))
  341.    ;; ctime
  342.    (cons (concat
  343.       weekday-regexp
  344.       " "
  345.       monthname-regexp
  346.       "  ?"
  347.       monthday-regexp
  348.       ;; time of day
  349.       " [0-9:]+ "
  350.       "\\(" full-year-regexp "\\)")
  351.      '(4 nil 2 3))
  352.    )
  353.   "Assoc list of regexps and match locators.
  354. A match locator is a list of four numbers indicating which submatch of the
  355. regexp contains the year, month number, month name, and day of the month.
  356. The list elements may be nil if that information is not available.")
  357.  
  358.  
  359. ;;;
  360. ;;; Parsing dates
  361. ;;;
  362.  
  363. (defun parse-date-string (date-string)
  364.   "Parse DATE-STRING, and return a date object; err if the parse is invalid.
  365. If DATE-STRING contains only whitespace, return a null date object.
  366. If DATE-STRING is nil, use the result of `parse-date-default-function' instead."
  367.   (let ((regexp-alist date-regexps)
  368.     result
  369.     match-list)
  370.     (db-debug-message "parse-date-string `%s'" date-string)
  371.     (if (null date-string)        ;provide default date for nil strings
  372.     (setq date-string (parse-date-default-function))
  373.       (setq date-string (string-trim-whitespace date-string)))
  374.     (if (zerop (length date-string))    ;if empty string,
  375.     (make-empty-date)        ;return empty date
  376.       ;; regexp-alist is nulled if a match is found
  377.       (progn
  378.     (while regexp-alist
  379.       (if (string-match (concat "^" (car (car regexp-alist)) "$")
  380.                 date-string)
  381.           ;; Bug in version 18 save-match-data:  it's impossible
  382.           ;; to have a marker at 0, so this gets converted to 1.
  383.           (setq match-list (mapcar (function (lambda (match-no)
  384.                      (and match-no
  385.                           (match-string-maybe
  386.                            match-no date-string))))
  387.                        (cdr (car regexp-alist)))
  388.             ;; match-list is year, monthnumber, monthname, day
  389.             result
  390.             (make-date
  391.              (string-or-nil->number-or-nil (car match-list))
  392.              (or (string-or-nil->number-or-nil (car (cdr match-list)))
  393.              (and (car (cdr (cdr match-list)))
  394.                   ;; match is non-nil; don't check match-beginning
  395.                   ;; At one time this clobbered the match-data.
  396.                   (monthname->integer (car (cdr (cdr match-list))))))
  397.              (string-or-nil->number-or-nil (nth 3 match-list)))
  398.             regexp-alist nil)
  399.         ;; string-match failed
  400.         (setq regexp-alist (cdr regexp-alist))))
  401.     (db-debug-message "parse-date-string:  result = %s" result)
  402.     (if result
  403.         (if (date-month-day-compatible result)
  404.         (if (zero-or-empty-date-p result)
  405.             (make-empty-date)
  406.           result)
  407.           (error "There is no such day as %s %d!"
  408.              (integer->monthname (date-month result))
  409.              (date-day result)))
  410.       (error "`%s' is not a valid date." date-string))))))
  411.  
  412. (defun parse-date-string-or-nil (date-string)
  413.   "Like `parse-date-string', but returns null date in case of nil arg."
  414.   (if date-string
  415.       (parse-date-string date-string)
  416.     (make-empty-date)))
  417.  
  418. (defvar parse-date-default 'empty
  419.   "One of the symbols 'empty or 'current-date, specifying what date string
  420. `parse-date-default-function' should return, and `parse-date-string' should
  421. use when passed a nil argument.")
  422.  
  423. (defun parse-date-default-function ()
  424.   "Return a default value for `parse-date-string' to use if its input is nil."
  425.   (cond ((eq parse-date-default 'empty)
  426.      "")
  427.     ((or (eq parse-date-default 'today)
  428.          (eq parse-date-default 'current-date)
  429.          (eq parse-date-default 'current-time)
  430.          (eq parse-date-default 'current-time-string))
  431.      (current-time-string))
  432.     (t
  433.      (error "Unrecodgnized value `%s' for variable parse-date-default."
  434.         parse-date-default))))
  435.  
  436.  
  437.  
  438. ;; AKS, UCSB, 9/30/92
  439. ;;
  440. ;; General purpose date format routine
  441.  
  442.  
  443. ;; *WARNING*: If any new escape symbols are added, BE SURE that they are
  444. ;; placed in order of longest symbol first, so that the regexp computed
  445. ;; below works properly.
  446.  
  447. (defconst format-date-sub-syms-alist
  448.   '(("day"     . ((date-day date) .   (date->weekday-abbrev date)))
  449.     ("dd"      . ((date-day date) .   (format "%02d" (date-day date))))
  450.     ("d"       . ((date-day date) .   (date-day date)))
  451.     ("month"   . ((date-month date) . (integer->monthname (date-month date))))
  452.     ("mon"     . ((date-month date) . (integer->monthabbrev (date-month date))))
  453.     ("mm"      . ((date-month date) . (format "%02d" (date-month date))))
  454.     ("m"       . ((date-month date) . (date-month date)))
  455.     ("year"    . ((date-year date) .  (date-year-long date)))
  456.     ("yy"      . ((date-year date) .  (format "%02d" (date-year-short date))))
  457.     ("jday"    . ((and (date-day date)
  458.                (date-month date)
  459.                (date-year date)) . (date->day-of-year date)))
  460.     ("wday"    . ((and (date-day date)
  461.                (date-month date)
  462.                (date-year date)) . (date->weekday-index date)))
  463.     ("weekday" . ((and (date-day date)
  464.                (date-month date)
  465.                (date-year date)) . (date->weekday-name date)))
  466.     )
  467.   "An alist of (NAME . (TEST . SEXP)) used by `format-date'.  Each NAME
  468. is a string, which, when prefixed by \"%\", will be substituted by the
  469. value resulting from evalling the associated SEXP but only if TEST evals
  470. to non-null.")
  471.  
  472. ;; Build a regexp which matches the symbol names given above
  473.  
  474. (defconst format-date-sub-syms-regexp
  475.   (concat "%\\("
  476.       (mapconcat (function car) format-date-sub-syms-alist "\\|")
  477.       "\\)")
  478.   "A regexp pattern to parse format strings for symbol substition strings;
  479. this variable is computed from the variable `format-date-sub-syms-alist'.")
  480.  
  481. (defun format-date (format-string &optional date)
  482.   "Using FORMAT-STRING, format the DATE, which defaults to the current date
  483. if nil.  FORMAT-STRING can contain the following symbol strings,
  484. which are substituted by their corresponding value from the date; other
  485. characters are inserted as is.
  486.  
  487.  String    Action
  488.  ======    ======
  489.   %d       day of month -- 1 to 31 (one or two digits)
  490.   %dd       day of month -- 01 to 31 (always two digits)
  491.   %m       month of year - 1 to 12 (one or two digits)
  492.   %mm       month of year - 01 to 12 (always two digits)
  493.   %mon       month name (abbreviated) - Jun
  494.   %month   full month name - June
  495.   %yy       last 2 digits of year - 00 to 99
  496.   %year       year as 4 digits -- 0000 to 9999?
  497.   %jday       Julian day of year -- 1 to 366
  498.   %wday       day of week -- 0 to 6 (Sunday = 0)
  499.   %day       day of week name -- \"Sun\" to \"Sat\"
  500.   %weekday full day of week name -- \"Sunday\" to \"Saturday\"
  501.  
  502. See the variables `format-date-sub-syms-alist' and
  503. `format-date-sub-syms-regexp'.
  504.  
  505. A special case: if an element of DATE is nil, its field is omitted.  A
  506. DATE object of all nils is thus formatted as the empty string."
  507.  
  508.   (if (null date)
  509.       (setq date (parse-date-string nil)))
  510.   (let* ((ofs 0) (buf "") sym-alist x)
  511.     (while (setq x (string-match
  512.             format-date-sub-syms-regexp format-string ofs))
  513.       (if (not (setq sym-alist (assoc (match-string 1 format-string)
  514.                       format-date-sub-syms-alist)))
  515.       (error "format-date: Symbol %s is not in format-date-sub-syms-alist!"
  516.          (match-string 1 format-string))
  517.     (if (eval (car (cdr sym-alist)))    ;does TEST work?
  518.         ;; Yes; insert its prefix string and its value
  519.         (setq buf (concat buf
  520.                   (if (not (string= buf ""))
  521.                   (substring format-string ofs x))
  522.                   (eval (cdr (cdr sym-alist)))))
  523.       ))
  524.       (setq ofs (match-end 0))        ;skip past the variable
  525.       )
  526.     (concat buf (substring format-string ofs))))
  527.  
  528.  
  529. (defconst simple-format-date-default "%month %d, %year"
  530.   "*A default format used by simple-format-date.")
  531.  
  532. ;; Note only one argument
  533. (defun simple-format-date (date)
  534.   "Format the DATE using a default format, defined by the variable
  535. `simple-format-date-default'.
  536. If DATE is nil, use the value of `parse-date-default-function'."
  537.   (format-date simple-format-date-default date))
  538.  
  539. (defun simple-format-date-or-nil (date)
  540.   "Format the DATE using a default format, defined by the variable
  541. `simple-format-date-default'.
  542. If DATE is nil, return the empty string."
  543.   (if date
  544.       (format-date simple-format-date-default date)
  545.     ""))
  546.  
  547.  
  548. ;; AKS, format-date-xxx routines
  549. ;; The following display functions are used above in the displayspec
  550. ;; definitions:
  551. ;;
  552. ;;  Function             Sample    Separator var                   Default
  553. ;;  ==================   ========  ===========================     =======
  554. ;;  format-date-mmddyy   06/10/54  format-date-mmddyy-separator    "/"
  555. ;;  format-date-yymmdd   541006    format-date-yymmdd-separator    ""
  556. ;;  format-date-ddmmyy   10.6.54   format-date-ddmmyy-separator    "."
  557. ;;  format-date-ddmmmyy  6 Jun 54  format-date-ddmmmyy-separator   " "
  558. ;;  format-date-yyyymmdd 1954/6/6  format-date-yyyymmdd-separator  "/"
  559. ;;
  560. ;;  format-date-europe   10.6.54
  561. ;;  format-date-dec      06-Jun-54
  562. ;;  format-date-full     June 6, 1954
  563. ;;  format-date-unix     Sun Jun 6 1954
  564. ;;  format-date-all      Sunday, June 6, 1954
  565.  
  566. ;; Is there a better way to do this?  How about something like:
  567. ;; /field,date="%w %m %d %y"
  568. ;; (Display specifications may not contain spaces.)
  569. ;; [Ok, how about: ``/field,date="%w_%m_%d_%y"'' if we make format-date
  570. ;; turn "_" into blanks??]
  571.  
  572. (defconst format-date-mmddyy-separator "/"
  573.   "*A string used to separate the components of the MMDDYY date format.")
  574.  
  575. (defun format-date-mmddyy (date)
  576.   "Format the DATE into a MM/DD/YY format.  The \"/\" separator is a user-
  577. configuration variable in format-date-mmddyy-separator.
  578. If DATE is nil, return the empty string."
  579.   (if date
  580.       (let ((sep format-date-mmddyy-separator))
  581.     (format-date (format "%%mm%s%%dd%s%%yy" sep sep) date))
  582.     ""))
  583.  
  584. (defconst format-date-ddmmyy-separator "."
  585.   "*A string used to separate the components of the DDMMYY date format.")
  586.  
  587. (defun format-date-ddmmyy (date)
  588.   "Format the DATE into a DD.MM.YY format.  The \".\" separator is configured
  589. by the variable format-date-ddmmyy-separator.
  590. If DATE is nil, return the empty string."
  591.   (if date
  592.       (let ((sep (or format-date-ddmmyy-separator "")))
  593.     (format-date (format "%%d%s%%m%s%%yy" sep sep) date))
  594.     ""))
  595.  
  596. (defconst format-date-yymmdd-separator ""
  597.   "*A string used to separate the componenets of the YYMMDD date format.")
  598.  
  599. (defun format-date-yymmdd (date)
  600.   "Format the DATE into a YYMMDD format.  The components are separated by
  601. the value of `format-date-yymmdd-separator', which is initially the null
  602. string.
  603. If DATE is nil, return the empty string."
  604.   (if date
  605.       (let ((sep (or format-date-yymmdd-separator "")))
  606.     (format-date (format "%%yy%s%%mm%s%%dd" sep sep) date))
  607.     ""))
  608.  
  609. (defconst format-date-ddmmmyy-separator " "
  610.   "*A string used to separate the components of the DD MMM YY date format.")
  611.  
  612. (defun format-date-ddmmmyy (date)
  613.   "Format the DATE into a DD MMM YY format.  The components are separated by
  614. the value of format-date-ddmmmyy-separator, which is initially a single space.
  615. If DATE is nil, return the empty string."
  616.   (if date
  617.       (let ((sep format-date-ddmmmyy-separator))
  618.     (format-date (format "%%d%s%%mon%s%%yy" sep sep) date))
  619.     ""))
  620.  
  621. (defconst format-date-yyyymmdd-separator "/"
  622.   "*A string used to separate the components of the YYYY/MM/DD date format.")
  623.  
  624. (defun format-date-yyyymmdd (date)
  625.   "Format the DATE into a YYYY/MM/DD format.  The components are separated by
  626. the value of `format-date-yyyymmdd-separator', which is initially a ``/''.
  627. If DATE is nil, return the empty string."
  628.   (if date
  629.       (let ((sep format-date-yyyymmdd-separator))
  630.     (format-date (format "%%year%s%%m%s%%d" sep sep) date))
  631.     ""))
  632.  
  633.  
  634. (defun format-date-full (date)
  635.   "Format the DATE into the full format: MMMM DD, YYYY.
  636. If DATE is nil, return the empty string."
  637.   (if date
  638.       (format-date "%month %d, %year" date)
  639.     ""))
  640.  
  641. (defun format-date-unix (date)
  642.   "Format the DATE into the standard Unix format: DAY MMM DD YYYY.
  643. If DATE is nil, return the empty string."
  644.   (if date
  645.       (format-date "%day %mon %d %year" date)
  646.     ""))
  647.  
  648. (defun format-date-all (date)
  649.   "Format the DATE using all components, without abbreviations, in the format
  650. DAYNAME, MMMM DD, YYYY.
  651. If DATE is nil, return the empty string."
  652.   (if date
  653.       (format-date "%weekday, %month %d, %year" date)
  654.     ""))
  655.  
  656. ;; Some common variations on a theme
  657.  
  658. (defun format-date-dec (date)
  659.   "Format the DATE into the standard DEC format: dd-mmm-yy.
  660. If DATE is nil, return the empty string."
  661.   (let ((format-date-ddmmmyy-separator "-"))
  662.     (format-date-ddmmmyy date)))
  663.  
  664. (defun format-date-europe (date)
  665.   "Format the DATE into the European standard, which is DD.MM.YY.
  666. If DATE is nil, return the empty string."
  667.   (let ((format-date-ddmmyy-separator "."))
  668.     (format-date-ddmmyy date)))
  669.  
  670.  
  671. ;; Test routines
  672. (defun test-date-formats ()
  673.    (interactive)
  674.    (let ((formats '(mmddyy ddmmyy yymmdd ddmmmyy yyyymmdd full
  675.                unix all dec europe))
  676.      form)
  677.      (while formats
  678.        (setq form (car formats)
  679.          formats (cdr formats))
  680.        (message "Format %s = \"%s\"" form
  681.         (funcall (intern (concat "format-date-" (symbol-name form)))
  682.              (parse-date-string (current-time-string))))
  683.        (read-char))))
  684.  
  685.  
  686. ;;;
  687. ;;; EDB type definitions
  688. ;;;
  689.  
  690. (let ((ds (make-displayspec)))
  691.   (displayspec-set-indent ds nil)
  692.   (displayspec-set-actual->display ds (function simple-format-date))
  693.   (displayspec-set-display->actual ds (function parse-date-string))
  694.   (define-displaytype-from-displayspec 'date ds))
  695. (let ((rs (make-recordfieldspec)))
  696.   (recordfieldspec-set-type rs 'date)
  697.   (recordfieldspec-set-default-value rs (make-empty-date))
  698.   (recordfieldspec-set-actual->stored rs (function date->storage-string))
  699.   (recordfieldspec-set-stored->actual rs (function storage-string->date))
  700.   (recordfieldspec-set-merge-function rs (function date-merge))
  701.   (recordfieldspec-set-order-fn rs (function date-order-absolute))
  702.   (recordfieldspec-set-match-function rs (function date-match-function))
  703.   (recordfieldspec-set-help-info rs "A date.")
  704.   (define-recordfieldtype-from-recordfieldspec 'date rs))
  705. (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec 'date))))
  706.   (recordfieldspec-set-stored->actual rs (function storage-string->date))
  707.   (define-recordfieldtype-from-recordfieldspec 'date-efficient-storage rs))
  708.  
  709. (let ((ds (copy-displayspec (displaytype->displayspec 'date))))
  710.   (displayspec-set-actual->display ds (function simple-format-date-or-nil))
  711.   (displayspec-set-display->actual ds (function parse-date-string-or-nil))
  712.   (define-displaytype-from-displayspec 'date-or-nil ds))
  713. (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec 'date))))
  714.   (recordfieldspec-set-type rs 'date-or-nil)
  715.   (recordfieldspec-set-default-value rs nil)
  716.   (recordfieldspec-set-stored->actual rs (function parse-date-string-or-nil))
  717.   (recordfieldspec-set-help-info rs "(Optional) date.")
  718.   (define-recordfieldtype-from-recordfieldspec 'date-or-nil rs))
  719.  
  720. ;; AKS, 9/30/92
  721. ;; def-date-disptype is used to create alternative display types
  722. ;; on the date.
  723.  
  724. (defun def-date-disptype (type)
  725.   "Construct a new date displaytype based on TYPE (a string).  A function named
  726. `format-date-TYPE' must exist."
  727.   (let* ((func (intern (concat "format-date-" type)))
  728.      (typename (intern (concat "date-" type)))
  729.      (ds (copy-displayspec (displaytype->displayspec 'date))))
  730.     (displayspec-set-actual->display ds func)
  731.     (define-displaytype-from-displayspec typename ds)))
  732.  
  733. (def-date-disptype "mmddyy")
  734. (def-date-disptype "yymmdd")
  735. (def-date-disptype "ddmmyy")
  736. (def-date-disptype "ddmmmyy")
  737. (def-date-disptype "yyyymmdd")
  738. (def-date-disptype "europe")
  739. (def-date-disptype "full")
  740. (def-date-disptype "all")
  741. (def-date-disptype "unix")
  742. (def-date-disptype "dec")
  743.  
  744.  
  745. (defun date-match-function (patterndate targetdate)
  746.   (and (or (not (date-year patterndate))
  747.        (and (date-year targetdate)
  748.         (= (date-year patterndate) (date-year targetdate))))
  749.        (or (not (date-month patterndate))
  750.        (and (date-month targetdate)
  751.         (= (date-month patterndate) (date-month targetdate))))
  752.        (or (not (date-day patterndate))
  753.        (and (date-day targetdate)
  754.         (= (date-day patterndate) (date-day targetdate))))))
  755.  
  756. ;; Merge dates: if an item of a date is nil, use the other date's value.
  757. (defun date-merge (date1 date2)
  758.   (let ((mm (or (date-month date1) (date-month date2)))
  759.     (dd (or (date-day date1) (date-day date2)))
  760.     (yy (or (date-year date1) (date-year date2))))
  761.     (make-date yy mm dd )))
  762.  
  763. ;; File representation
  764. (fset 'date->storage-string 'format-date-full)
  765. (fset 'storage-string->date 'date-stored->actual)
  766.  
  767. ;;; This is fairly human-readable, but ambiguous to Europeans.
  768. (defun date->storage-string-mmddyyyy (date)
  769.   (if (date-year date)
  770.       (format "%02d/%02d/%02d"
  771.           (or (date-month date) 0)
  772.           (or (date-day date) 0)
  773.           (or (date-year date) 0))
  774.     (if (not (or (date-month date) (date-day date)))
  775.     ""
  776.       (format "%02d/%02d"
  777.           (or (date-month date) 0)
  778.           (or (date-day date) 0)))))
  779.  
  780. (defun storage-string-mmddyyyy->date (str)
  781.   (let ((month (string->integer (substring str 0 2)))
  782.     (day (string->integer (substring str 3 5)))
  783.     (year (and (> (length str) 5)
  784.            (string->integer (substring str 6)))))
  785.     (make-date (if (not (zerop month)) month)
  786.            (if (not (zerop day)) day)
  787.            (if (and year (not (zerop year))) year))))
  788.  
  789. ;;; This is quite fast, but not very human-readable.
  790. (defun date->storage-string-lisp (date)
  791.   (format "%s" date))
  792.  
  793. (defun storage-string-lisp->date (str)
  794.   (car (read-from-string str)))
  795.  
  796. ;; Don't do anything if it's already a date.  The point of this is to do
  797. ;; the right thing even when the field didn't appear in the database file,
  798. ;; so the record field got set to the empty date rather than the empty string.
  799. (defun date-stored->actual (date-stored)
  800.   (if (stringp date-stored)
  801.       ;; This is slow but general.
  802.       (parse-date-string date-stored)
  803.     date-stored))
  804.  
  805.  
  806. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  807. ;;; Times
  808. ;;;
  809. ;;; Much of this was lifted from Dates
  810. ;;; Otherwise it was written by Alan K. Stebbens, UCSB <aks@hub.ucsb.edu>
  811. ;;;
  812. ;;; Display types:   time, time-12, time-24, time-12-hhmm, time-24-hhmm,
  813. ;;;             and time-hhmm.
  814. ;;; Field Types:     time, time-12, time-24, and time-arb-storage
  815. ;;; Functions:          parse-time-string, format-time-12, format-time-24
  816. ;;;             time->storage-string, storage-string->time,
  817. ;;;             time-order, time-merge, time-match-function,
  818. ;;;             time-default-constraint
  819. ;;;
  820.  
  821. ;;; Abstraction:  TIME object is a 3-elt list (this allows n'th to work)
  822. (defun make-time (hours mins secs)
  823.   "Arguments HOURS MINS SECS."
  824.   (list hours mins secs))
  825. (proclaim-inline make-time)
  826.  
  827. (defun time-hours (time) (car time))
  828. (defun time-mins (time) (car (cdr time)))
  829. (defun time-secs (time) (car (cdr (cdr time))))
  830. (proclaim-inline time-hours time-mins time-secs)
  831.  
  832. (defun make-empty-time ()
  833.   "Return a time object containing no information."
  834.   (make-time nil nil nil))
  835.  
  836. (defun empty-time-p (time)
  837.   "Return t if all the time's slots contain nil, nil otherwise."
  838.   (and (null (time-hours time))
  839.        (null (time-mins time))
  840.        (null (time-secs time))))
  841.  
  842. ;; time-default-constraint
  843.  
  844. (defun time-default-constraint (time record record-index database)
  845.   "Enforce proper time values."
  846.   (if (or (empty-time-p time)
  847.       (and (< (time-hours time) 23)
  848.            (< (time-mins time) 59)
  849.            (< (time-secs time) 59)))
  850.       t
  851.     (error "Invalid time value.")))
  852.  
  853.  
  854. ;; parse-time-string
  855. ;;
  856. ;; State-driven time parser; I converted this from my Perl time parser.
  857. ;; Alan K. Stebbens, UCSB <aks@hub.ucsb.edu>
  858.  
  859. (defconst parse-time-regexp-array
  860.   [ "\\([0-9]?[0-9]\\)\\(:\\| ?[ap]m\\)"
  861.     "\\([0-5][0-9]\\)\\(:\\| ?[ap]m\\|\\Sw\\|$\\)"
  862.     "\\([0-5][0-9]\\)\\( *[ap]m\\|\\Sw\\|$\\)" ]
  863.   "An array of regexps used by parse-time-string, indexed by the
  864. current parse state to obtain the appropriate regexp.")
  865.  
  866.  
  867. (defun parse-time-string (time-string)
  868.   "Parse the first occurrence of hh:mm:ss in TIME-STRING; return a time object.
  869. If \":ss\" is omitted in TIME-STRING, the seconds default to zero.
  870. If TIME-STRING contains only whitespace, return an empty time object.
  871. If TIME-STRING is nil, use the result of `parse-time-default-function' instead."
  872.   (if (not time-string)            ; provide default time for nil strings
  873.       (setq time-string (parse-time-default-function))
  874.     (setq time-string (string-trim-whitespace time-string)))
  875.   (if (zerop (length time-string))
  876.       (make-empty-time)
  877.     (let ((str time-string)
  878.       (case-fold-search t)
  879.       ;; Initial regexp matches HH: or HHpm
  880.       (hh 0) (mm 0) (ss 0) pm
  881.       (vars '[hh mm ss])
  882.       (ofs 0)
  883.       (state 0))
  884.       (while (and (< state 3)
  885.           (< ofs (length str))
  886.           (string-match (aref parse-time-regexp-array state) str ofs))
  887.     (set (aref vars state) (string-to-int (match-string 1 str)))
  888.     (setq state (if (equal ":" (match-string-maybe 2 str))
  889.             (1+ state)
  890.               3))
  891.     (setq ofs (match-end 0)))
  892.       (make-time (if (and (setq pm (match-string-maybe 2 str))
  893.               (string-match "[ap]m" pm))
  894.              (+ (mod hh 12) (if (string-match "pm" pm) 12 0))
  895.            hh)
  896.          mm ss))))
  897.  
  898. (defvar parse-time-default 'empty
  899.   "One of the symbols 'empty or 'current-time, specifying what time string
  900. `parse-time-default-function' should return, and `parse-time-string' should
  901. use when passed a nil argument.")
  902.  
  903. (defun parse-time-default-function ()
  904.   "Return a default value for `parse-time-string' to use if its input is nil."
  905.   (cond ((eq parse-time-default 'empty)
  906.      "")
  907.     ((or (eq parse-time-default 'current-time)
  908.          (eq parse-time-default 'now))
  909.      (current-time-string))
  910.     (t
  911.      (error "Unrecognized value `%s' for variable parse-time-default."
  912.         parse-time-default))))
  913.  
  914. ;; test routine for above
  915.  
  916. '(defun test-time-parser ()
  917.    (interactive)
  918.    (let ((times '("1am"
  919.           "1pm"
  920.           "1 pm"
  921.           "1 PM"
  922.           "1:01am"
  923.           "1:02pm"
  924.           "12:01:01am"
  925.           "12:01:01pm"
  926.           "12:34:45"
  927.           " 12:34:45"
  928.           " 12:34:45 "
  929.           "12:34:45 "
  930.           "May 12 14:34 1992"
  931.           "May 19 10:17:23pm 1992"
  932.           "May 19 10:17:23 pm 1992")))
  933.      (while times
  934.        (message "In = \"%s\" Out = \"%s\" (CR for next)"
  935.         (car times)
  936.         (parse-time-string (car times)))
  937.        (read-char)
  938.        (setq times (cdr times)))))
  939.  
  940.  
  941. (defun format-time-24 (time)
  942.   "Format TIME (a three element list) into a 24 hour time string in the
  943. format HH:MM:SS.  If an element of the list is nil, that component is
  944. not edited.  Typically, the seconds element is omitted or set to nil to
  945. produce a time format with only HH:MM.  See `format-time-24-hhmm'."
  946.   (let ((hh (time-hours time))
  947.     (mm (time-mins time))
  948.     (ss (time-secs time)))
  949.     (concat
  950.      (and hh (format "%d" hh))
  951.      (and hh mm ":")
  952.      (and mm (format "%02d" mm))
  953.      (and mm ss (format ":%02d" ss))
  954.      ;; no am/pm string
  955.      )))
  956.  
  957.  
  958. (defun format-time-12 (time)
  959.   "Format TIME (a 3 element list) into a 12 hour time string in the
  960. format HH:MM:SS PM.  If an element of the list is nil, that component is
  961. not edited.  Typically, the seconds element is omitted or set to nil to
  962. produce a time format with only HH:MM.  See `format-time-12-hhmm'."
  963.   (let ((hh (time-hours time))
  964.     (mm (time-mins time))
  965.     (ss (time-secs time)))
  966.     (concat
  967.      (and hh (format "%d" (cond ((zerop hh) 12)
  968.                 ((< hh 13) hh)
  969.                 (t (- hh 12)))))
  970.      (and hh mm ":")
  971.      (and mm (format "%02d" mm))
  972.      (and mm ss (format ":%02d" ss))
  973.      (and hh (if (>= hh 12) "pm" "am")))))
  974.  
  975. (fset 'format-time-hhmm 'format-time-12-hhmm)
  976.  
  977. (defun format-time-12-hhmm (time)
  978.   "Format time in HH:MM PM format."
  979.   (format-time-12 (make-time (time-hours time) (time-mins time) nil)))
  980.  
  981. (defun format-time-24-hhmm (time)
  982.   "Format 24-hour time without seconds"
  983.   (format-time-24 (make-time (time-hours time) (time-mins time) nil)))
  984.  
  985. ;;;
  986. ;;; EDB type specifications
  987. ;;;
  988.  
  989. (defun def-time-disptype (type)
  990.   "Construct a new time based on TYPE, which must exist as a function
  991. of the name \"format-time-TYPE\"."
  992.   (let* ((func (intern (concat "format-time-" type)))
  993.      (typename (intern (concat "time-" type)))
  994.      (ds (copy-displayspec (displaytype->displayspec 'time))))
  995.     (displayspec-set-actual->display ds func)
  996.     (define-displaytype-from-displayspec typename ds)))
  997.  
  998. (let ((ds (make-displayspec)))
  999.   (displayspec-set-indent ds nil)
  1000.   (displayspec-set-actual->display ds (function format-time-12))
  1001.   (displayspec-set-display->actual ds (function parse-time-string))
  1002.   (define-displaytype-from-displayspec 'time ds))
  1003.  
  1004. (def-time-disptype "12")        ;am/pm time
  1005. (def-time-disptype "24")        ;military time
  1006. (def-time-disptype "hhmm")        ;synonym for time-12-hhmm
  1007. (def-time-disptype "12-hhmm")        ;am/pm w/o secs
  1008. (def-time-disptype "24-hhmm")        ;military w/o secs
  1009.  
  1010. (let ((rs (make-recordfieldspec)))
  1011.   (recordfieldspec-set-type rs 'time)
  1012.   (recordfieldspec-set-default-value rs (make-empty-time))
  1013.   (recordfieldspec-set-constraint-function rs (function time-default-constraint))
  1014.   (recordfieldspec-set-actual->stored rs (function time->storage-string))
  1015.   (recordfieldspec-set-stored->actual rs (function storage-string->time))
  1016.   (recordfieldspec-set-merge-function rs (function time-merge))
  1017.   (recordfieldspec-set-order-fn rs (function time-order))
  1018.   (recordfieldspec-set-match-function rs (function time-match-function))
  1019.   (recordfieldspec-set-help-info rs "A time.")
  1020.   (define-recordfieldtype-from-recordfieldspec 'time rs))
  1021.  
  1022. (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec 'time))))
  1023.   (recordfieldspec-set-help-info rs "A 12-hour time, with AM/PM.")
  1024.   (define-recordfieldtype-from-recordfieldspec 'time-12 rs))
  1025.  
  1026. (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec 'time))))
  1027.   (recordfieldspec-set-help-info rs "A 24-hour time (a.k.a. military time).")
  1028.   (define-recordfieldtype-from-recordfieldspec 'time-24 rs))
  1029.  
  1030. (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec 'time))))
  1031.   (recordfieldspec-set-stored->actual rs (function parse-time-string))
  1032.   (define-recordfieldtype-from-recordfieldspec 'time-arb-storage rs))
  1033.  
  1034. ;; time-order
  1035.  
  1036. (defun time-order (time1 time2)
  1037.   (let ((result 0) (n 0))
  1038.     (while (and (<= n 2) (zerop result))
  1039.       (setq result
  1040.             (number-or-nil-order-nil-greatest
  1041.              (nth n time1) (nth n time2))))
  1042.     result))
  1043.  
  1044. ;; time-match-function
  1045.  
  1046. (defun time-match-function (patterntime targettime)
  1047.   (and (or (not (time-hours patterntime))
  1048.            (and (time-hours targettime)
  1049.             (= (time-hours patterntime) (time-hours targettime))))
  1050.        (or (not (time-mins patterntime))
  1051.            (and (time-mins targettime)
  1052.             (= (time-mins patterntime) (time-mins targettime))))
  1053.        (or (not (time-secs patterntime))
  1054.            (and (time-secs targettime)
  1055.             (= (time-secs patterntime) (time-secs targettime))))))
  1056.  
  1057. ;; time->storage-string
  1058.  
  1059. (defun time->storage-string (time)
  1060.   (format "%02d:%02d:%02d"
  1061.           (or (time-hours time) 0)
  1062.           (or (time-mins time) 0)
  1063.           (or (time-secs time) 0)))
  1064.  
  1065. ;; storage-string->time
  1066.  
  1067. (defun storage-string->time (str)
  1068.   (make-time (string->integer (substring str 0 2))
  1069.              (string->integer (substring str 3 5))
  1070.              (string->integer (substring str 6 8))))
  1071.  
  1072. ;; time-merge
  1073. ;; If an item in one time is nil, take the other time's value.
  1074.  
  1075. (defun time-merge (time1 time2)
  1076.   (let ((hh (or (time-hours time1) (time-hours time2)))
  1077.     (mm (or (time-mins time1) (time-mins time2)))
  1078.     (ss (or (time-secs time1) (time-secs time2))))
  1079.     (make-time hh mm ss)))
  1080.  
  1081. ;;; db-time.el ends here
  1082.