planner-calendar.el

   1 ;;; planner-calendar.el --- Create a clickable calendar in published html
   2
   3 ;; Copyright (C) 2003, 2004 Gary V. Vaughan (gary AT gnu DOT org)
   4 ;; Parts copyright (C) 2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Emacs Lisp Archive Entry
   7 ;; Filename: planner-calendar.el
   8 ;; Version: 1.1
   9 ;; Date: Tue, 1 June 2004
  10 ;; Keywords: hypermedia
  11 ;; Author: Gary V. Vaughan (gary AT gnu DOT org)
  12 ;; Description: Create a clickable calendar in published html
  13 ;; Compatibility: Emacs21, XEmacs21
  14
  15 ;; This file is part of Planner.  It is not part of GNU Emacs.
  16
  17 ;; Planner is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by
  19 ;; the Free Software Foundation; either version 2, or (at your option)
  20 ;; any later version.
  21
  22 ;; Planner is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25 ;; General Public License for more details.
  26
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with Planner; see the file COPYING.  If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31
  32 ;;; Commentary:
  33
  34 ;; You will need to install Emacs Muse before this is of any use to
  35 ;; you.
  36
  37 ;; Read the documentation for `planner-calendar-insert-calendar-maybe',
  38 ;; `planner-calendar-move-calendar-to-top-of-page-maybe' and
  39 ;; `planner-calendar-create-today-link' for how to use the functions
  40 ;; in this file from Muse hooks.
  41 ;;
  42 ;; If you decide to create a today link for published planner pages,
  43 ;; add a hook function like this:
  44 ;;
  45 ;;   (eval-after-load "muse-publish"
  46 ;;     (add-hook 'muse-after-publish-hook
  47 ;;               'planner-calendar-create-today-link nil t))
  48
  49 ;;; Contributors:
  50
  51 ;; drkm <darkman_spam@yahoo.fr> contributed a small patch that fixes a
  52 ;; planner-calendar boundary case when last day of the month is
  53 ;; Sunday.
  54
  55 ;;; Code:
  56
  57 (require 'calendar)
  58 (require 'muse)
  59 (require 'planner)
  60 (require 'planner-publish)
  61
  62 (defgroup planner-calendar nil
  63   "Options controlling the behaviour of planner calendar publication."
  64   :group 'planner)
  65
  66 (defcustom planner-calendar-prev-month-button "&laquo;"
  67   "*Default html entity to use for previous month buttons."
  68   :type 'string
  69   :group 'planner-calendar)
  70
  71 (defcustom planner-calendar-next-month-button "&raquo;"
  72   "*Default html entity to use for next month buttons."
  73   :type 'string
  74   :group 'planner-calendar)
  75
  76 (defcustom planner-calendar-day-header-chars 3
  77   "*Default number of characters to use for day column header names."
  78   :type 'integer
  79   :group 'planner-calendar)
  80
  81 (defcustom planner-calendar-html-tag-marker "<div id=\"content\">"
  82   "*Default html block element to add calendar HTML to."
  83   :type 'string
  84   :group 'planner-calendar)
  85
  86 (defcustom planner-calendar-today-page-name "today"
  87   "*Default base name for published today page link file."
  88   :type 'string
  89   :group 'planner-calendar)
  90
  91 (defcustom planner-calendar-nop-buttons-flag t
  92   "Non-nil means add <nop> tags before navigation buttons in the calendar."
  93   :type 'boolean
  94   :group 'planner-calendar)
  95
  96 (defmacro planner-calendar-render (var begin end tag class &rest body)
  97   "Generate a row of days for the calendar."
  98   `(let (string)
  99      (calendar-for-loop ,var from ,begin to ,end do
 100       (let ((day (mod (+ calendar-week-start-day i) 7))
 101             (wrap-p (and (= 6 (mod ,var 7)) (/= ,var ,end))))
 102         (setq string (concat string
 103                              "<" ,tag " class=\"" ,class " "
 104                              (calendar-day-name day nil t) "\">"
 105                              ,@body
 106                              "</" ,tag ">\n"
 107                              (and wrap-p "</tr>\n<tr>\n")))))
 108      string))
 109
 110 (put 'planner-calendar-render 'lisp-indent-function 1)
 111
 112 (defun planner-calendar-date-to-filename (date)
 113   "See `planner-date-to-filename' except don't choke on nil DATE."
 114   (and date (planner-date-to-filename date)))
 115
 116 ;; calendar-week-start-day
 117 (defun planner-calendar (month year &optional arrows)
 118   "Generate a string of html to render a clickable calendar for MONTH YEAR.
 119 If ARROWS is non-nil, include prev/next month arrows."
 120   (let*
 121       ((blank-days                      ; at start of month
 122         (mod (- (calendar-day-of-week (list month 1 year))
 123                 calendar-week-start-day)
 124          7))
 125        (last (calendar-last-day-of-month month year))
 126        (pad-days                        ; at end of month
 127         (- 7 (1+ (calendar-day-of-week (list month last year)))))
 128        ;; don't use leading whitespace in the generated html, or the
 129        ;; other markup rules will add <blockquote> sections!
 130        (string
 131         (concat
 132          "<table class=\"month-calendar\">\n"
 133          "<tr class=\"month-calendar-head\">\n"
 134          (if arrows
 135              (concat
 136               "<th>"
 137               (planner-calendar-prev-month-href
 138                month year
 139                planner-calendar-prev-month-button
 140                planner-calendar-nop-buttons-flag)
 141               "</th>\n"
 142               "<th colspan=\"5\">\n")
 143            "<th colspan=\"7\">\n")
 144          (format "%s %d" (calendar-month-name month) year)
 145          "</th>\n"
 146          (when arrows
 147            (concat "<th>"
 148                    (planner-calendar-next-month-href
 149                     month year planner-calendar-next-month-button
 150                     planner-calendar-nop-buttons-flag)
 151                    "</th>\n"))
 152          "</tr>\n"
 153          "<tr>\n"
 154
 155          ;; add day name headings
 156          (planner-calendar-render i 0 6
 157           "th" "month-calendar-day-head"
 158           (calendar-day-name day planner-calendar-day-header-chars t))
 159
 160          "</tr>\n"
 161          "<tr>\n"
 162
 163          ;; add blank days before the first of the month
 164          (planner-calendar-render i 0 (1- blank-days)
 165           "td" "month-calendar-day-noday" "&nbsp;")
 166
 167          ;; put in the days of the month
 168          (planner-calendar-render i blank-days (+ last blank-days -1)
 169              "td" (if (planner-page-file
 170                        (planner-calendar-date-to-filename
 171                         (list month (- i blank-days -1) year)))
 172                       "month-calendar-day-link"
 173                     "month-calendar-day-nolink")
 174              (planner-calendar-published-file-href
 175                       (planner-calendar-date-to-filename
 176                        (list month (- i blank-days -1) year))
 177                       (int-to-string (- i blank-days -1))
 178                       planner-calendar-nop-buttons-flag))
 179
 180          ;; add padding days at end of month to make rule lines neat
 181          (unless (zerop (mod (+ blank-days last) 7))
 182            (planner-calendar-render i
 183              (+ last blank-days) (+ last blank-days pad-days -1)
 184              "td" "month-calendar-day-noday" "&nbsp;"))
 185
 186          "</tr>\n"
 187          "</table>\n")))
 188     string))
 189
 190 (defun planner-calendar-from-wiki (&optional arrows wiki)
 191   "Generate a string of html (possibly with ARROWS) for a calendar for WIKI."
 192   (let ((page (or wiki (planner-page-name))))
 193     (save-match-data
 194       (when (string-match planner-date-regexp page)
 195         (let ((year (string-to-number (substring page 0 4)))
 196               (month (string-to-number (substring page 5 7))))
 197           (planner-calendar month year arrows))))))
 198
 199 (defun planner-calendar-published-file-href (wiki &optional name nop)
 200   "Return an href anchor string to the published WIKI if WIKI exists."
 201   (if (and (planner-page-file wiki)
 202            (not (planner-private-p (planner-page-file wiki))))
 203       (planner-link-href wiki (or name wiki))
 204     (or name wiki)))
 205
 206 (defun planner-calendar-yesterday (date)
 207   "Return the day before DATE as a (month day year) list."
 208   (let* ((year (extract-calendar-year date))
 209          (month (extract-calendar-month date))
 210          (day (extract-calendar-day date))
 211          (prev-year (if (and (= 1 month) (= 1 day)) (1- year) year))
 212          (prev-month (if (= 1 day) (1+ (mod (+ month 10) 12)) month))
 213          (prev-day (if (= 1 day)
 214                        (calendar-last-day-of-month prev-month prev-year)
 215                      (1- day))))
 216     (list prev-month prev-day prev-year)))
 217
 218 (defun planner-calendar-tomorrow (date)
 219   "Return the day after DATE as a (month day year) list."
 220   (let* ((year (extract-calendar-year date))
 221          (month (extract-calendar-month date))
 222          (day (extract-calendar-day date))
 223          (last-day (calendar-last-day-of-month month year))
 224          (next-year
 225           (if (and (= 12 month) (= 31 day))
 226               (1+ year)
 227             year))
 228          (next-month
 229           (if (>= day last-day)
 230               (1+ (mod month 12))
 231             month))
 232          (next-day (if (< day last-day) (1+ day) 1)))
 233     (list next-month next-day next-year)))
 234
 235 (defun planner-calendar-today (&optional max-days)
 236   "Return today or the first day before today with a day page."
 237   (planner-calendar-prev-date
 238    (planner-calendar-tomorrow (calendar-current-date))))
 239
 240 (defun planner-calendar-create-today-link (&optional name)
 241   "Create a link to the newest published day page.
 242 Add this to `muse-after-publish-hook' to create a \"today\" soft
 243 link to the newest published planner day page, on operating systems that
 244 support POSIX \"ln\"."
 245   (let* ((today-name planner-calendar-today-page-name)
 246          (target-file (planner-published-file (or name today-name)))
 247          (source-file (planner-published-file
 248                        (planner-calendar-date-to-filename
 249                         (planner-calendar-today)))))
 250     (when (file-exists-p target-file)
 251       (funcall planner-delete-file-function target-file))
 252     (make-symbolic-link source-file target-file t)))
 253
 254 (defun planner-calendar-prev-date (date &optional max-days)
 255   "Return the first day before DATE with a day page."
 256   (let ((days (or max-days 180))
 257         (yesterday date)
 258         (done nil))
 259     (while (and (not done) (> days 0))
 260       (setq yesterday (planner-calendar-yesterday yesterday)
 261             days (1- days))
 262       (let ((wiki (planner-calendar-date-to-filename yesterday)))
 263         (setq done (and (planner-page-file wiki)
 264                         (not (planner-private-p (planner-page-file wiki)))))))
 265     (if done yesterday nil)))
 266
 267 (defun planner-calendar-next-date (date &optional max-days)
 268   "Return the first day after DATE with a day page."
 269   (let ((days (or max-days 180))
 270         (tomorrow date)
 271         (done nil))
 272     (while (and (not done) (> days 0))
 273       (setq tomorrow (planner-calendar-tomorrow tomorrow)
 274             days (1- days))
 275       (let ((wiki (planner-calendar-date-to-filename tomorrow)))
 276         (setq done (and (planner-page-file wiki)
 277                         (not (planner-private-p (planner-page-file wiki)))))))
 278     (if done tomorrow nil)))
 279
 280 (defun planner-calendar-prev-date-href (date name &optional nop max-days)
 281   "Return an href anchor string for the first day page before DATE."
 282   (let ((prev-date (planner-calendar-prev-date date max-days)))
 283     (planner-calendar-published-file-href
 284      (planner-calendar-date-to-filename prev-date) name nop)))
 285
 286 (defun planner-calendar-next-date-href (date name &optional nop max-days)
 287   "Return an href anchor string for the first day page after DATE."
 288   (let ((next-date (planner-calendar-next-date date max-days)))
 289     (planner-calendar-published-file-href
 290      (planner-calendar-date-to-filename next-date) name nop)))
 291
 292 (defun planner-calendar-prev-month-href (month year name &optional nop max-days)
 293   "Return an href anchor string for the last day page in the previous month."
 294   (let ((prev-date (planner-calendar-prev-date (list month 1 year) max-days))
 295         (muse-publish-desc-transforms nil))
 296     (planner-calendar-published-file-href
 297      (planner-calendar-date-to-filename prev-date) name nop)))
 298
 299 (defun planner-calendar-next-month-href (month year name &optional nop max-days)
 300   "Return an href anchor string for the first day page in the following month."
 301   (let ((next-date
 302          (planner-calendar-next-date
 303           (list month (calendar-last-day-of-month month year) year)
 304           max-days))
 305         (muse-publish-desc-transforms nil))
 306     (planner-calendar-published-file-href
 307      (planner-calendar-date-to-filename next-date) name nop)))
 308
 309 (defun planner-calendar-prev-day-wiki (&optional wiki max-days)
 310   "Return the first planner day page before this one."
 311   (let* ((page (or wiki (planner-page-name)))
 312          (date (planner-filename-to-calendar-date page)))
 313     (planner-calendar-date-to-filename
 314      (planner-calendar-prev-date date max-days))))
 315
 316 (defun planner-calendar-next-day-wiki (&optional wiki max-days)
 317   "Return the first planner day page after this one."
 318   (let* ((page (or wiki (planner-page-name)))
 319          (date (planner-filename-to-calendar-date page)))
 320     (planner-calendar-date-to-filename
 321      (planner-calendar-next-date date max-days))))
 322
 323 (defun planner-calendar-prev-date-href-from-wiki (name &optional wiki max-days)
 324   "Return an href anchor string for the first day page before this one."
 325   (let* ((page (or wiki (planner-page-name)))
 326          (date (planner-filename-to-calendar-date page)))
 327     (planner-calendar-prev-date-href date name max-days)))
 328
 329 (defun planner-calendar-next-date-href-from-wiki (name &optional wiki max-days)
 330   "Return an href anchor string for the first day page after this one."
 331   (let* ((page (or wiki (planner-page-name)))
 332          (date (planner-filename-to-calendar-date page)))
 333     (planner-calendar-next-date-href date name max-days)))
 334
 335 (defun planner-calendar-prev-month-href-from-wiki (name &optional wiki max-days)
 336   "Return a string for the last day page in first month before this one."
 337   (let* ((page (or wiki (planner-page-name)))
 338          (date (planner-filename-to-calendar-date page)))
 339     (planner-calendar-prev-month-href date name max-days)))
 340
 341 (defun planner-calendar-next-month-href-from-wiki (name &optional wiki max-days)
 342   "Return a string for the first day page in the first month after this one."
 343   (let* ((page (or wiki (planner-page-name)))
 344          (date (planner-filename-to-calendar-date page)))
 345     (planner-calendar-next-month-href date name max-days)))
 346
 347 (defun planner-calendar-insert-calendar-maybe ()
 348   "Insert the calendar on day pages.
 349 Add this to `muse-before-publish-hook'.  This can't be done from
 350 the page header, as header text is added after much of the page
 351 buffer has been marked up."
 352   (let ((page (planner-page-name)))
 353     (when (and page (string-match planner-date-regexp page))
 354       (goto-char (point-min))
 355       (insert "<calendar arrows=t>\n"))))
 356
 357 (defun planner-calendar-move-calendar-to-top-of-page-maybe ()
 358   "Move calendar to just after `planner-calendar-html-tag-marker'.
 359 Add this to `muse-after-publish-hook'."
 360   (when (string-match planner-date-regexp (or (planner-page-name) ""))
 361     (goto-char (point-min))
 362     (let* ((inhibit-read-only t)
 363            (body (and (search-forward planner-calendar-html-tag-marker
 364                                       nil 'noerror)
 365                       (forward-line 1)
 366                       (point)))
 367            (start (save-excursion
 368                     (and (search-forward "<table class=\"month-calendar\"")
 369                          (forward-line 0)
 370                          (point))))
 371            (end (save-excursion
 372                   (and start
 373                        (goto-char start)
 374                        (search-forward "</table>")
 375                        (point))))
 376            (calendar (and start end
 377                         (buffer-substring start end))))
 378     (when (and body calendar)
 379       (delete-region start end)
 380       (goto-char body)
 381       (planner-insert-markup calendar (string-match planner-date-regexp
 382                                                     (planner-page-name)))))))
 383
 384 (defun planner-publish-calendar-tag (beg end attrs)
 385   (let ((arrows (cdr (assoc "arrows" attrs)))
 386         (wiki (cdr (assoc "wiki" attrs))))
 387     (delete-region beg end)
 388     (planner-insert-markup (planner-calendar-from-wiki arrows wiki))
 389     (muse-publish-mark-read-only beg (point))))
 390
 391 (add-to-list 'planner-publish-markup-tags
 392              '("calendar" nil t planner-publish-calendar-tag)
 393              t)
 394
 395 (provide 'planner-calendar)
 396
 397 ;;; planner-calendar.el ends here
 398 ;;
 399 ;; Local Variables:
 400 ;; indent-tabs-mode: t
 401 ;; tab-width: 8
 402 ;; End: