Lispy Days

Add Calendar Plugin

Calendar Plugin for CL-Wiki. Making video (ttyrec).

/(calendar 3 2004 :center)

(in-package :blog)
(defconstant +day-names+
   '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
(defconstant +month-names+
   '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun weekday-name (week) (nth week +day-names+))
(defun month-name (month) (nth (1- month) +month-names+))
(defun get-this-year () (sixth (multiple-value-list (get-decoded-time))))
(defun get-this-month () (fifth (multiple-value-list (get-decoded-time))))

(defun calendar (month year)
  (let ((dtime (encode-universal-time 0 0 12 1 month year)))
    (flet ((next-day ()
             (multiple-value-bind (se mi ho da mo ye week)
                 (decode-universal-time dtime)
               (declare (ignorable se mi ho ye))
               (incf dtime (* 60 60 24))
               (if (= mo month) (list da week) nil))))
      (loop for d = (next-day) while d collect d))))

(defun format-html-calendar (stream month year fn)
  (let* ((c (calendar month year))
         (p (loop for i from 0 below (second (car c)) collect (list nil i)))
         (c (nconc p c)))
    (format stream
       "<table summary=\"~A ~A\">~%<tr><td colspan=\"7\"><div align=\"center\">~A ~A</div></td></tr>~%<tr>~{<td>~A</td>~}</tr>~%"
            (month-name month) year
            (month-name month) year
            (mapcar (lambda (e) (subseq e 0 3)) +day-names+))
    (loop for (day week) in c and i from 0 do
          (when (= (mod week 7) 0) (format stream "<tr>"))
          (if day
              (format stream "<td>~A</td>" (funcall fn year month day))
              (format stream "<td> </td>"))
          (when (= (mod week 7) 6) (format stream "</tr>~%"))
          finally
          (loop repeat (- 6 (mod week 7)) do
               (write-string "<td> </td>" stream)
               finally (write-line "</tr>" stream)))
    (format stream "</table>~%")))

(defplugin "/(calendar [month] [year] [:center|:right]) - calendar plugin."
  (lambda (blog req page arg stream)
    (declare (ignorable blog req page arg))
    (cond ((find :center arg) (write-line "<div align=\"center\">" stream))
          ((find :right arg) (write-line "<div align=\"right\">" stream)))
    (format-html-calendar
     stream
     (or (and (not (keywordp (first arg))) (first arg)) (get-this-month))
     (or (and (not (keywordp (second arg))) (second arg))(second arg) (get-this-year))
     (lambda (year month day)
       (let ((name (format nil "~4,'0D~2,'0D~2,'0D" year month day)))
         (if (find-page blog :page name)
             (format nil "<a href=\"~A.html\">~2D</a>" name day)
             (format nil "~2D" day)))))
    (cond ((find :center arg) (write-line "</div>" stream))
          ((find :right arg) (write-line "</div>" stream)))))

• 3/15 最後の部分が閉じてないのと <center> じゃなくて <div align="center"> を使うように修正。