summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2009-10-08 14:11:35 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2009-10-08 14:11:35 +0200
commitb78afdb907940e989129845be28888f3dbc8b297 (patch)
tree0dc306a293e7ef06eba30f00e0868df36dd89e92
parent876f26b9368f8976712f3eebef766745aec8616d (diff)
Reimplement FORMAT-DATE for improved performance.
Ignore-this: 9a98268184ce979a4c2676da9f58951e darcs-hash:94ec31059fb0961f727859c63fcdabb32683918b
-rwxr-xr-xjournal.lisp12
-rw-r--r--utils.lisp74
2 files changed, 51 insertions, 35 deletions
diff --git a/journal.lisp b/journal.lisp
index e706fb6..99b8459 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -59,7 +59,7 @@
(flet ((atom-time (time)
(format-date nil
- "%4yr-%2mon-%2dayT%2hr:%2min:%2secZ"
+ "%4yr%-%2mon%-%2day%T%2hr%:%2min%:%2sec%Z"
time
0)))
(with-xml-output (*standard-output* :encoding "utf-8")
@@ -132,7 +132,7 @@
(flet ((atom-time (time)
(format-date nil
- "%4yr-%2mon-%2dayT%2hr:%2min:%2secZ"
+ "%4yr%-%2mon%-%2day%T%2hr%:%2min%:%2secZ%"
time
0)))
(with-xml-output (*standard-output* :encoding "utf-8")
@@ -224,7 +224,7 @@
(<:td (<:a :href (link-to :view :post-id id)
(<:as-html title)))
(<:td :style "text-align: right"
- (<:as-is (format-date nil "%day.%mon.%yr,&nbsp;%hr:%2min" posting-date)))
+ (<:as-is (format-date nil "%day%.%mon%.%yr%,&nbsp;%hr%:%2min%" posting-date)))
(<:td (<:a :href (link-to :view :post-id id)
(<:as-is
(format nil "~D&nbsp;Kommentar~:*~[e~;~:;e~]" (length comments)))))))
@@ -236,7 +236,7 @@
(<:div :class :journal-entry-header
(<:span :class :journal-entry-date
(<:as-html
- (format-date nil "%@day-of-week, den %day.%mon.%yr, %hr:%2min."
+ (format-date nil "%@day-of-week%, den %day%.%mon%.%yr%, %hr%:%2min%."
posting-date)))
(unless (null categories)
(<:span :class :journal-entry-category
@@ -284,7 +284,7 @@
:id (format nil "comment-~D" id)
(<:div :class :journal-comment-header
(<:as-html (format nil "(~A) "
- (format-date nil "%day.%mon.%yr, %hr:%min" date)))
+ (format-date nil "%day%.%mon%.%yr%, %hr%:%min%" date)))
(<:a :href website :rel "nofollow"
(<:as-html (format nil "~A" author)))
(<:as-html " meint: "))
@@ -301,7 +301,7 @@
:id (format nil "trackback-~D" id)
(<:div :class :journal-comment-header
(<:as-html (format nil "(~A) "
- (format-date nil "%day.%mon.%yr, %hr:%min" date)))
+ (format-date nil "%day%.%mon%.%yr%, %hr%:%min%" date)))
(<:strong (<:as-html (format nil "~A " (or blog-name url))))
(if (null title)
(<:a :href url :rel "nofollow" (<:as-html "schreibt hierzu:"))
diff --git a/utils.lisp b/utils.lisp
index f49820e..cc7dee1 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -82,6 +82,23 @@
(6 "Sonntag")))
+(defmacro literal-casequal (thing &body clauses)
+ (let ((thing-sym (gensym "case-object"))
+ (map-sym (gensym "dispatch-table"))
+ (map-sym2 (gensym "load-time-dispatch-table")))
+ `(let ((,thing-sym ,thing)
+ (,map-sym (load-time-value
+ (let ((,map-sym2 (make-hash-table :test 'equal)))
+ ,@(mapcar (lambda (clause)
+ `(setf (gethash ,(first clause) ,map-sym2)
+ ,(position clause clauses)))
+ clauses)
+ ,map-sym2))))
+ (case (gethash ,thing-sym ,map-sym)
+ ,@(mapcar (lambda (clause)
+ `(,(position clause clauses) ,(second clause)))
+ clauses)))))
+
(defun %real-format-date (destination date-control-string universal-time
&optional (time-zone nil time-zone-supplied-p))
"Format DATE according to the description given by DATE-FORMAT-STRING.
@@ -98,37 +115,36 @@ after another in any arbitrary order."
(if time-zone-supplied-p
(decode-universal-time universal-time time-zone)
(decode-universal-time universal-time))
- (let ((first-match-p t))
- (ppcre:do-matches (start end "%[^%]*" date-control-string)
- (let ((substring (subseq date-control-string start end)))
+ (let ((first-match-p t)
+ (last-match-end 0))
+ (ppcre:do-matches (start end "%[^%]*%" date-control-string)
+ (let ((substring (subseq date-control-string (1+ start) (1- end))))
+ (format out (subseq date-control-string last-match-end start))
(multiple-value-bind (control value offset)
- (regex-case substring
- ("^%day-of-week" (values "~D" day-of-week 12))
- ("^%@day-of-week" (values "~A"
- (name-of-day day-of-week)
- 13))
- ("^%daylight-p" (values "~A" daylight-p 11))
- ("^%zone" (values "~D" zone 5))
- ("^%day" (values "~D" day 4))
- ("^%mon" (values "~D" mon 4))
- ("^%yr" (values "~D" yr 3))
- ("^%sec" (values "~D" sec 4))
- ("^%min" (values "~D" min 4))
- ("^%hr" (values "~D" hr 3))
- ("^%2day" (values "~2,'0D" day 5))
- ("^%2mon" (values "~2,'0D" mon 5))
- ("^%4yr" (values "~4,'0D" yr 4))
- ("^%2sec" (values "~2,'0D" sec 5))
- ("^%2min" (values "~2,'0D" min 5))
- ("^%2hr" (values "~2,'0D" hr 4)))
- (when first-match-p
- (format out (subseq date-control-string 0 start))
- (setf first-match-p nil))
+ (literal-casequal substring
+ ("day-of-week" (values "~D" day-of-week 11))
+ ("@day-of-week" (values "~A"
+ (name-of-day day-of-week)
+ 12))
+ ("daylight-p" (values "~A" daylight-p 10))
+ ("zone" (values "~D" zone 4))
+ ("day" (values "~D" day 3))
+ ("mon" (values "~D" mon 3))
+ ("yr" (values "~D" yr 2))
+ ("sec" (values "~D" sec 3))
+ ("min" (values "~D" min 3))
+ ("hr" (values "~D" hr 2))
+ ("2day" (values "~2,'0D" day 4))
+ ("2mon" (values "~2,'0D" mon 4))
+ ("4yr" (values "~4,'0D" yr 3))
+ ("2sec" (values "~2,'0D" sec 4))
+ ("2min" (values "~2,'0D" min 4))
+ ("2hr" (values "~2,'0D" hr 3)))
(if control
- (progn
- (format out control value)
- (format out "~A" (subseq substring offset)))
- (format out "~A" substring))))))))))
+ (format out control value)
+ (format out "%~A%" substring))
+ (setq last-match-end end))))
+ (format destination (subseq date-control-string last-match-end)))))))
(defun compute-script-last-modified-date ()