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 ;; To publish calendars in your day pages, it is necessary to do two
  38 ;; steps.
  39 ;;
  40 ;; 1. Add (require 'planner-calendar) to your configuration.
  41 ;;
  42 ;; 2. Add a <calendar> tag to either your header, footer, or
  43 ;;    `planner-day-page-template', depending on where you want it to
  44 ;;    appear.
  45
  46 ;; If you decide to create a today link for published planner pages,
  47 ;; add a hook function like this:
  48 ;;
  49 ;;   (eval-after-load "muse-publish"
  50 ;;     '(add-hook 'muse-after-publish-hook
  51 ;;                'planner-calendar-create-today-link))
  52
  53 ;;; Contributors:
  54
  55 ;; drkm <darkman_spam@yahoo.fr> contributed a small patch that fixes a
  56 ;; planner-calendar boundary case when last day of the month is
  57 ;; Sunday.
  58
  59 ;;; Code:
  60
  61 (require 'calendar)
  62 (require 'muse)
  63 (require 'planner)
  64
  65 (eval-when-compile
  66   (require 'planner-publish))
  67
  68 (defgroup planner-calendar nil
  69   "Options controlling the behaviour of planner calendar publication."
  70   :group 'planner)
  71
  72 (defcustom planner-calendar-prev-month-button "&laquo;"
  73   "*Default html entity to use for previous month buttons."
  74   :type 'string
  75   :group 'planner-calendar)
  76
  77 (defcustom planner-calendar-next-month-button "&raquo;"
  78   "*Default html entity to use for next month buttons."
  79   :type 'string
  80   :group 'planner-calendar)
  81
  82 (defcustom planner-calendar-day-header-chars 3
  83   "*Default number of characters to use for day column header names."
  84   :type 'integer
  85   :group 'planner-calendar)
  86
  87 (defcustom planner-calendar-html-tag-marker "<div id=\"content\">"
  88   "*Default html block element to add calendar HTML to."
  89   :type 'string
  90   :group 'planner-calendar)
  91
  92 (defcustom planner-calendar-today-page-name "today"
  93   "*Default base name for published today page link file."
  94   :type 'string
  95   :group 'planner-calendar)
  96
  97 (defcustom planner-calendar-nop-buttons-flag t
  98   "Non-nil means add <nop> tags before navigation buttons in the calendar."
  99   :type 'boolean
 100   :group 'planner-calendar)
 101
 102 (defmacro planner-calendar-render (var begin end tag class &rest body)
 103   "Generate a row of days for the calendar."
 104   `(let (string)
 105      (calendar-for-loop ,var from ,begin to ,end do
 106       (let ((day (mod (+ calendar-week-start-day i) 7))
 107             (wrap-p (and (= 6 (mod ,var 7)) (/= ,var ,end))))
 108         (setq string (concat string
 109                              "<" ,tag " class=\"" ,class " "
 110                              (calendar-day-name day nil t) "\">"
 111                              ,@body
 112                              "</" ,tag ">\n"
 113                              (and wrap-p "</tr>\n<tr>\n")))))
 114      string))
 115
 116 (put 'planner-calendar-render 'lisp-indent-function 1)
 117
 118 (defun planner-calendar-date-to-filename (date)
 119   "See `planner-date-to-filename' except don't choke on nil DATE."
 120   (and date (planner-date-to-filename date)))
 121
 122 ;; calendar-week-start-day
 123 (defun planner-calendar (month year &optional arrows)
 124   "Generate a string of html to render a clickable calendar for MONTH YEAR.
 125 If ARROWS is non-nil, include prev/next month arrows."
 126   (let*
 127       ((blank-days                      ; at start of month
 128         (mod (- (calendar-day-of-week (list month 1 year))
 129                 calendar-week-start-day)
 130          7))
 131        (last (calendar-last-day-of-month month year))
 132        (pad-days                        ; at end of month
 133         (- 7 (1+ (calendar-day-of-week (list month last year)))))
 134        ;; don't use leading whitespace in the generated html, or the
 135        ;; other markup rules will add <blockquote> sections!
 136        (string
 137         (concat
 138          "<table class=\"month-calendar\">\n"
 139          "<tr class=\"month-calendar-head\">\n"
 140          (if arrows
 141              (concat
 142               "<th>"
 143               (planner-calendar-prev-month-href
 144                month year
 145                planner-calendar-prev-month-button
 146                planner-calendar-nop-buttons-flag)
 147               "</th>\n"
 148               "<th colspan=\"5\">\n")
 149            "<th colspan=\"7\">\n")
 150          (format "%s %d" (calendar-month-name month) year)
 151          "</th>\n"
 152          (when arrows
 153            (concat "<th>"
 154                    (planner-calendar-next-month-href
 155                     month year planner-calendar-next-month-button
 156                     planner-calendar-nop-buttons-flag)
 157                    "</th>\n"))
 158          "</tr>\n"
 159          "<tr>\n"
 160
 161          ;; add day name headings
 162          (planner-calendar-render i 0 6
 163           "th" "month-calendar-day-head"
 164           (calendar-day-name day planner-calendar-day-header-chars t))
 165
 166          "</tr>\n"
 167          "<tr>\n"
 168
 169          ;; add blank days before the first of the month
 170          (planner-calendar-render i 0 (1- blank-days)
 171           "td" "month-calendar-day-noday" "&nbsp;")
 172
 173          ;; put in the days of the month
 174          (planner-calendar-render i blank-days (+ last blank-days -1)
 175              "td" (if (planner-page-file
 176                        (planner-calendar-date-to-filename
 177                         (list month (- i blank-days -1) year)))
 178                       "month-calendar-day-link"
 179                     "month-calendar-day-nolink")
 180              (planner-calendar-published-file-href
 181                       (planner-calendar-date-to-filename
 182                        (list month (- i blank-days -1) year))
 183                       (int-to-string (- i blank-days -1))
 184                       planner-calendar-nop-buttons-flag))
 185
 186          ;; add padding days at end of month to make rule lines neat
 187          (unless (zerop (mod (+ blank-days last) 7))
 188            (planner-calendar-render i
 189              (+ last blank-days) (+ last blank-days pad-days -1)
 190              "td" "month-calendar-day-noday" "&nbsp;"))
 191
 192          "</tr>\n"
 193          "</table>\n")))
 194     string))
 195
 196 (defun planner-calendar-coerce-day-page (&optional page)
 197   "Figure out what day page to use, based on PAGE."
 198   (save-match-data
 199     (unless page
 200       (or (and (setq page (planner-page-name))
 201                (stringp page)
 202                (string-match planner-date-regexp page))
 203           (setq page (planner-today)))))
 204   page)
 205
 206 (defun planner-calendar-from-page (&optional arrows page)
 207   "Generate a string of html (possibly with ARROWS) for a calendar for PAGE."
 208   (setq page (planner-calendar-coerce-day-page page))
 209   (when (and (stringp page)
 210              (save-match-data (string-match planner-date-regexp page)))
 211     (let ((year (string-to-number (substring page 0 4)))
 212           (month (string-to-number (substring page 5 7))))
 213       (planner-calendar month year arrows))))
 214
 215 (defun planner-calendar-published-file-href (page &optional name nop)
 216   "Return an href anchor string to the published PAGE if PAGE exists."
 217   (if (and (stringp page)
 218            (planner-page-file page)
 219            (not (planner-private-p (planner-page-file page))))
 220       (planner-link-href page (or name page))
 221     (or name page)))
 222
 223 (defun planner-calendar-yesterday (date)
 224   "Return the day before DATE as a (month day year) list."
 225   (let* ((year (extract-calendar-year date))
 226          (month (extract-calendar-month date))
 227          (day (extract-calendar-day date))
 228          (prev-year (if (and (= 1 month) (= 1 day)) (1- year) year))
 229          (prev-month (if (= 1 day) (1+ (mod (+ month 10) 12)) month))
 230          (prev-day (if (= 1 day)
 231                        (calendar-last-day-of-month prev-month prev-year)
 232                      (1- day))))
 233     (list prev-month prev-day prev-year)))
 234
 235 (defun planner-calendar-tomorrow (date)
 236   "Return the day after DATE as a (month day year) list."
 237   (let* ((year (extract-calendar-year date))
 238          (month (extract-calendar-month date))
 239          (day (extract-calendar-day date))
 240          (last-day (calendar-last-day-of-month month year))
 241          (next-year
 242           (if (and (= 12 month) (= 31 day))
 243               (1+ year)
 244             year))
 245          (next-month
 246           (if (>= day last-day)
 247               (1+ (mod month 12))
 248             month))
 249          (next-day (if (< day last-day) (1+ day) 1)))
 250     (list next-month next-day next-year)))
 251
 252 (defun planner-calendar-today (&optional max-days)
 253   "Return today or the first day before today with a day page."
 254   (planner-calendar-prev-date
 255    (planner-calendar-tomorrow (calendar-current-date))))
 256
 257 (defun planner-calendar-create-today-link (&optional name)
 258   "Create a link to the newest published day page.
 259 Add this to `muse-after-publish-hook' to create a \"today\" soft
 260 link to the newest published planner day page, on operating systems that
 261 support POSIX \"ln\"."
 262   (let* ((today-name planner-calendar-today-page-name)
 263          (target-file (planner-published-file (or name today-name)))
 264          (source-file (planner-published-file
 265                        (planner-calendar-date-to-filename
 266                         (planner-calendar-today)))))
 267     (when (and (stringp target-file)
 268                (stringp source-file)
 269                (file-exists-p source-file))
 270       (when (file-exists-p target-file)
 271         (funcall planner-delete-file-function target-file))
 272       (make-symbolic-link source-file target-file t))))
 273
 274 (defun planner-calendar-prev-date (date &optional max-days)
 275   "Return the first day before DATE with a day page."
 276   (let ((days (or max-days 180))
 277         (yesterday date)
 278         (done nil))
 279     (while (and (not done) (> days 0))
 280       (setq yesterday (planner-calendar-yesterday yesterday)
 281             days (1- days))
 282       (let ((page (planner-calendar-date-to-filename yesterday)))
 283         (setq done (and (planner-page-file page)
 284                         (not (planner-private-p (planner-page-file page)))))))
 285     (if done yesterday nil)))
 286
 287 (defun planner-calendar-next-date (date &optional max-days)
 288   "Return the first day after DATE with a day page."
 289   (let ((days (or max-days 180))
 290         (tomorrow date)
 291         (done nil))
 292     (while (and (not done) (> days 0))
 293       (setq tomorrow (planner-calendar-tomorrow tomorrow)
 294             days (1- days))
 295       (let ((page (planner-calendar-date-to-filename tomorrow)))
 296         (setq done (and (planner-page-file page)
 297                         (not (planner-private-p (planner-page-file page)))))))
 298     (if done tomorrow nil)))
 299
 300 (defun planner-calendar-prev-date-href (date name &optional nop max-days)
 301   "Return an href anchor string for the first day page before DATE."
 302   (let ((prev-date (planner-calendar-prev-date date max-days)))
 303     (planner-calendar-published-file-href
 304      (planner-calendar-date-to-filename prev-date) name nop)))
 305
 306 (defun planner-calendar-next-date-href (date name &optional nop max-days)
 307   "Return an href anchor string for the first day page after DATE."
 308   (let ((next-date (planner-calendar-next-date date max-days)))
 309     (planner-calendar-published-file-href
 310      (planner-calendar-date-to-filename next-date) name nop)))
 311
 312 (defun planner-calendar-prev-month-href (month year name &optional nop max-days)
 313   "Return an href anchor string for the last day page in the previous month."
 314   (let ((prev-date (planner-calendar-prev-date (list month 1 year) max-days))
 315         (muse-publish-desc-transforms nil))
 316     (planner-calendar-published-file-href
 317      (planner-calendar-date-to-filename prev-date) name nop)))
 318
 319 (defun planner-calendar-next-month-href (month year name &optional nop max-days)
 320   "Return an href anchor string for the first day page in the following month."
 321   (let ((next-date
 322          (planner-calendar-next-date
 323           (list month (calendar-last-day-of-month month year) year)
 324           max-days))
 325         (muse-publish-desc-transforms nil))
 326     (planner-calendar-published-file-href
 327      (planner-calendar-date-to-filename next-date) name nop)))
 328
 329 (defun planner-calendar-prev-day-page (&optional page max-days)
 330   "Return the first planner day page before this one."
 331   (unless page (setq page (planner-page-name)))
 332   (let ((date (planner-filename-to-calendar-date page)))
 333     (planner-calendar-date-to-filename
 334      (planner-calendar-prev-date date max-days))))
 335
 336 (defun planner-calendar-next-day-page (&optional page max-days)
 337   "Return the first planner day page after this one."
 338   (unless page (setq page (planner-page-name)))
 339   (let ((date (planner-filename-to-calendar-date page)))
 340     (planner-calendar-date-to-filename
 341      (planner-calendar-next-date date max-days))))
 342
 343 (defun planner-calendar-prev-date-href-from-page (name &optional page max-days)
 344   "Return an href anchor string for the first day page before this one."
 345   (unless page (setq page (planner-page-name)))
 346   (let ((date (planner-filename-to-calendar-date page)))
 347     (planner-calendar-prev-date-href date name max-days)))
 348
 349 (defun planner-calendar-next-date-href-from-page (name &optional page max-days)
 350   "Return an href anchor string for the first day page after this one."
 351   (unless page (setq page (planner-page-name)))
 352   (let ((date (planner-filename-to-calendar-date page)))
 353     (planner-calendar-next-date-href date name max-days)))
 354
 355 (defun planner-calendar-prev-month-href-from-page (name &optional page max-days)
 356   "Return a string for the last day page in first month before this one."
 357   (unless page (setq page (planner-page-name)))
 358   (let ((date (planner-filename-to-calendar-date page)))
 359     (planner-calendar-prev-month-href date name max-days)))
 360
 361 (defun planner-calendar-next-month-href-from-page (name &optional page max-days)
 362   "Return a string for the first day page in the first month after this one."
 363   (unless page (setq page (planner-page-name)))
 364   (let ((date (planner-filename-to-calendar-date page)))
 365     (planner-calendar-next-month-href date name max-days)))
 366
 367 (defun planner-publish-calendar-tag (beg end attrs)
 368   (let* ((arrows (cdr (assoc "arrows" attrs)))
 369          (page (cdr (assoc "page" attrs)))
 370          (calendar (planner-calendar-from-page arrows page)))
 371     (delete-region beg end)
 372     (when calendar
 373       (planner-insert-markup "<div class=\"calendar\">\n")
 374       (planner-insert-markup calendar)
 375       (planner-insert-markup "</div>\n"))))
 376
 377 (eval-after-load "planner-publish"
 378   '(progn
 379      (if (featurep 'muse-nested-tags)
 380          (add-to-list 'planner-publish-markup-tags
 381                       '("calendar" nil t nil planner-publish-calendar-tag)
 382                       t)
 383        (add-to-list 'planner-publish-markup-tags
 384                     '("calendar" nil t planner-publish-calendar-tag)
 385                     t))
 386      (add-to-list 'planner-publish-finalize-regexps
 387                   '(200 "<\\(calendar\\)\\(\\s-+[^<>\n]+[^</>\n]\\)?\\(/\\)?>"
 388                         0 muse-publish-markup-tag))))
 389
 390 (provide 'planner-calendar)
 391
 392 ;;; planner-calendar.el ends here
 393 ;;
 394 ;; Local Variables:
 395 ;; indent-tabs-mode: t
 396 ;; tab-width: 8
 397 ;; End: