/[cl-l10n]/cl-l10n/printers.lisp
ViewVC logotype

Contents of /cl-l10n/printers.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Thu Jun 15 19:57:34 2006 UTC (7 years, 10 months ago) by alendvai
Branch: MAIN
CVS Tags: HEAD
Changes since 1.18: +1 -1 lines
Added arnesi and iterate dependency, lookup-first-matching-resource
1 ;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3 (in-package :cl-l10n)
4
5 ;; Number
6 (defun get-sign (arg locale)
7 (cond ((plusp arg) (locale-positive-sign locale))
8 ((minusp arg) (locale-negative-sign locale))
9 (t "")))
10
11 (defvar *float-digits* 2
12 "Used when all values after the decimal point are zero to
13 determine the number of zero's to print")
14
15 (defun fix-float-string (string size)
16 "Pads the string with trailing zero's if it is smaller than size"
17 (with-output-to-string (s)
18 (princ string s)
19 (when (< (length string) size)
20 (dotimes (x (- size (length string)))
21 (princ "0" s)))))
22
23 (defun format-number (stream arg no-dp no-ts
24 &optional (locale (current-locale)))
25 (let ((locale (locale locale))
26 (float-part (float-part (coerce (abs arg) 'double-float))))
27 (cl:format stream
28 (getf (printers locale)
29 (if no-ts :number-no-ts :number-ts))
30 (get-sign arg locale)
31 (truncate (abs arg))
32 (unless (and (string= "" float-part) no-dp)
33 (list (locale-decimal-point locale)
34 (fix-float-string float-part *float-digits*))))
35 (values)))
36
37 (defun print-number (number &key (stream *standard-output*)
38 no-ts no-dp (locale (current-locale)))
39 (format-number stream number no-dp no-ts locale)
40 number)
41
42
43 ;; Money
44 (defvar *default-round-mode* :round)
45
46 (defun round-money (float frac-digits &key (round-mode *default-round-mode*))
47 (let ((round-fn (ecase round-mode
48 (:round #'fround)
49 (:down #'ffloor)
50 (:up #'fceiling))))
51 (let ((size (expt 10 frac-digits)))
52 (/ (funcall round-fn (* float size)) size))))
53
54 (defun get-money-printer (minusp no-ts)
55 (if minusp
56 (if no-ts
57 :money-n-no-ts
58 :money-n-ts)
59 (if no-ts
60 :money-p-no-ts
61 :money-p-ts)))
62
63 (defun format-money (stream arg use-int-sym no-ts &optional (locale (current-locale)))
64 (let* ((locale (locale locale))
65 (frac-digits (max (if use-int-sym
66 (locale-int-frac-digits locale)
67 (locale-frac-digits locale))
68 0))
69 (val-to-print (round-money (abs (coerce arg 'double-float))
70 frac-digits))
71 (float-part (float-part val-to-print))
72 (sym (if use-int-sym
73 (locale-int-curr-symbol locale)
74 (locale-currency-symbol locale)))
75 (prec (= 1 (locale-n-cs-precedes locale))))
76 (cl:format stream
77 (getf (printers locale)
78 (get-money-printer (minusp arg) no-ts))
79 (if prec sym "")
80 (truncate (abs val-to-print))
81 (unless (zerop frac-digits)
82 (list (locale-mon-decimal-point locale)
83 (fix-float-string float-part frac-digits)))
84 (if prec "" (trim sym))))
85 (values))
86
87 (defun print-money (num &key (stream *standard-output*) use-int-sym no-ts
88 (locale (current-locale)))
89 (format-money stream num use-int-sym no-ts locale)
90 num)
91
92 ;; ;; Time and date printing.
93 (defun get-time-fmt-string (locale show-date show-time)
94 (cond ((and show-time show-date)
95 (locale-d-t-fmt locale))
96 ((and (not show-date) (not show-time))
97 (if (string= "" (locale-t-fmt-ampm locale))
98 (locale-t-fmt locale)
99 (locale-t-fmt-ampm locale)))
100 (show-time (locale-t-fmt locale))
101 (show-date (locale-d-fmt locale))))
102
103 (defvar *time-formatters* (make-hash-table))
104 (defmacro def-formatter (sym &body body)
105 "Creates a function with BODY which can be looked up using lookup-formatter
106 using the character SYM."
107 (let ((name (gensym (strcat "FORMATTER-" sym))))
108 `(flet ((,name (stream locale ut sec min hour date month year day
109 daylight-p zone)
110 (declare (ignorable stream locale ut sec min hour date month
111 year day daylight-p zone))
112 ,@body))
113 (setf (gethash ,sym *time-formatters*)
114 #',name))))
115
116 (defun lookup-formatter (char)
117 (or (gethash char *time-formatters*)
118 (locale-error "No format directive for char ~S." char)))
119
120 (defun princ-pad-val (val stream &optional (pad "0") (size 2))
121 (declare (type stream stream) (optimize speed)
122 (type fixnum val size))
123 (assert (not (minusp val)) (val) "Value ~A cannot be smaller than 0." val)
124 (cond ((zerop val)
125 (dotimes (x (1- size))
126 (princ pad stream))
127 (princ 0 stream))
128 (t
129 (loop with stop-value = (expt 10 size)
130 for x integer = (* val 10) then (* x 10)
131 until (>= x stop-value) do
132 (princ pad stream))
133 (princ val stream))))
134
135 (defun last-2-digits (val)
136 (mod val 100))
137
138 (def-formatter #\a
139 (let ((day (1+ day)))
140 (if (> day 6) (decf day 7))
141 (princ (nth day (locale-abday locale)) stream)))
142
143 (def-formatter #\A
144 (let ((day (1+ day)))
145 (if (> day 6) (decf day 7))
146 (princ (nth day (locale-day locale)) stream)))
147
148 (def-formatter #\b
149 (cl:format stream (cl:formatter "~A")
150 (nth (1- month) (locale-abmon locale))))
151
152 (def-formatter #\B
153 (cl:format stream (cl:formatter "~A")
154 (nth (1- month) (locale-mon locale))))
155
156 (def-formatter #\c
157 (print-time-string (locale-d-t-fmt locale) stream ut locale))
158
159 (def-formatter #\C
160 (princ-pad-val (truncate (/ year 100)) stream))
161
162 (def-formatter #\d
163 (princ-pad-val date stream))
164
165 (def-formatter #\D
166 (print-time-string "%m/%d/%y" stream ut locale))
167
168 (def-formatter #\e
169 (princ-pad-val date stream " "))
170
171 (def-formatter #\F
172 (print-time-string "%Y-%m-%d" stream ut locale))
173
174 (def-formatter #\g
175 (print-time-string "%y" stream ut locale))
176
177 (def-formatter #\G
178 (print-time-string "%Y" stream ut locale))
179
180 (def-formatter #\h
181 (princ (nth (1- month) (locale-abmon locale))
182 stream))
183
184 (def-formatter #\H
185 (princ-pad-val hour stream))
186
187 (def-formatter #\I
188 (princ-pad-val (if (> hour 12) (- hour 12) hour) stream))
189
190 (defvar *mon-days*
191 '(31 28 31 30 31 30 31 31 30 31 30 31))
192
193 (defvar *mon-days-leap*
194 (substitute 29 28 *mon-days*))
195
196 (defun leap-year-p (year)
197 (cond ((zerop (mod year 400)) t)
198 ((zerop (mod year 100)) nil)
199 ((zerop (mod year 4)) t)
200 (t nil)))
201
202 (defun day-of-year (date month year)
203 (let ((total 0))
204 (loop repeat (1- month)
205 for x in (if (leap-year-p year) *mon-days-leap* *mon-days*) do
206 (incf total x))
207 (incf total date)))
208
209 (def-formatter #\j
210 (princ-pad-val (day-of-year date month year) stream "0" 3))
211
212 (def-formatter #\k
213 (princ-pad-val hour stream " "))
214
215 (def-formatter #\l
216 (princ-pad-val (if (> hour 12) (- hour 12) hour) stream
217 " "))
218
219 (def-formatter #\m
220 (princ-pad-val month stream))
221
222 (def-formatter #\M
223 (princ-pad-val min stream))
224
225 (def-formatter #\n
226 (princ #\Newline stream))
227
228 (def-formatter #\N
229 (princ "000000000" stream))
230
231 (defun get-am-pm (hour locale)
232 (funcall (if (< hour 12) #'car #'cadr)
233 (locale-am-pm locale)))
234
235 (def-formatter #\p
236 (princ (string-upcase (get-am-pm hour locale))
237 stream))
238
239 (def-formatter #\P
240 (princ (string-downcase (get-am-pm hour locale))
241 stream))
242
243 (def-formatter #\r
244 (print-time-string "%H:%M:%S %p" stream ut locale))
245
246 (def-formatter #\R
247 (print-time-string "%I:%M" stream ut locale))
248
249 (defvar *1970-01-01* (encode-universal-time 0 0 0 01 01 1970 0))
250
251 (def-formatter #\s
252 (princ (- ut *1970-01-01*) stream))
253
254 (def-formatter #\S
255 (princ-pad-val sec stream))
256
257 (def-formatter #\t
258 (princ #\Tab stream))
259
260 (def-formatter #\T
261 (print-time-string "%H:%M:%S" stream ut locale))
262
263 (def-formatter #\u
264 (let ((day (1+ day)))
265 (when (> day 7) (decf day 7))
266 (princ day stream)))
267
268 ;; FIXME
269 (def-formatter #\U
270 (locale-error "Unsupported time format directive ~S." #\U))
271
272 ;; FIXME
273 (def-formatter #\V
274 (locale-error "Unsupported time format directive ~S." #\V))
275
276 (def-formatter #\w
277 (let ((day (1+ day)))
278 (when (>= day 7) (decf day 7))
279 (princ day stream)))
280
281 ;; FIXME
282 (def-formatter #\W
283 (locale-error "Unsupported time format directive ~S." #\W))
284
285 (def-formatter #\x
286 (print-time-string (locale-d-fmt locale) stream ut locale))
287
288 (def-formatter #\X
289 (print-time-string (locale-t-fmt locale) stream ut locale))
290
291 (def-formatter #\y
292 (princ-pad-val (last-2-digits year) stream))
293
294 (def-formatter #\Y
295 (princ year stream))
296
297
298 ; This was all severely broken until I took a look
299 ; at Daniel Barlow's net-telent-date package,
300 ; which is a must read for anyone working with dates
301 ; in CL.
302 (def-formatter #\z
303 (let ((d-zone (if daylight-p (1- zone) zone)))
304 (multiple-value-bind (hr mn) (truncate (abs d-zone))
305 (princ (if (<= d-zone 0) #\+ #\-) stream)
306 (cl:format stream (cl:formatter "~2,'0D~2,'0D")
307 hr (floor (* 60 mn))))))
308
309 ;; Probably Should be printing SAST rather than +0200
310 ;; but since all these wonderful codes are not
311 ;; standardized i'm keeping it the same as %z
312 ;; so that we can parse it back.
313 ;; eg. Does IST mean 'Israeli Standard Time','Indian Standard Time'
314 ;; or 'Irish Summer Time' ?
315 (def-formatter #\Z
316 (print-time-string "%z" stream ut locale))
317
318 (defvar *time-zone*)
319
320 (defun format-time (stream ut show-date show-time &optional (locale (current-locale)) fmt time-zone)
321 (let ((locale (locale locale))
322 (*time-zone* (or time-zone (nth-value 8 (decode-universal-time ut)))))
323 (print-time-string (or fmt (get-time-fmt-string locale
324 show-date show-time))
325 stream ut locale))
326 (values))
327
328 (defun print-time-string (fmt-string stream ut locale)
329 (declare (optimize speed) (type simple-string fmt-string))
330 (let ((values (multiple-value-list (decode-universal-time ut *time-zone*))))
331 (loop for x across fmt-string
332 with perc = nil
333 with in-dot = nil do
334 (case x
335 (#\% (if perc
336 (progn (princ #\% stream) (setf perc nil))
337 (setf perc t)))
338 ;; see compute-order in load-locale.lisp
339 ;; for why this line is here.
340 (#\. (if perc (setf in-dot t) (princ x stream)))
341 (#\1 (if (and perc in-dot)
342 (setf in-dot nil)
343 (princ x stream)))
344 (#\E (unless perc (princ x stream)))
345 (t (if perc
346 (progn (apply (the function (lookup-formatter x))
347 stream locale ut values)
348 (setf perc nil))
349 (princ x stream)))))))
350
351 (defun print-time (ut &key show-date show-time (stream *standard-output*)
352 (locale (current-locale)) fmt time-zone)
353 (format-time stream ut show-date show-time locale fmt time-zone)
354 ut)
355
356
357 ;; Format
358 (define-compiler-macro format (&whole form dest control &rest args)
359 "Compiler macro to remove unnecessary calls to parse-fmt-string."
360 (if (stringp control)
361 `(cl::format ,dest ,(parse-fmt-string control) ,@args)
362 form))
363
364 (defmacro formatter (fmt-string)
365 (etypecase fmt-string
366 (string `(cl:formatter ,(parse-fmt-string fmt-string)))))
367
368 (defun format (stream fmt-cntrl &rest args)
369 (apply #'cl:format stream
370 (etypecase fmt-cntrl
371 (function fmt-cntrl)
372 (string (parse-fmt-string fmt-cntrl)))
373 args))
374
375 (defun shadow-format (&optional (package *package*))
376 (shadowing-import '(cl-l10n::format cl-l10n::formatter) package))
377
378 (defvar *scanner* (cl-ppcre:create-scanner "~[@V,:]*[M|U|N]"))
379
380 (defun needs-parsing (string)
381 (declare (optimize speed (safety 1) (debug 0)))
382 (cl-ppcre:scan *scanner* (string-upcase string)))
383
384 (defun parse-fmt-string (string)
385 (if (needs-parsing string)
386 (really-parse-fmt-string string)
387 string))
388
389 (defun really-parse-fmt-string (string)
390 (declare (optimize speed) (type simple-string string))
391 (with-output-to-string (fmt-string)
392 (loop for char across string
393 with tilde = nil do
394 (case char
395 ((#\@ #\v #\, #\:) (princ char fmt-string))
396 (#\~ (princ char fmt-string)
397 (if tilde
398 (setf tilde nil)
399 (setf tilde t)))
400 (t (if tilde
401 (progn (setf tilde nil)
402 (princ (get-replacement char) fmt-string))
403 (princ char fmt-string)))))))
404
405 (defvar *directive-replacements*
406 '((#\M . "/cl-l10n:format-money/")
407 (#\U . "/cl-l10n:format-time/")
408 (#\N . "/cl-l10n:format-number/")))
409
410 (defun get-replacement (char)
411 (or (cdr (assoc (char-upcase char) *directive-replacements*))
412 char))
413
414
415
416
417 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5