/[cmucl]/src/code/format-time.lisp
ViewVC logotype

Contents of /src/code/format-time.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.11: +14 -14 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
2
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/format-time.lisp,v 1.12 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11
12 ;;; Really slick time printing routines built upon the Common Lisp
13 ;;; format function.
14
15 ;;; Written by Jim Healy, September 1987.
16
17 ;;; **********************************************************************
18
19 (in-package :extensions)
20
21 (intl:textdomain "cmucl")
22
23 (export '(format-universal-time format-decoded-time))
24
25 (defconstant abbrev-weekday-table
26 '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
27
28 (defconstant long-weekday-table
29 '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
30 "Sunday"))
31
32 (defconstant abbrev-month-table
33 '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
34 "Dec"))
35
36 (defconstant long-month-table
37 '#("January" "February" "March" "April" "May" "June" "July" "August"
38 "September" "October" "November" "December"))
39
40 ;;; The timezone-table is incomplete but workable.
41
42 (defconstant timezone-table
43 '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
44
45 (defconstant daylight-table
46 '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT"))
47
48 ;;; Valid-Destination-P ensures the destination stream is okay
49 ;;; for the Format function.
50
51 (defun valid-destination-p (destination)
52 (or (not destination)
53 (eq destination 't)
54 (streamp destination)
55 (and (stringp destination)
56 (array-has-fill-pointer-p destination))))
57
58 ;;; Format-Universal-Time - External.
59
60 (defun format-universal-time (destination universal-time
61 &key (timezone nil)
62 (style :short)
63 (date-first t)
64 (print-seconds t)
65 (print-meridian t)
66 (print-timezone t)
67 (print-weekday t))
68 "Format-Universal-Time formats a string containing the time and date
69 given by universal-time in a common manner. The destination is any
70 destination which can be accepted by the Format function. The
71 timezone keyword is an integer specifying hours west of Greenwich.
72 The style keyword can be :short (numeric date), :long (months and
73 weekdays expressed as words), :abbreviated (like :long but words
74 are abbreviated), :rfc1123 (conforming to RFC 1123), :government
75 (of the form \"XX Mon XX XX:XX:XX\"), or :iso8601 (conforming to
76 ISO 8601), which is the recommended way of printing date and time.
77 The keyword date-first, if nil, will print the time first instead of
78 the date (the default). The print- keywords, if nil, inhibit the
79 printing of the obvious part of the time/date."
80 (unless (valid-destination-p destination)
81 (error (intl:gettext "~A: Not a valid format destination.") destination))
82 (unless (integerp universal-time)
83 (error (intl:gettext "~A: Universal-Time should be an integer.") universal-time))
84 (when timezone
85 (unless (and (rationalp timezone) (<= -24 timezone 24))
86 (error (intl:gettext "~A: Timezone should be a rational between -24 and 24.") timezone))
87 (unless (zerop (rem timezone 1/3600))
88 (error (intl:gettext "~A: Timezone is not a second (1/3600) multiple.") timezone)))
89
90 (multiple-value-bind (secs mins hours day month year dow dst tz)
91 (if timezone
92 (decode-universal-time universal-time timezone)
93 (decode-universal-time universal-time))
94 (declare (fixnum secs mins hours day month year dow))
95 (let ((time-string "~2,'0D:~2,'0D")
96 (date-string
97 (case style
98 (:short "~D/~D/~2,'0D") ;; MM/DD/YY
99 ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, YYYY
100 (:rfc1123 "~2,'0D ~A ~4,'0D") ;; DD Mon YYYY
101 (:government "~2,'0D ~:@(~A~) ~2,'0D") ;; DD MON YY
102 (:iso8601 "~4,'0D-~2,'0D-~2,'0D") ;; YYYY-MM-DD
103 (t
104 (error (intl:gettext "~A: Unrecognized :style keyword value.") style))))
105 (time-args
106 (case style
107 ((:rfc1123 :iso8601) (list mins hours))
108 (t (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))))
109 (date-args (case style
110 (:short
111 (list month day (mod year 100)))
112 (:abbreviated
113 (list (svref abbrev-month-table (1- month)) day year))
114 (:long
115 (list (svref long-month-table (1- month)) day year))
116 (:rfc1123
117 (list day (svref abbrev-month-table (1- month)) year))
118 (:government
119 (list day (svref abbrev-month-table (1- month))
120 (mod year 100)))
121 (:iso8601
122 (list year month day))))
123 (timezone-name (case style
124 (:rfc1123 (timezone-rfc1123-name dst tz))
125 (:iso8601 (timezone-iso8601-name dst tz))
126 (t (timezone-name dst tz)))))
127 (declare (simple-string time-string date-string timezone-name))
128 (when print-weekday
129 (push (case style
130 ((:short :long) (svref long-weekday-table dow))
131 ((:abbreviated :rfc1123 :government :iso8601)
132 (svref abbrev-weekday-table dow)))
133 date-args)
134 (setq date-string
135 (concatenate 'simple-string "~A, " date-string)))
136 (when (or print-seconds (eq style :government))
137 (push secs time-args)
138 (setq time-string
139 (concatenate 'simple-string time-string ":~2,'0D")))
140 (when (and print-meridian (not (member style '(:rfc1123 :iso8601))))
141 (push (signum (floor hours 12)) time-args)
142 (setq time-string
143 (concatenate 'simple-string time-string " ~[am~;pm~]")))
144 (apply #'format destination
145 (if (or date-first (eq style :iso8601))
146 (concatenate 'simple-string date-string " " time-string
147 (when print-timezone
148 (if (eq style :iso8601)
149 "~A"
150 " ~A")))
151 (concatenate 'simple-string time-string " " date-string
152 (if print-timezone " ~A")))
153 (if (or date-first (eq style :iso8601))
154 (nconc date-args (nreverse time-args)
155 (if print-timezone
156 (list timezone-name)))
157 (nconc (nreverse time-args) date-args
158 (if print-timezone
159 (list timezone-name))))))))
160
161 (defun timezone-name (dst tz)
162 (if (and (integerp tz)
163 (or (and (not dst) (= tz 0))
164 (<= 5 tz 8)))
165 (svref (if dst daylight-table timezone-table) tz)
166 (multiple-value-bind
167 (rest seconds)
168 (truncate (* (if dst (1- tz) tz) 60 60) 60)
169 (multiple-value-bind
170 (hours minutes)
171 (truncate rest 60)
172 (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
173 (if (minusp tz) #\- #\+)
174 (abs hours)
175 (not (and (zerop minutes) (zerop seconds)))
176 (abs minutes)
177 (not (zerop seconds))
178 (abs seconds))))))
179
180 ;;; RFC 1123 style timezone: GMT, +1000, -1000.
181 ;;; Timezone is the negative of the CL timezone.
182 ;;;
183 (defun timezone-rfc1123-name (dst tz)
184 (let ((tz (- tz)))
185 (if (and (integerp tz)
186 (or (and (not dst) (= tz 0))
187 (<= 5 tz 8)))
188 (svref (if dst daylight-table timezone-table) tz)
189 (multiple-value-bind
190 (hours minutes)
191 (truncate (if dst (1+ tz) tz))
192 (format nil "~C~2,'0D~2,'0D"
193 (if (minusp tz) #\- #\+)
194 (abs hours)
195 (abs (truncate (* minutes 60))))))))
196
197 ;;; ISO 8601 style timezone: Z, +1000, -1000.
198 ;;; Timezone is the negative of the CL timezone.
199 ;;;
200 (defun timezone-iso8601-name (dst tz)
201 (let ((tz (- tz)))
202 (if (and (not dst) (= tz 0))
203 "Z"
204 (multiple-value-bind (hours minutes)
205 (truncate (if dst (1+ tz) tz))
206 (format nil "~C~2,'0D:~2,'0D"
207 (if (minusp tz) #\- #\+)
208 (abs hours)
209 (abs (truncate (* minutes 60))))))))
210
211
212 ;;; Format-Decoded-Time - External.
213
214 (defun format-decoded-time (destination seconds minutes hours
215 day month year
216 &key (timezone nil)
217 (style :short)
218 (date-first t)
219 (print-seconds t)
220 (print-meridian t)
221 (print-timezone t)
222 (print-weekday t))
223 "Format-Decoded-Time formats a string containing decoded-time
224 expressed in a humanly-readable manner. The destination is any
225 destination which can be accepted by the Format function. The
226 timezone keyword is an integer specifying hours west of Greenwich.
227 The style keyword can be :short (numeric date), :long (months and
228 weekdays expressed as words), or :abbreviated (like :long but words are
229 abbreviated). The keyword date-first, if nil, will cause the time
230 to be printed first instead of the date (the default). The print-
231 keywords, if nil, inhibit the printing of certain semi-obvious
232 parts of the string."
233 (unless (valid-destination-p destination)
234 (error (intl:gettext "~A: Not a valid format destination.") destination))
235 (unless (and (integerp seconds) (<= 0 seconds 59))
236 (error (intl:gettext "~A: Seconds should be an integer between 0 and 59.") seconds))
237 (unless (and (integerp minutes) (<= 0 minutes 59))
238 (error (intl:gettext "~A: Minutes should be an integer between 0 and 59.") minutes))
239 (unless (and (integerp hours) (<= 0 hours 23))
240 (error (intl:gettext "~A: Hours should be an integer between 0 and 23.") hours))
241 (unless (and (integerp day) (<= 1 day 31))
242 (error (intl:gettext "~A: Day should be an integer between 1 and 31.") day))
243 (unless (and (integerp month) (<= 1 month 12))
244 (error (intl:gettext "~A: Month should be an integer between 1 and 12.") month))
245 (unless (and (integerp year) (plusp year))
246 (error (intl:gettext "~A: Hours should be an non-negative integer.") year))
247 (when timezone
248 (unless (and (integerp timezone) (<= 0 timezone 32))
249 (error (intl:gettext "~A: Timezone should be an integer between 0 and 32.")
250 timezone)))
251 (format-universal-time destination
252 (encode-universal-time seconds minutes hours day month year)
253 :timezone timezone :style style :date-first date-first
254 :print-seconds print-seconds :print-meridian print-meridian
255 :print-timezone print-timezone :print-weekday print-weekday))

  ViewVC Help
Powered by ViewVC 1.1.5