Reimplement FORMAT-DATE for improved performance.

Ignore-this: 9a98268184ce979a4c2676da9f58951e

darcs-hash:94ec31059fb0961f727859c63fcdabb32683918b

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 ()