Fix problem introduced by recent commit that broke using SPC as separator.
[planner-el.git] / planner-calendar.el
blob7fd9d09bc1f3a43dea02a6199256d1093ea176c0
1 ;;; planner-calendar.el --- Create a clickable calendar in published html
3 ;; Copyright (C) 2003, 2004, 2008 Gary V. Vaughan (gary AT gnu DOT org)
4 ;; Parts copyright (C) 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
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: Emacs20, Emacs21, Emacs22, XEmacs21
15 ;; This file is part of Planner. It is not part of GNU Emacs.
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 3, or (at your option)
20 ;; any later version.
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.
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.
32 ;;; Commentary:
34 ;; You will need to install Emacs Muse before this is of any use to
35 ;; you.
37 ;; To publish calendars in your day pages, it is necessary to do two
38 ;; steps.
40 ;; 1. Add (require 'planner-calendar) to your configuration.
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.
46 ;; If you decide to create a today link for published planner pages,
47 ;; add a hook function like this:
49 ;; (eval-after-load "muse-publish"
50 ;; '(add-hook 'muse-after-publish-hook
51 ;; 'planner-calendar-create-today-link))
53 ;;; Contributors:
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.
59 ;;; Code:
61 (require 'calendar)
62 (require 'muse)
63 (require 'planner)
65 (eval-when-compile
66 (require 'planner-publish))
68 (defgroup planner-calendar nil
69 "Options controlling the behaviour of planner calendar publication."
70 :group 'planner)
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)
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)
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)
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)
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)
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)
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))
116 (put 'planner-calendar-render 'lisp-indent-function 1)
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)))
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)
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"
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))
166 "</tr>\n"
167 "<tr>\n"
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;")
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))
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;"))
192 "</tr>\n"
193 "</table>\n")))
194 string))
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)
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))))
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)))
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)))
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)))
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))))
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))))
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)))
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)))
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)))
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)))
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-publish-ignore-url-desc-specials t))
317 (planner-calendar-published-file-href
318 (planner-calendar-date-to-filename prev-date) name nop)))
320 (defun planner-calendar-next-month-href (month year name &optional nop max-days)
321 "Return an href anchor string for the first day page in the following month."
322 (let ((next-date
323 (planner-calendar-next-date
324 (list month (calendar-last-day-of-month month year) year)
325 max-days))
326 (muse-publish-desc-transforms nil)
327 (planner-publish-ignore-url-desc-specials t))
328 (planner-calendar-published-file-href
329 (planner-calendar-date-to-filename next-date) name nop)))
331 (defun planner-calendar-prev-day-page (&optional page max-days)
332 "Return the first planner day page before this one."
333 (unless page (setq page (planner-page-name)))
334 (let ((date (planner-filename-to-calendar-date page)))
335 (planner-calendar-date-to-filename
336 (planner-calendar-prev-date date max-days))))
338 (defun planner-calendar-next-day-page (&optional page max-days)
339 "Return the first planner day page after this one."
340 (unless page (setq page (planner-page-name)))
341 (let ((date (planner-filename-to-calendar-date page)))
342 (planner-calendar-date-to-filename
343 (planner-calendar-next-date date max-days))))
345 (defun planner-calendar-prev-date-href-from-page (name &optional page max-days)
346 "Return an href anchor string for the first day page before this one."
347 (unless page (setq page (planner-page-name)))
348 (let ((date (planner-filename-to-calendar-date page)))
349 (planner-calendar-prev-date-href date name max-days)))
351 (defun planner-calendar-next-date-href-from-page (name &optional page max-days)
352 "Return an href anchor string for the first day page after this one."
353 (unless page (setq page (planner-page-name)))
354 (let ((date (planner-filename-to-calendar-date page)))
355 (planner-calendar-next-date-href date name max-days)))
357 (defun planner-calendar-prev-month-href-from-page (name &optional page max-days)
358 "Return a string for the last day page in first month before this one."
359 (unless page (setq page (planner-page-name)))
360 (let ((date (planner-filename-to-calendar-date page)))
361 (planner-calendar-prev-month-href date name max-days)))
363 (defun planner-calendar-next-month-href-from-page (name &optional page max-days)
364 "Return a string for the first day page in the first month after this one."
365 (unless page (setq page (planner-page-name)))
366 (let ((date (planner-filename-to-calendar-date page)))
367 (planner-calendar-next-month-href date name max-days)))
369 (defun planner-publish-calendar-tag (beg end attrs)
370 (let* ((arrows (cdr (assoc "arrows" attrs)))
371 (page (cdr (assoc "page" attrs)))
372 (calendar (planner-calendar-from-page arrows page)))
373 (delete-region beg end)
374 (when calendar
375 (planner-insert-markup "<div class=\"calendar\">\n")
376 (planner-insert-markup calendar)
377 (planner-insert-markup "</div>\n"))))
379 (eval-after-load "planner-publish"
380 '(progn
381 (add-to-list 'planner-publish-markup-tags
382 '("calendar" nil t nil planner-publish-calendar-tag)
384 (add-to-list 'planner-publish-finalize-regexps
385 '(200 "<\\(calendar\\)\\(\\s-+[^<>\n]+[^</>\n]\\)?\\(/\\)?>"
386 0 muse-publish-markup-tag))))
388 (provide 'planner-calendar)
390 ;;; planner-calendar.el ends here
392 ;; Local Variables:
393 ;; indent-tabs-mode: t
394 ;; tab-width: 8
395 ;; End: