Plaster

(defmacro format-date (format (&rest values) &key (time nil) (stream nil) (gmt-p nil)) "Call #'format with FORMAT and the given date fields in VALUES. VALUES is a sequence of any of the following keywords: :seconds :minutes :hours :date :month :year :day :daylight-p :zone :day-abbrev :month-abbrev :year-abbrev :12-hours :am :pm :weekday :day-name Some abbreviations of the keywords are accepted, like :hrs :min :sec. Note that :day is the day of the week number and :date is the day of the month." (let* ((seconds (gensym "SECONDS")) (minutes (gensym "MINUTES")) (hours (gensym "HOURS")) (date (gensym "DATE")) (month (gensym "MONTH")) (year (gensym "YEAR")) (day (gensym "DAY")) (daylight-p (gensym "DAYLIGHT-P")) (zone (gensym "ZONE")) (args (loop :for v :in values :collect (etypecase v (keyword (case v (:day-abbrev `(lisp-weekday-name ,day :abbrev t)) ((:weekday :day-name) `(lisp-weekday-name ,day)) ((:month-name) `(calendar:month-name ,month ,year)) ((:month-abbrev :mon-abbrev) `(calendar:month-name ,month ,year :format :abbreviated)) ((:year-abbrev :yr-abbrev) `(format nil "~2,'0d" (mod ,year 100))) (:std-zone `(format nil "~c~2,'0d~2,'0d" (if (< ,zone 0) #\+ #\-) (tz-hours ,zone) (tz-minutes ,zone))) ((:12-hours :12-hour :12-hrs :12-hr :12hours :12hour :12hrs :12hr) `(let ((p (mod ,hours 12))) (if (zerop p) 12 p))) ((:am :pm :am/pm :am-pm) `(if (> ,hours 12) "PM" "AM")) (otherwise (case v ((:seconds :second :sec) seconds) ((:minutes :minute :min) minutes) ((:hours :hour :hrs :hr) hours) (:date date) ((:month :mon) month) ((:year :yr) year) (:day day) (:zone zone) (:daylight-p daylight-p) (otherwise (error "Unknown format-date keyword ~s." v)))))) (t v))))) `(multiple-value-bind (,seconds ,minutes ,hours ,date ,month ,year ,day ,daylight-p ,zone) ;; One of the branches of gmt-p will be unreachable. (locally #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (if ,gmt-p (decode-universal-time (or ,time (get-universal-time)) 0) (decode-universal-time (or ,time (get-universal-time))))) (declare (ignorable ,seconds ,minutes ,hours ,date ,month ,year ,day ,daylight-p ,zone)) (when ,daylight-p (decf ,zone)) (format ,stream ,format ,@args))))