(require (quote db-util)) (defun make-date (year month day) "\ Make an EDB date object with arguments YEAR MONTH DAY." (byte-code " BB‡" [year month day] 3)) (defun date-year (date) (byte-code "@‡" [date] 1)) (defun date-month (date) (byte-code "A@‡" [date] 1)) (defun date-day (date) (byte-code "AA‡" [date] 1)) (proclaim-inline date-year date-month date-day) (defun make-empty-date nil "\ Return a date object containing no information." (byte-code "ÁÀÀÀ#‡" [nil make-date] 4)) (defun zero-or-empty-date-p (date) "\ Return t if all the date's slots contain nil or 0, nil otherwise." (byte-code "Ä !?† Å!)…-Æ ! ?†Å !)…-Ç ! ?†,Å !)‡" [year date month day date-year zerop date-month date-day] 7)) (defun date-year-short (date) "\ Extract the year and return it modulo 1900." (byte-code "ÁÂ!Ã\"‡" [date % date-year 1900] 4)) (defun date-year-long (date) "\ Extract the year as a four digit value." (byte-code "à !ÄWƒÅ\\‚ÆWƒÇ\\‚)‡" [yy date t date-year 50 2000 99 1900] 3)) (proclaim-inline make-date make-empty-date date-year-short) (defun leap-year-p (year) "\ Return t if YEAR is a Gregorian leap year." (byte-code "ÁÂ\"ÃU…ÄÁÅ\"Ã\"†ÁÆ\"ÃU‡" [year % 4 0 /= 100 400] 6)) (defun date->day-of-year (date) "\ Return the day number within the year for Gregorian DATE." (byte-code "Å !Æ !Ç ! ÈÉS\"\\ÊV…2 ËÌÈÍ\"\\Î\"Z‰ˆÏ !…2 T‰ˆ ,‡" [month date day year day-of-year date-month date-day date-year * 31 2 / 23 4 10 leap-year-p] 10)) (defun date->absolute-days (date) "\ Return the number of days elapsed between the Gregorian 12/31/1 BC and DATE. The Gregorian date Sunday, December 31, 1 BC is imaginary." (byte-code "Ä !Å !Æ !SÇÈ !ÉÊ \"Ë Ì\"Ë Í\"[Ë Î\"%+‡" [mm date dd yy date-month date-day date-year-long + date->day-of-year * 365 / 4 100 400] 15)) (defconst weekday-array (quote ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) "\ An array of weekday names.") (defconst weekday-alist (quote (("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3) ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6) ("Tues" . 2) ("Thurs" . 4) ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))) (defun integer->weekday (dayx) "\ Convert INDEX into its corresponding weekday name." (byte-code " Ã\"H‡" [weekday-array dayx % 7] 4)) (defun integer->weekday-abbrev (dayx) "\ Convert INDEX into its corresponding three-letter abbreviated weekday name." (byte-code "Á!ÂÃO‡" [dayx integer->weekday 0 3] 4)) (defun date->weekday-index (date) "\ Return the weekday index for DATE." (byte-code "ÁÂ!Ã\"‡" [date % date->absolute-days 7] 4)) (defun date->weekday-name (date) "\ Return the weekday name for the DATE." (byte-code "ÁÂ!!‡" [date integer->weekday date->weekday-index] 3)) (defun date->weekday-abbrev (date) "\ Return the abbreviated weekday name for the DATE" (byte-code "Á!ÂÃO‡" [date date->weekday-name 0 3] 4)) (proclaim-inline integer->weekday integer->weekday-abbrev date->weekday-index date->weekday-name date->weekday-abbrev) (defconst monthlength-array [0 31 28 31 30 31 30 31 31 30 31 30 31]) (defun date-month-day-compatible (date) (byte-code "Ã!ƒÄ!ƒÃ! Ä!HX‚ÅÆ!‚‡" [date monthlength-array t date-day date-month error "Date has a day but no month"] 7)) (defconst full-monthname-alist (quote (("January" . 1) ("February" . 2) ("March" . 3) ("April" . 4) ("May" . 5) ("June" . 6) ("July" . 7) ("August" . 8) ("September" . 9) ("October" . 10) ("November" . 11) ("December" . 12)))) (defconst monthabbrev-alist (quote (("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))) (defconst monthname-alist (append monthabbrev-alist full-monthname-alist (quote (("Sept" . 9))))) (defconst monthabbrev-array (vconcat (quote ("")) (mapcar (function car) monthabbrev-alist))) (defconst monthname-array (vconcat (quote ("")) (mapcar (function car) full-monthname-alist))) (defun monthname->integer (monthname) (byte-code "ÂÃ! \"A‡" [monthname monthname-alist assoc capitalize] 4)) (defun integer->monthname (monthno) (byte-code " H‡" [monthname-array monthno] 2)) (defun integer->monthabbrev (monthno) (byte-code " H‡" [monthabbrev-array monthno] 2)) (proclaim-inline monthname->integer integer->monthname integer->monthabbrev) (defun date-order-absolute (date1 date2) (byte-code "ÃÄ !Ä !\"Å!ƒÆ \"‚)‡" [result date1 date2 number-or-nil-order-nil-greatest date-year zerop date-order-within-year] 7)) (defun date-order-within-year (date1 date2) (byte-code "ÃÄ !Ä !\"Å!ƒÃÆ !Æ !\"‚)‡" [result date1 date2 number-or-nil-order-nil-greatest date-month zerop date-day] 9)) (defconst monthname-regexp (concat "\\(" (mapconcat (function car) monthname-alist "\\|") "\\)\\.?")) (defconst weekday-regexp (concat "\\(" (mapconcat (function car) weekday-alist "\\|") "\\)\\.?")) (defconst monthnumber-regexp "\\(0?[1-9]\\|1[0-2]\\)") (defconst monthnumber-regexp-two-char "\\(0[1-9]\\|1[0-2]\\)") (defconst monthday-regexp "\\(0?[1-9]\\|[12][0-9]\\|3[01]\\)") (defconst monthday-regexp-two-char "\\([0-2][0-9]\\|3[01]\\)") (defconst full-year-regexp "[0-2][0-9][0-9][0-9]") (defconst short-year-regexp "[0-9][0-9]") (defconst year-regexp (concat "\\(" full-year-regexp "\\|" short-year-regexp "\\)")) (defconst elt-separator-regexp "[ -.,/']+") (defconst date-regexps (list (cons (concat monthname-regexp elt-separator-regexp monthday-regexp "\\(" elt-separator-regexp year-regexp "\\)?") (quote (4 nil 1 2))) (cons (concat monthnumber-regexp elt-separator-regexp monthday-regexp "\\(" elt-separator-regexp year-regexp "\\)?") (quote (4 1 nil 2))) (cons (concat monthday-regexp elt-separator-regexp monthname-regexp "\\(" elt-separator-regexp year-regexp "\\)?") (quote (4 nil 2 1))) (cons (concat "\\(" monthday-regexp elt-separator-regexp "\\)?" monthname-regexp elt-separator-regexp year-regexp) (quote (4 nil 3 2))) (cons (concat monthday-regexp elt-separator-regexp monthnumber-regexp elt-separator-regexp "\\(" full-year-regexp "\\)") (quote (3 2 nil 1))) (cons (concat year-regexp elt-separator-regexp monthname-regexp elt-separator-regexp monthday-regexp) (quote (1 nil 2 3))) (cons (concat year-regexp elt-separator-regexp monthnumber-regexp elt-separator-regexp monthday-regexp) (quote (1 2 nil 3))) (cons (concat year-regexp monthnumber-regexp-two-char "?" monthday-regexp-two-char "?") (quote (1 2 nil 3))) (cons (concat weekday-regexp elt-separator-regexp monthname-regexp elt-separator-regexp monthday-regexp "\\(" elt-separator-regexp year-regexp "\\)?") (quote (5 nil 2 3))) (cons (concat weekday-regexp elt-separator-regexp monthday-regexp elt-separator-regexp monthname-regexp "\\(" elt-separator-regexp year-regexp "\\)?") (quote (5 nil 3 2))) (cons (concat weekday-regexp " " monthname-regexp " ?" monthday-regexp " [0-9:]+ " "\\(" full-year-regexp "\\)") (quote (4 nil 2 3)))) "\ Assoc list of regexps and match locators. A match locator is a list of four numbers indicating which submatch of the regexp contains the year, month number, month name, and day of the month. The list elements may be nil if that information is not available.") (defun parse-date-string (date-string) "\ Parse DATE-STRING, and return a date object; err if the parse is invalid. If DATE-STRING contains only whitespace, return a null date object. If DATE-STRING is nil, use the result of `parse-date-default-function' instead." (byte-code " ÄÄĈ ?ƒÆ ‰‚Ç !‰ˆÈ G!ƒ&É ‚š…lÊË@@ÌQ \"ƒdÍÎ@A\"ÏÐ @!Ð A@!†W AA@…WÑ AA@!ÐÒ 8!#ĉ‚hA‰ˆ‚&ˆÄˆ ƒ–Ó !ƒˆÔ !ƒ„É ‚… ‚“ÕÖ×Ø !!Ù !#‚šÕÚ \"+‡" [regexp-alist date-regexps result match-list nil date-string parse-date-default-function db-string-trim-whitespace zerop make-empty-date string-match "^" "$" mapcar (lambda (match-no) (byte-code "… \"‡" [match-no date-string db-match-string-maybe] 3)) make-date string-or-nil->number-or-nil monthname->integer 3 date-month-day-compatible zero-or-empty-date-p error "There is no such day as %s %d!" integer->monthname date-month date-day "`%s' is not a valid date."] 21)) (defun parse-date-string-or-nil (date-string) "\ Like `parse-date-string', but returns null date in case of nil arg." (byte-code "ƒ Á!‚  ‡" [date-string parse-date-string make-empty-date] 3)) (defvar parse-date-default (quote empty) "\ One of the symbols 'empty or 'current-date, specifying what date string `parse-date-default-function' should return, and `parse-date-string' should use when passed a nil argument.") (defun parse-date-default-function nil "\ Return a default value for `parse-date-string' to use if its input is nil." (byte-code "Â=ƒ Â+Ä=†Å=†Æ=†Ç=ƒ'Ç ‚+ÈÉ\"‡" [parse-date-default t empty "" today current-date current-time current-time-string error "Unrecodgnized value `%s' for variable parse-date-default."] 4)) (defconst format-date-sub-syms-alist (quote (("day" (date-day date) date->weekday-abbrev date) ("dd" (date-day date) format "%02d" (date-day date)) ("d" (date-day date) date-day date) ("month" (date-month date) integer->monthname (date-month date)) ("mon" (date-month date) integer->monthabbrev (date-month date)) ("mm" (date-month date) format "%02d" (date-month date)) ("m" (date-month date) date-month date) ("year" (date-year date) date-year-long date) ("yy" (date-year date) format "%02d" (date-year-short date)) ("jday" (and (date-day date) (date-month date) (date-year date)) date->day-of-year date) ("wday" (and (date-day date) (date-month date) (date-year date)) date->weekday-index date) ("weekday" (and (date-day date) (date-month date) (date-year date)) date->weekday-name date))) "\ An alist of (NAME . (TEST . SEXP)) used by `format-date'. Each NAME is a string, which, when prefixed by \"%\", will be substituted by the value resulting from evalling the associated SEXP but only if TEST evals to non-null.") (defconst format-date-sub-syms-regexp (concat "%\\(" (mapconcat (function car) format-date-sub-syms-alist "\\|") "\\)") "\ A regexp pattern to parse format strings for symbol substition strings; this variable is computed from the variable `format-date-sub-syms-alist'.") (defun format-date (format-string &optional date) "\ Using FORMAT-STRING, format the DATE, which defaults to the current date if nil. FORMAT-STRING can contain the following symbol strings, which are substituted by their corresponding value from the date; other characters are inserted as is. String Action ====== ====== %d day of month -- 1 to 31 (one or two digits) %dd day of month -- 01 to 31 (always two digits) %m month of year - 1 to 12 (one or two digits) %mm month of year - 01 to 12 (always two digits) %mon month name (abbreviated) - Jun %month full month name - June %yy last 2 digits of year - 00 to 99 %year year as 4 digits -- 0000 to 9999? %jday Julian day of year -- 1 to 366 %wday day of week -- 0 to 6 (Sunday = 0) %day day of week name -- \"Sun\" to \"Sat\" %weekday full day of week name -- \"Sunday\" to \"Saturday\" See the variables `format-date-sub-syms-alist' and `format-date-sub-syms-regexp'. A special case: if an element of DATE is nil, its field is omitted. A DATE object of all nils is thus formatted as the empty string." (byte-code "?… ÉÁ!‰ˆÊËÁÁÌ #‰…aÍÎÏ\"\"‰?ƒ9ÐÑÎÏ\"\"‚WÒ A@!…W Ó Ë\"?…O OÒ AA!Q‰ˆÔÊ!‰ˆ‚ˆ  ÁOP,‡" [date nil ofs buf sym-alist x format-date-sub-syms-regexp format-string format-date-sub-syms-alist parse-date-string 0 "" string-match assoc db-match-string 1 error "format-date: Symbol %s is not in format-date-sub-syms-alist!" eval string= match-end] 14)) (defconst simple-format-date-default "%month %d, %year" "\ *A default format used by simple-format-date.") (defun simple-format-date (date) "\ Format the DATE using a default format, defined by the variable `simple-format-date-default'. If DATE is nil, use the value of `parse-date-default-function'." (byte-code " \"‡" [simple-format-date-default date format-date] 3)) (defun simple-format-date-or-nil (date) "\ Format the DATE using a default format, defined by the variable `simple-format-date-default'. If DATE is nil, return the empty string." (byte-code "ƒ  \"‚ Ç" [date simple-format-date-default format-date ""] 3)) (defconst format-date-mmddyy-separator "/" "\ *A string used to separate the components of the MMDDYY date format.") (defun format-date-mmddyy (date) "\ Format the DATE into a MM/DD/YY format. The \"/\" separator is a user- configuration variable in format-date-mmddyy-separator. If DATE is nil, return the empty string." (byte-code "ƒ ÃÄÅ #\")‚Ƈ" [date sep format-date-mmddyy-separator format-date format "%%mm%s%%dd%s%%yy" ""] 5)) (defconst format-date-ddmmyy-separator "." "\ *A string used to separate the components of the DDMMYY date format.") (defun format-date-ddmmyy (date) "\ Format the DATE into a DD.MM.YY format. The \".\" separator is configured by the variable format-date-ddmmyy-separator. If DATE is nil, return the empty string." (byte-code "ƒ † ÃÄÅÆ #\")‚Ç" [date sep format-date-ddmmyy-separator "" format-date format "%%d%s%%m%s%%yy"] 5)) (defconst format-date-yymmdd-separator "" "\ *A string used to separate the componenets of the YYMMDD date format.") (defun format-date-yymmdd (date) "\ Format the DATE into a YYMMDD format. The components are separated by the value of `format-date-yymmdd-separator', which is initially the null string. If DATE is nil, return the empty string." (byte-code "ƒ † ÃÄÅÆ #\")‚Ç" [date sep format-date-yymmdd-separator "" format-date format "%%yy%s%%mm%s%%dd"] 5)) (defconst format-date-ddmmmyy-separator " " "\ *A string used to separate the components of the DD MMM YY date format.") (defun format-date-ddmmmyy (date) "\ Format the DATE into a DD MMM YY format. The components are separated by the value of format-date-ddmmmyy-separator, which is initially a single space. If DATE is nil, return the empty string." (byte-code "ƒ ÃÄÅ #\")‚Ƈ" [date sep format-date-ddmmmyy-separator format-date format "%%d%s%%mon%s%%yy" ""] 5)) (defconst format-date-yyyymmdd-separator "/" "\ *A string used to separate the components of the YYYY/MM/DD date format.") (defun format-date-yyyymmdd (date) "\ Format the DATE into a YYYY/MM/DD format. The components are separated by the value of `format-date-yyyymmdd-separator', which is initially a ``/''. If DATE is nil, return the empty string." (byte-code "ƒ ÃÄÅ #\")‚Ƈ" [date sep format-date-yyyymmdd-separator format-date format "%%year%s%%m%s%%d" ""] 5)) (defun format-date-full (date) "\ Format the DATE into the full format: MMMM DD, YYYY. If DATE is nil, return the empty string." (byte-code "ƒ ÁÂ\"‚ Ç" [date format-date "%month %d, %year" ""] 3)) (defun format-date-unix (date) "\ Format the DATE into the standard Unix format: DAY MMM DD YYYY. If DATE is nil, return the empty string." (byte-code "ƒ ÁÂ\"‚ Ç" [date format-date "%day %mon %d %year" ""] 3)) (defun format-date-all (date) "\ Format the DATE using all components, without abbreviations, in the format DAYNAME, MMMM DD, YYYY. If DATE is nil, return the empty string." (byte-code "ƒ ÁÂ\"‚ Ç" [date format-date "%weekday, %month %d, %year" ""] 3)) (defun format-date-dec (date) "\ Format the DATE into the standard DEC format: dd-mmm-yy. If DATE is nil, return the empty string." (byte-code "Âà !)‡" [format-date-ddmmmyy-separator date "-" format-date-ddmmmyy] 2)) (defun format-date-europe (date) "\ Format the DATE into the European standard, which is DD.MM.YY. If DATE is nil, return the empty string." (byte-code "Âà !)‡" [format-date-ddmmyy-separator date "." format-date-ddmmyy] 2)) (defun test-date-formats nil (interactive) (byte-code "ˆÃÂ…)@A‰ˆÄÅ ÆÇÈÉ !P!ÊË !\"#ˆrˆ‚*‡" [formats form nil (mmddyy ddmmyy yymmdd ddmmmyy yyyymmdd full unix all dec europe) message "Format %s = \"%s\"" funcall intern "format-date-" symbol-name parse-date-string current-time-string] 11)) (let ((ds (make-displayspec))) (displayspec-set-indent ds nil) (displayspec-set-actual->display ds (function simple-format-date)) (displayspec-set-display->actual ds (function parse-date-string)) (define-displaytype-from-displayspec (quote date) ds)) (let ((rs (make-recordfieldspec))) (recordfieldspec-set-type rs (quote date)) (recordfieldspec-set-default-value rs (make-empty-date)) (recordfieldspec-set-actual->stored rs (function date->storage-string)) (recordfieldspec-set-stored->actual rs (function storage-string->date)) (recordfieldspec-set-merge-function rs (function date-merge)) (recordfieldspec-set-order-fn rs (function date-order-absolute)) (recordfieldspec-set-match-function rs (function date-match-function)) (recordfieldspec-set-help-info rs "A date.") (define-recordfieldtype-from-recordfieldspec (quote date) rs)) (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec (quote date))))) (recordfieldspec-set-stored->actual rs (function storage-string->date)) (define-recordfieldtype-from-recordfieldspec (quote date-efficient-storage) rs)) (let ((ds (copy-displayspec (displaytype->displayspec (quote date))))) (displayspec-set-actual->display ds (function simple-format-date-or-nil)) (displayspec-set-display->actual ds (function parse-date-string-or-nil)) (define-displaytype-from-displayspec (quote date-or-nil) ds)) (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec (quote date))))) (recordfieldspec-set-type rs (quote date-or-nil)) (recordfieldspec-set-default-value rs nil) (recordfieldspec-set-stored->actual rs (function parse-date-string-or-nil)) (recordfieldspec-set-help-info rs "(Optional) date.") (define-recordfieldtype-from-recordfieldspec (quote date-or-nil) rs)) (defun def-date-disptype (type) "\ Construct a new date displaytype based on TYPE (a string). A function named `format-date-TYPE' must exist." (byte-code "ÄÅ P!ÄÆ P!ÇÈÉ!! ÊIˆË \"+‡" [func type typename ds intern "format-date-" "date-" copy-sequence displaytype->displayspec date 11 define-displaytype-from-displayspec] 7)) (def-date-disptype "mmddyy") (def-date-disptype "yymmdd") (def-date-disptype "ddmmyy") (def-date-disptype "ddmmmyy") (def-date-disptype "yyyymmdd") (def-date-disptype "europe") (def-date-disptype "full") (def-date-disptype "all") (def-date-disptype "unix") (def-date-disptype "dec") (defun date-match-function (patterndate targetdate) (byte-code "Â!?† !…Â! !U…BÃ!?†+à !…+Ã!à !U…BÄ!?†BÄ !…BÄ!Ä !U‡" [patterndate targetdate date-year date-month date-day] 14)) (defun date-merge (date1 date2) (byte-code "Å !† Å !Æ !†Æ !Ç !†Ç !È  #+‡" [mm date1 date2 dd yy date-month date-day date-year make-date] 10)) (fset (quote date->storage-string) (quote format-date-full)) (fset (quote storage-string->date) (quote date-stored->actual)) (defun date->storage-string-mmddyyyy (date) (byte-code "Á!ƒ!ÂÃÄ!†ÅÆ!†ÅÁ!†Å$‚CÄ!†*Æ!?ƒ2Ç‚CÂÈÄ!†;ÅÆ!†BÅ#‡" [date date-year format "%02d/%02d/%02d" date-month 0 date-day "" "%02d/%02d"] 13)) (defun storage-string-mmddyyyy->date (str) (byte-code "Ä ÅÆO!Ä ÇÈO! GÈV…Ä ÉÊO!ËÌ!?…%Ì !?…- …5Ì !?…9 #+‡" [month str day year string->integer 0 2 3 5 6 nil make-date zerop] 10)) (defun date->storage-string-lisp (date) (byte-code "ÁÂ\"‡" [date format "%s"] 3)) (defun storage-string-lisp->date (str) (byte-code "Á!@‡" [str read-from-string] 2)) (defun date-stored->actual (date-stored) (byte-code ";ƒ Á!‚ ‡" [date-stored parse-date-string] 2)) (defun make-time (hours mins secs) "\ Arguments HOURS MINS SECS." (byte-code " E‡" [hours mins secs] 3)) (proclaim-inline make-time) (defun time-hours (time) (byte-code "@‡" [time] 1)) (defun time-mins (time) (byte-code "A@‡" [time] 1)) (defun time-secs (time) (byte-code "AA@‡" [time] 1)) (proclaim-inline time-hours time-mins time-secs) (defun make-empty-time nil "\ Return a time object containing no information." (byte-code "ÁÀÀÀ#‡" [nil make-time] 4)) (defun empty-time-p (time) "\ Return t if all the time's slots contain nil, nil otherwise." (byte-code "Á!?…Â!?…Ã!?‡" [time time-hours time-mins time-secs] 4)) (defun time-default-constraint (time record record-index database) "\ Enforce proper time values." (byte-code "Â!†Ã!ÄW…Å!ÆW…Ç!ÆWƒ\"Á‚%ÈÉ!‡" [time t empty-time-p time-hours 23 time-mins 59 time-secs error "Invalid time value."] 6)) (defconst parse-time-regexp-array ["\\([0-9]?[0-9]\\)\\(:\\| ?[ap]m\\)" "\\([0-5][0-9]\\)\\(:\\| ?[ap]m\\|\\Sw\\|$\\)" "\\([0-5][0-9]\\)\\( *[ap]m\\|\\Sw\\|$\\)"] "\ An array of regexps used by parse-time-string, indexed by the current parse state to obtain the appropriate regexp.") (defun parse-time-string (time-string) "\ Parse the first occurrence of hh:mm:ss in TIME-STRING; return a time object. If \":ss\" is omitted in TIME-STRING, the seconds default to zero. If TIME-STRING contains only whitespace, return an empty time object. If TIME-STRING is nil, use the result of `parse-time-default-function' instead." (byte-code "?ƒ Ì ‰‚Í!‰ˆÎG!ƒÏ ‚­ÃÐÐÐÑÒÐÐ   ÓW…N GW…NÔ  H  #…} HÕÖ× \"!LˆØÙÚÛ \"\"ƒn T‚oÓ‰ ˆÜÐ!‰ ˆ‚5ˆÝÚÛ \"‰…ŽÔÞ\"ƒ¦ß à\"Ôá\"ƒ¡à‚¢Ð\\‚§ #. ‡" [time-string str case-fold-search t hh mm ss pm vars ofs state parse-time-regexp-array parse-time-default-function db-string-trim-whitespace zerop make-empty-time 0 nil [hh mm ss] 3 string-match string-to-int db-match-string 1 equal ":" db-match-string-maybe 2 match-end make-time "[ap]m" % 12 "pm"] 18)) (defvar parse-time-default (quote empty) "\ One of the symbols 'empty or 'current-time, specifying what time string `parse-time-default-function' should return, and `parse-time-string' should use when passed a nil argument.") (defun parse-time-default-function nil "\ Return a default value for `parse-time-string' to use if its input is nil." (byte-code "Â=ƒ ÂÄ=†Å=ƒÆ ‚ÇÈ\"‡" [parse-time-default t empty "" current-time now current-time-string error "Unrecognized value `%s' for variable parse-time-default."] 4)) (quote (defun test-time-parser nil (interactive) (let ((times (quote ("1am" "1pm" "1 pm" "1 PM" "1:01am" "1:02pm" "12:01:01am" "12:01:01pm" "12:34:45" " 12:34:45" " 12:34:45 " "12:34:45 " "May 12 14:34 1992" "May 19 10:17:23pm 1992" "May 19 10:17:23 pm 1992")))) (while times (message "In = \"%s\" Out = \"%s\" (CR for next)" (car times) (parse-time-string (car times))) (read-char) (setq times (cdr times)))))) (defun format-time-24 (time) "\ Format TIME (a three element list) into a 24 hour time string in the format HH:MM:SS. If an element of the list is nil, that component is not edited. Typically, the seconds element is omitted or set to nil to produce a time format with only HH:MM. See `format-time-24-hhmm'." (byte-code "Ä !Å !Æ !…ÇÈ\"… …É …%ÇÊ \" …1 …1ÇË \"R+‡" [hh time mm ss time-hours time-mins time-secs format "%d" ":" "%02d" ":%02d"] 11)) (defun format-time-12 (time) "\ Format TIME (a 3 element list) into a 12 hour time string in the format HH:MM:SS PM. If an element of the list is nil, that component is not edited. Typically, the seconds element is omitted or set to nil to produce a time format with only HH:MM. See `format-time-12-hhmm'." (byte-code "Å !Æ !Ç !È…+ÉÊË!ƒÌ‚*ÍWƒ'‚*ÌZ\"…4 …4Î …<ÉÏ \" …H …HÉÐ \"…WÌYƒVÑ‚WÒ%+‡" [hh time mm ss t time-hours time-mins time-secs concat format "%d" zerop 12 13 ":" "%02d" ":%02d" "pm" "am"] 14)) (fset (quote format-time-hhmm) (quote format-time-12-hhmm)) (defun format-time-12-hhmm (time) "\ Format time in HH:MM PM format." (byte-code "ÂÃÄ!Å!Á#!‡" [time nil format-time-12 make-time time-hours time-mins] 7)) (defun format-time-24-hhmm (time) "\ Format 24-hour time without seconds" (byte-code "ÂÃÄ!Å!Á#!‡" [time nil format-time-24 make-time time-hours time-mins] 7)) (defun def-time-disptype (type) "\ Construct a new time based on TYPE, which must exist as a function of the name \"format-time-TYPE\"." (byte-code "ÄÅ P!ÄÆ P!ÇÈÉ!! ÊIˆË \"+‡" [func type typename ds intern "format-time-" "time-" copy-sequence displaytype->displayspec time 11 define-displaytype-from-displayspec] 7)) (let ((ds (make-displayspec))) (displayspec-set-indent ds nil) (displayspec-set-actual->display ds (function format-time-12)) (displayspec-set-display->actual ds (function parse-time-string)) (define-displaytype-from-displayspec (quote time) ds)) (def-time-disptype "12") (def-time-disptype "24") (def-time-disptype "hhmm") (def-time-disptype "12-hhmm") (def-time-disptype "24-hhmm") (let ((rs (make-recordfieldspec))) (recordfieldspec-set-type rs (quote time)) (recordfieldspec-set-default-value rs (make-empty-time)) (recordfieldspec-set-constraint-function rs (function time-default-constraint)) (recordfieldspec-set-actual->stored rs (function time->storage-string)) (recordfieldspec-set-stored->actual rs (function storage-string->time)) (recordfieldspec-set-merge-function rs (function time-merge)) (recordfieldspec-set-order-fn rs (function time-order)) (recordfieldspec-set-match-function rs (function time-match-function)) (recordfieldspec-set-help-info rs "A time.") (define-recordfieldtype-from-recordfieldspec (quote time) rs)) (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec (quote time))))) (recordfieldspec-set-help-info rs "A 12-hour time, with AM/PM.") (define-recordfieldtype-from-recordfieldspec (quote time-12) rs)) (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec (quote time))))) (recordfieldspec-set-help-info rs "A 24-hour time (a.k.a. military time).") (define-recordfieldtype-from-recordfieldspec (quote time-24) rs)) (let ((rs (copy-recordfieldspec (recordfieldtype->recordfieldspec (quote time))))) (recordfieldspec-set-stored->actual rs (function parse-time-string)) (define-recordfieldtype-from-recordfieldspec (quote time-arb-storage) rs)) (defun time-order (time1 time2) (byte-code "ÄÄ ÅX… Æ!…Ç 8 8\"‰ˆ‚ˆ*‡" [result n time1 time2 0 2 zerop number-or-nil-order-nil-greatest] 6)) (defun time-match-function (patterntime targettime) (byte-code "Â!?† !…Â! !U…BÃ!?†+à !…+Ã!à !U…BÄ!?†BÄ !…BÄ!Ä !U‡" [patterntime targettime time-hours time-mins time-secs] 14)) (defun time->storage-string (time) (byte-code "ÁÂÃ!† ÄÅ!†ÄÆ!†Ä$‡" [time format "%02d:%02d:%02d" time-hours 0 time-mins time-secs] 8)) (defun storage-string->time (str) (byte-code "ÁÂÃÄO!ÂÅÆO!ÂÇÈO!#‡" [str make-time string->integer 0 2 3 5 6 8] 9)) (defun time-merge (time1 time2) (byte-code "Å !† Å !Æ !†Æ !Ç !†Ç !È #+‡" [hh time1 time2 mm ss time-hours time-mins time-secs make-time] 10))