1;;;; time printing routines built upon the Common Lisp FORMAT function 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!IMPL") 13 14(defparameter *abbrev-weekday-table* 15 #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) 16 17(defparameter *long-weekday-table* 18 #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) 19 20(defparameter *abbrev-month-table* 21 #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) 22 23(defparameter *long-month-table* 24 #("January" "February" "March" "April" "May" "June" "July" "August" 25 "September" "October" "November" "December")) 26 27;;; The timezone table is incomplete but workable. 28(defparameter *timezone-table* 29 #("GMT" "" "" "" "" "EST" "CST" "MST" "PST")) 30 31(defparameter *daylight-table* 32 #(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT")) 33 34;;; VALID-DESTINATION-P ensures the destination stream is okay for the 35;;; FORMAT function. 36(defun valid-destination-p (destination) 37 (or (not destination) 38 (eq destination t) 39 (streamp destination) 40 (and (stringp destination) 41 (array-has-fill-pointer-p destination)))) 42 43;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on 44;;; the theory that since the 8/7/1999 style is hard to decode unambiguously, 45;;; you should have to ask for it explicitly. (I prefer YYYYMMDD myself, since 46;;; it sorts properly.:-) -- WHN 19990831 47;;; 48;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested 49;;; OTOH it probably wouldn't be a major problem to change compile-file to 50;;; use for example :long, so that the output would be Month DD, YYYY, or 51;;; even better to extend format-universal-time with a flag to output ISO 52;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate 53;;; slowly towards ISO dates in the user code... 54;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe 55;;; someone will do them for CMU CL and we can steal them for SBCL. 56(defun format-universal-time (destination universal-time 57 &key 58 (timezone nil) 59 (style :long) 60 (date-first t) 61 (print-seconds t) 62 (print-meridian t) 63 (print-timezone t) 64 (print-weekday t)) 65 #!+sb-doc 66 "Format-Universal-Time formats a string containing the time and date 67 given by universal-time in a common manner. The destination is any 68 destination which can be accepted by the Format function. The 69 timezone keyword is an integer specifying hours west of Greenwich. 70 The style keyword can be :SHORT (numeric date), :LONG (months and 71 weekdays expressed as words), :ABBREVIATED (like :LONG but words are 72 abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\") 73 The &KEY argument :DATE-FIRST, if NIL, will print the time first instead 74 of the date (the default). The PRINT- keywords, if NIL, inhibit 75 the printing of the obvious part of the time/date." 76 (unless (valid-destination-p destination) 77 (error "~A: Not a valid format destination." destination)) 78 (unless (integerp universal-time) 79 (error "~A: Universal-Time should be an integer." universal-time)) 80 (when timezone 81 (unless (and (rationalp timezone) (<= -24 timezone 24)) 82 (error "~A: Timezone should be a rational between -24 and 24." timezone)) 83 (unless (zerop (rem timezone 1/3600)) 84 (error "~A: Timezone is not a second (1/3600) multiple." timezone))) 85 86 (multiple-value-bind (secs mins hours day month year dow dst tz) 87 (if timezone 88 (decode-universal-time universal-time timezone) 89 (decode-universal-time universal-time)) 90 (declare (fixnum secs mins hours day month year dow)) 91 (let ((time-string "~2,'0D:~2,'0D") 92 (date-string 93 (case style 94 (:short "~D/~D/~D") ;; MM/DD/Y 95 ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y 96 (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y 97 (t 98 (error "~A: Unrecognized :style keyword value." style)))) 99 (time-args 100 (list mins (max (mod hours 12) (1+ (mod (1- hours) 12))))) 101 (date-args (case style 102 (:short 103 (list month day year)) 104 (:abbreviated 105 (list (svref *abbrev-month-table* (1- month)) day year)) 106 (:long 107 (list (svref *long-month-table* (1- month)) day year)) 108 (:government 109 (list day (svref *abbrev-month-table* (1- month)) 110 year))))) 111 (declare (simple-string time-string date-string)) 112 (when print-weekday 113 (push (case style 114 ((:short :long) (svref *long-weekday-table* dow)) 115 (:abbreviated (svref *abbrev-weekday-table* dow)) 116 (:government (svref *abbrev-weekday-table* dow))) 117 date-args) 118 (setq date-string 119 (concatenate 'simple-string "~A, " date-string))) 120 (when (or print-seconds (eq style :government)) 121 (push secs time-args) 122 (setq time-string 123 (concatenate 'simple-string time-string ":~2,'0D"))) 124 (when print-meridian 125 (push (signum (floor hours 12)) time-args) 126 (setq time-string 127 (concatenate 'simple-string time-string " ~[AM~;PM~]"))) 128 (apply #'format destination 129 (if date-first 130 (concatenate 'simple-string date-string " " time-string 131 (if print-timezone " ~A")) 132 (concatenate 'simple-string time-string " " date-string 133 (if print-timezone " ~A"))) 134 (if date-first 135 (nconc date-args (nreverse time-args) 136 (if print-timezone 137 (list (timezone-name dst tz)))) 138 (nconc (nreverse time-args) date-args 139 (if print-timezone 140 (list (timezone-name dst tz))))))))) 141 142(defun timezone-name (dst tz) 143 (if (and (integerp tz) 144 (or (and dst (= tz 0)) 145 (<= 5 tz 8))) 146 (svref (if dst *daylight-table* *timezone-table*) tz) 147 (multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60) 148 (multiple-value-bind (hours minutes) (truncate rest 60) 149 (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]" 150 (if (minusp tz) #\- #\+) 151 (abs hours) 152 (not (and (zerop minutes) (zerop seconds))) 153 (abs minutes) 154 (not (zerop seconds)) 155 (abs seconds)))))) 156 157(defun format-decoded-time (destination seconds minutes hours 158 day month year 159 &key (timezone nil) 160 (style :short) 161 (date-first t) 162 (print-seconds t) 163 (print-meridian t) 164 (print-timezone t) 165 (print-weekday t)) 166 #!+sb-doc 167 "FORMAT-DECODED-TIME formats a string containing decoded time 168 expressed in a humanly-readable manner. The destination is any 169 destination which can be accepted by the FORMAT function. The 170 timezone keyword is an integer specifying hours west of Greenwich. 171 The style keyword can be :SHORT (numeric date), :LONG (months and 172 weekdays expressed as words), or :ABBREVIATED (like :LONG but words are 173 abbreviated). The keyword DATE-FIRST, if NIL, will cause the time 174 to be printed first instead of the date (the default). The PRINT- 175 keywords, if nil, inhibit the printing of certain semi-obvious 176 parts of the string." 177 (unless (valid-destination-p destination) 178 (error "~A: Not a valid format destination." destination)) 179 (unless (and (integerp seconds) (<= 0 seconds 59)) 180 (error "~A: Seconds should be an integer between 0 and 59." seconds)) 181 (unless (and (integerp minutes) (<= 0 minutes 59)) 182 (error "~A: Minutes should be an integer between 0 and 59." minutes)) 183 (unless (and (integerp hours) (<= 0 hours 23)) 184 (error "~A: Hours should be an integer between 0 and 23." hours)) 185 (unless (and (integerp day) (<= 1 day 31)) 186 (error "~A: Day should be an integer between 1 and 31." day)) 187 (unless (and (integerp month) (<= 1 month 12)) 188 (error "~A: Month should be an integer between 1 and 12." month)) 189 (unless (and (integerp year) (plusp year)) 190 (error "~A: Hours should be an non-negative integer." year)) 191 (when timezone 192 (unless (and (integerp timezone) (<= 0 timezone 32)) 193 (error "~A: Timezone should be an integer between 0 and 32." 194 timezone))) 195 (format-universal-time destination 196 (encode-universal-time seconds minutes hours day month year) 197 :timezone timezone :style style :date-first date-first 198 :print-seconds print-seconds :print-meridian print-meridian 199 :print-timezone print-timezone :print-weekday print-weekday)) 200