src/code/format-time.lisp

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