HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add arch taglines
[bpt/emacs.git] / lisp / calendar / diary-lib.el
CommitLineData
3afbc435 1;;; diary-lib.el --- diary functions
0808d911 2
c87a1f38
GM		 3;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2003
4;; Free Software Foundation, Inc.
0808d911
ER		 5
6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7;; Keywords: calendar
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
b578f267
EN		 22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
0808d911
ER		 25
26;;; Commentary:
27
28;; This collection of functions implements the diary features as described
29;; in calendar.el.
30
31;; Comments, corrections, and improvements should be sent to
32;; Edward M. Reingold Department of Computer Science
33;; (217) 333-6733 University of Illinois at Urbana-Champaign
34;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
35;; Urbana, Illinois 61801
36
37;;; Code:
38
39(require 'calendar)
40
c87a1f38
GM		 41(defun diary-check-diary-file ()
42 "Check that the file specified by `diary-file' exists and is readable.
43If so, return the expanded file name, otherwise signal an error."
44 (let ((d-file (substitute-in-file-name diary-file)))
45 (if (and d-file (file-exists-p d-file))
46 (if (file-readable-p d-file)
47 d-file
48 (error "Diary file `%s' is not readable" diary-file))
49 (error "Diary file `%s' does not exist" diary-file))))
50
0808d911
ER		 51;;;###autoload
52(defun diary (&optional arg)
53 "Generate the diary window for ARG days starting with the current date.
54If no argument is provided, the number of days of diary entries is governed
55by the variable `number-of-diary-entries'. This function is suitable for
56execution in a `.emacs' file."
57 (interactive "P")
c87a1f38
GM		 58 (diary-check-diary-file)
59 (let ((date (calendar-current-date)))
60 (list-diary-entries
61 date
62 (cond (arg (prefix-numeric-value arg))
63 ((vectorp number-of-diary-entries)
64 (aref number-of-diary-entries (calendar-day-of-week date)))
65 (t number-of-diary-entries)))))
0808d911
ER		 66
67(defun view-diary-entries (arg)
68 "Prepare and display a buffer with diary entries.
69Searches the file named in `diary-file' for entries that
70match ARG days starting with the date indicated by the cursor position
71in the displayed three-month calendar."
72 (interactive "p")
c87a1f38
GM		 73 (diary-check-diary-file)
74 (list-diary-entries (calendar-cursor-to-date t) arg))
0808d911 75
892e6825 76(defun view-other-diary-entries (arg d-file)
0808d911 77 "Prepare and display buffer of diary entries from an alternative diary file.
c87a1f38
GM		 78Searches for entries that match ARG days, starting with the date indicated
79by the cursor position in the displayed three-month calendar.
80D-FILE specifies the file to use as the diary file."
0808d911 81 (interactive
c87a1f38 82 (list (if arg (prefix-numeric-value arg) 1)
892e6825
ER		 83 (read-file-name "Enter diary file name: " default-directory nil t)))
84 (let ((diary-file d-file))
85 (view-diary-entries arg)))
0808d911
ER		 86
87(autoload 'check-calendar-holidays "holidays"
88 "Check the list of holidays for any that occur on DATE.
89The value returned is a list of strings of relevant holiday descriptions.
fd4a98f0 90The holidays are those in the list `calendar-holidays'.")
0808d911
ER		 91
92(autoload 'calendar-holiday-list "holidays"
93 "Form the list of holidays that occur on dates in the calendar window.
fd4a98f0 94The holidays are those in the list `calendar-holidays'.")
0808d911
ER		 95
96(autoload 'diary-french-date "cal-french"
fd4a98f0 97 "French calendar equivalent of date diary entry.")
0808d911
ER		 98
99(autoload 'diary-mayan-date "cal-mayan"
fd4a98f0 100 "Mayan calendar equivalent of date diary entry.")
0808d911 101
c36baedb 102(autoload 'diary-iso-date "cal-iso"
fd4a98f0 103 "ISO calendar equivalent of date diary entry.")
c36baedb 104
0808d911 105(autoload 'diary-julian-date "cal-julian"
fd4a98f0 106 "Julian calendar equivalent of date diary entry.")
0808d911
ER		 107
108(autoload 'diary-astro-day-number "cal-julian"
fd4a98f0 109 "Astronomical (Julian) day number diary entry.")
0808d911 110
327b6868 111(autoload 'diary-chinese-date "cal-china"
fd4a98f0 112 "Chinese calendar equivalent of date diary entry.")
0808d911 113
327b6868 114(autoload 'diary-islamic-date "cal-islam"
fd4a98f0 115 "Islamic calendar equivalent of date diary entry.")
0808d911 116
327b6868 117(autoload 'list-islamic-diary-entries "cal-islam"
fd4a98f0 118 "Add any Islamic date entries from the diary file to `diary-entries-list'.")
0808d911 119
327b6868 120(autoload 'mark-islamic-diary-entries "cal-islam"
fd4a98f0 121 "Mark days in the calendar window that have Islamic date diary entries.")
0808d911 122
327b6868 123(autoload 'mark-islamic-calendar-date-pattern "cal-islam"
fd4a98f0 124 "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.")
0808d911
ER		 125
126(autoload 'diary-hebrew-date "cal-hebrew"
fd4a98f0 127 "Hebrew calendar equivalent of date diary entry.")
0808d911
ER		 128
129(autoload 'diary-omer "cal-hebrew"
fd4a98f0 130 "Omer count diary entry.")
0808d911
ER		 131
132(autoload 'diary-yahrzeit "cal-hebrew"
fd4a98f0 133 "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.")
0808d911
ER		 134
135(autoload 'diary-parasha "cal-hebrew"
fd4a98f0 136 "Parasha diary entry--entry applies if date is a Saturday.")
0808d911
ER		 137
138(autoload 'diary-rosh-hodesh "cal-hebrew"
fd4a98f0 139 "Rosh Hodesh diary entry.")
0808d911
ER		 140
141(autoload 'list-hebrew-diary-entries "cal-hebrew"
fd4a98f0 142 "Add any Hebrew date entries from the diary file to `diary-entries-list'.")
0808d911
ER		 143
144(autoload 'mark-hebrew-diary-entries "cal-hebrew"
fd4a98f0 145 "Mark days in the calendar window that have Hebrew date diary entries.")
0808d911
ER		 146
147(autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew"
fd4a98f0 148 "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.")
0808d911
ER		 149
150(autoload 'diary-coptic-date "cal-coptic"
fd4a98f0 151 "Coptic calendar equivalent of date diary entry.")
0808d911
ER		 152
153(autoload 'diary-ethiopic-date "cal-coptic"
fd4a98f0 154 "Ethiopic calendar equivalent of date diary entry.")
0808d911 155
a45eee72 156(autoload 'diary-persian-date "cal-persia"
fd4a98f0 157 "Persian calendar equivalent of date diary entry.")
72fb78ce 158
fd4a98f0 159(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry.")
0808d911
ER		 160
161(autoload 'diary-sunrise-sunset "solar"
fd4a98f0 162 "Local time of sunrise and sunset as a diary entry.")
0808d911
ER		 163
164(autoload 'diary-sabbath-candles "solar"
165 "Local time of candle lighting diary entry--applies if date is a Friday.
fd4a98f0 166No diary entry if there is no sunset on that date.")
0808d911
ER		 167
168(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
169 "The syntax table used when parsing dates in the diary file.
170It is the standard syntax table used in Fundamental mode, but with the
c87a1f38 171syntax of `*' and `:' changed to be word constituents.")
0808d911
ER		 172
173(modify-syntax-entry ?* "w" diary-syntax-table)
cfd1d0ec 174(modify-syntax-entry ?: "w" diary-syntax-table)
0808d911 175
ee58da1b
SS		 176(defvar diary-entries-list)
177(defvar displayed-year)
178(defvar displayed-month)
179(defvar entry)
180(defvar date)
181(defvar number)
182(defvar date-string)
ee58da1b
SS		 183(defvar original-date)
184
c47a201a 185(defun diary-attrtype-convert (attrvalue type)
c87a1f38
GM		 186 "Convert string ATTRVALUE to TYPE appropriate for a face description.
187Valid TYPEs are: string, symbol, int, stringtnil, tnil."
c47a201a
JB		 188 (let (ret)
189 (setq ret (cond ((eq type 'string) attrvalue)
190 ((eq type 'symbol) (read attrvalue))
191 ((eq type 'int) (string-to-int attrvalue))
192 ((eq type 'stringtnil)
193 (cond ((string= "t" attrvalue) t)
194 ((string= "nil" attrvalue) nil)
195 (t attrvalue)))
196 ((eq type 'tnil)
197 (cond ((string= "t" attrvalue) t)
198 ((string= "nil" attrvalue) nil)))))
199; (message "(%s)[%s]=[%s]" (print type) attrvalue ret)
200 ret))
4e80f517 201
c47a201a
JB		 202
203(defun diary-pull-attrs (entry fileglobattrs)
4e80f517
SS		 204 "Pull the face-related attributes off the entry, merge with the
205fileglobattrs, and return the (possibly modified) entry and face
206data in a list of attrname attrvalue values.
c47a201a 207The entry will be modified to drop all tags that are used for face matching.
4e80f517
SS		 208If entry is nil, then the fileglobattrs are being searched for,
209the fileglobattrs variable is ignored, and
210diary-glob-file-regexp-prefix is prepended to the regexps before each
c47a201a
JB		 211search."
212 (save-excursion
61d094de
GM		 213 (let (regexp regnum attrname attr-list attrname attrvalue type
214 ret-attr attr)
c47a201a
JB		 215 (if (null entry)
216 (progn
217 (setq ret-attr '()
218 attr-list diary-face-attrs)
219 (while attr-list
220 (goto-char (point-min))
221 (setq attr (car attr-list)
222 regexp (nth 0 attr)
223 regnum (nth 1 attr)
224 attrname (nth 2 attr)
225 type (nth 3 attr)
226 regexp (concat diary-glob-file-regexp-prefix regexp))
227 (setq attrvalue nil)
228 (if (re-search-forward regexp (point-max) t)
229 (setq attrvalue (buffer-substring-no-properties
230 (match-beginning regnum)
231 (match-end regnum))))
232 (if (and attrvalue
233 (setq attrvalue (diary-attrtype-convert attrvalue type)))
234 (setq ret-attr (append ret-attr (list attrname attrvalue))))
235 (setq attr-list (cdr attr-list)))
236 (setq fileglobattrs ret-attr))
237 (progn
238 (setq ret-attr fileglobattrs
239 attr-list diary-face-attrs)
240 (while attr-list
241 (goto-char (point-min))
242 (setq attr (car attr-list)
243 regexp (nth 0 attr)
244 regnum (nth 1 attr)
245 attrname (nth 2 attr)
246 type (nth 3 attr))
247 (setq attrvalue nil)
248 (if (string-match regexp entry)
4e80f517 249 (progn
c47a201a
JB		 250 (setq attrvalue (substring-no-properties entry
251 (match-beginning regnum)
252 (match-end regnum)))
253 (setq entry (replace-match "" t t entry))))
254 (if (and attrvalue
255 (setq attrvalue (diary-attrtype-convert attrvalue type)))
256 (setq ret-attr (append ret-attr (list attrname attrvalue))))
61d094de
GM		 257 (setq attr-list (cdr attr-list)))))
258 (list entry ret-attr))))
4e80f517
SS		 259
260
c47a201a 261
0808d911
ER		 262(defun list-diary-entries (date number)
263 "Create and display a buffer containing the relevant lines in diary-file.
264The arguments are DATE and NUMBER; the entries selected are those
265for NUMBER days starting with date DATE. The other entries are hidden
266using selective display.
267
268Returns a list of all relevant diary entries found, if any, in order by date.
a14723d9
KH		 269The list entries have the form ((month day year) string specifier) where
270\(month day year) is the date of the entry, string is the entry text, and
271specifier is the applicability. If the variable `diary-list-include-blanks'
272is t, this list includes a dummy diary entry consisting of the empty string)
273for a date with no diary entries.
0808d911
ER		 274
275After the list is prepared, the hooks `nongregorian-diary-listing-hook',
276`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
277These hooks have the following distinct roles:
278
279 `nongregorian-diary-listing-hook' can cull dates from the diary
280 and each included file. Usually used for Hebrew or Islamic
281 diary entries in files. Applied to *each* file.
282
283 `list-diary-entries-hook' adds or manipulates diary entries from
284 external sources. Used, for example, to include diary entries
285 from other files or to sort the diary entries. Invoked *once* only,
286 before the display hook is run.
287
288 `diary-display-hook' does the actual display of information. If this is
289 nil, simple-diary-display will be used. Use add-hook to set this to
290 fancy-diary-display, if desired. If you want no diary display, use
291 add-hook to set this to ignore.
292
293 `diary-hook' is run last. This can be used for an appointment
294 notification function."
295
296 (if (< 0 number)
c87a1f38
GM		 297 (let ((original-date date);; save for possible use in the hooks
298 old-diary-syntax-table
299 diary-entries-list
300 file-glob-attrs
301 (date-string (calendar-date-string date))
302 (d-file (substitute-in-file-name diary-file)))
0808d911
ER		 303 (message "Preparing diary...")
304 (save-excursion
cdfeb73f 305 (let ((diary-buffer (find-buffer-visiting d-file)))
ca67b44e
RS		 306 (if (not diary-buffer)
307 (set-buffer (find-file-noselect d-file t))
308 (set-buffer diary-buffer)
309 (or (verify-visited-file-modtime diary-buffer)
310 (revert-buffer t t))))
c47a201a 311 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
0808d911
ER		 312 (setq selective-display t)
313 (setq selective-display-ellipses nil)
314 (setq old-diary-syntax-table (syntax-table))
315 (set-syntax-table diary-syntax-table)
316 (unwind-protect
317 (let ((buffer-read-only nil)
318 (diary-modified (buffer-modified-p))
319 (mark (regexp-quote diary-nonmarking-symbol)))
7d3ff869
GM		 320 ;; First and last characters must be ^M or \n for
321 ;; selective display to work properly
0808d911
ER		 322 (goto-char (1- (point-max)))
323 (if (not (looking-at "\^M\\|\n"))
324 (progn
7d3ff869 325 (goto-char (point-max))
4cf95c44 326 (insert "\^M")))
0808d911
ER		 327 (goto-char (point-min))
328 (if (not (looking-at "\^M\\|\n"))
4cf95c44 329 (insert "\^M"))
0808d911
ER		 330 (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
331 (calendar-for-loop i from 1 to number do
332 (let ((d diary-date-forms)
333 (month (extract-calendar-month date))
334 (day (extract-calendar-day date))
335 (year (extract-calendar-year date))
336 (entry-found (list-sexp-diary-entries date)))
337 (while d
338 (let*
339 ((date-form (if (equal (car (car d)) 'backup)
340 (cdr (car d))
341 (car d)))
342 (backup (equal (car (car d)) 'backup))
343 (dayname
ca2a5950
GM		 344 (format "%s\\|%s\\.?"
345 (calendar-day-name date)
346 (calendar-day-name date 'abbrev)))
0808d911 347 (monthname
ca2a5950
GM		 348 (format "\\*\\|%s\\|%s\\.?"
349 (calendar-month-name month)
350 (calendar-month-name month 'abbrev)))
0808d911
ER		 351 (month (concat "\\*\\|0*" (int-to-string month)))
352 (day (concat "\\*\\|0*" (int-to-string day)))
353 (year
354 (concat
355 "\\*\\|0*" (int-to-string year)
356 (if abbreviated-calendar-year
e65fc107 357 (concat "\\|" (format "%02d" (% year 100)))
0808d911
ER		 358 "")))
359 (regexp
360 (concat
361 "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
362 (mapconcat 'eval date-form "\\)\\(")
363 "\\)"))
364 (case-fold-search t))
365 (goto-char (point-min))
366 (while (re-search-forward regexp nil t)
367 (if backup (re-search-backward "\\<" nil t))
368 (if (and (or (char-equal (preceding-char) ?\^M)
369 (char-equal (preceding-char) ?\n))
370 (not (looking-at " \\|\^I")))
371 ;; Diary entry that consists only of date.
372 (backward-char 1)
373 ;; Found a nonempty diary entry--make it visible and
374 ;; add it to the list.
375 (setq entry-found t)
376 (let ((entry-start (point))
61d094de 377 date-start temp)
0808d911
ER		 378 (re-search-backward "\^M\\|\n\\|\\`")
379 (setq date-start (point))
380 (re-search-forward "\^M\\|\n" nil t 2)
381 (while (looking-at " \\|\^I")
382 (re-search-forward "\^M\\|\n" nil t))
383 (backward-char 1)
384 (subst-char-in-region date-start
385 (point) ?\^M ?\n t)
c47a201a
JB		 386 (setq entry (buffer-substring entry-start (point))
387 temp (diary-pull-attrs entry file-glob-attrs)
61d094de 388 entry (nth 0 temp))
0808d911 389 (add-to-diary-list
a14723d9 390 date
c47a201a 391 entry
c1b0dc0c 392 (buffer-substring
86432f81 393 (1+ date-start) (1- entry-start))
61d094de 394 (copy-marker entry-start) (nth 1 temp))))))
0808d911
ER		 395 (setq d (cdr d)))
396 (or entry-found
397 (not diary-list-include-blanks)
4dd618ff 398 (setq diary-entries-list
0808d911 399 (append diary-entries-list
c47a201a 400 (list (list date "" "" "" "")))))
0808d911
ER		 401 (setq date
402 (calendar-gregorian-from-absolute
403 (1+ (calendar-absolute-from-gregorian date))))
404 (setq entry-found nil)))
405 (set-buffer-modified-p diary-modified))
406 (set-syntax-table old-diary-syntax-table))
407 (goto-char (point-min))
408 (run-hooks 'nongregorian-diary-listing-hook
409 'list-diary-entries-hook)
410 (if diary-display-hook
411 (run-hooks 'diary-display-hook)
412 (simple-diary-display))
413 (run-hooks 'diary-hook)
414 diary-entries-list))))
415
416(defun include-other-diary-files ()
417 "Include the diary entries from other diary files with those of diary-file.
418This function is suitable for use in `list-diary-entries-hook';
419it enables you to use shared diary files together with your own.
420The files included are specified in the diaryfile by lines of this form:
421 #include \"filename\"
422This is recursive; that is, #include directives in diary files thus included
423are obeyed. You can change the `#include' to some other string by
424changing the variable `diary-include-string'."
425 (goto-char (point-min))
426 (while (re-search-forward
427 (concat
428 "\\(\\`\\|\^M\\|\n\\)"
429 (regexp-quote diary-include-string)
430 " \"\\([^\"]*\\)\"")
431 nil t)
cb8325bf
GM		 432 (let* ((diary-file (substitute-in-file-name
433 (buffer-substring-no-properties
434 (match-beginning 2) (match-end 2))))
435 (diary-list-include-blanks nil)
436 (list-diary-entries-hook 'include-other-diary-files)
437 (diary-display-hook 'ignore)
438 (diary-hook nil)
439 (d-buffer (find-buffer-visiting diary-file))
440 (diary-modified (if d-buffer
441 (save-excursion
442 (set-buffer d-buffer)
443 (buffer-modified-p)))))
0808d911
ER		 444 (if (file-exists-p diary-file)
445 (if (file-readable-p diary-file)
446 (unwind-protect
447 (setq diary-entries-list
448 (append diary-entries-list
449 (list-diary-entries original-date number)))
8b431855
GM		 450 (save-excursion
451 (set-buffer (find-buffer-visiting diary-file))
73e19344
RS		 452 (let ((inhibit-read-only t))
453 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))
8b431855
GM		 454 (setq selective-display nil)
455 (set-buffer-modified-p diary-modified)))
0808d911
ER		 456 (beep)
457 (message "Can't read included diary file %s" diary-file)
458 (sleep-for 2))
459 (beep)
460 (message "Can't find included diary file %s" diary-file)
461 (sleep-for 2))))
462 (goto-char (point-min)))
463
464(defun simple-diary-display ()
465 "Display the diary buffer if there are any relevant entries or holidays."
466 (let* ((holiday-list (if holidays-in-diary-buffer
467 (check-calendar-holidays original-date)))
8ec6d48a
GM		 468 (hol-string (format "%s%s%s"
469 date-string
470 (if holiday-list ": " "")
471 (mapconcat 'identity holiday-list "; ")))
472 (msg (format "No diary entries for %s" hol-string))
473 ;; If selected window is dedicated (to the calendar),
474 ;; need a new one to display the diary.
475 (pop-up-frames (window-dedicated-p (selected-window))))
476 (calendar-set-mode-line (format "Diary for %s" hol-string))
0808d911
ER		 477 (if (or (not diary-entries-list)
478 (and (not (cdr diary-entries-list))
479 (string-equal (car (cdr (car diary-entries-list))) "")))
8ec6d48a 480 (if (< (length msg) (frame-width))
b3099c46 481 (message "%s" msg)
0808d911
ER		 482 (set-buffer (get-buffer-create holiday-buffer))
483 (setq buffer-read-only nil)
484 (calendar-set-mode-line date-string)
485 (erase-buffer)
486 (insert (mapconcat 'identity holiday-list "\n"))
487 (goto-char (point-min))
488 (set-buffer-modified-p nil)
489 (setq buffer-read-only t)
490 (display-buffer holiday-buffer)
491 (message "No diary entries for %s" date-string))
c87a1f38
GM		 492 (display-buffer (find-buffer-visiting
493 (substitute-in-file-name diary-file)))
0808d911
ER		 494 (message "Preparing diary...done"))))
495
86432f81
MR		 496(defface diary-button-face '((((type pc) (class color))
497 (:foreground "lightblue")))
ebea495a
MR		 498 "Default face used for buttons."
499 :version "21.4"
500 :group 'diary)
86432f81
MR		 501
502(define-button-type 'diary-entry
503 'action #'diary-goto-entry
504 'face #'diary-button-face)
505
506(defun diary-goto-entry (button)
507 (let ((marker (button-get button 'marker)))
508 (when marker
509 (pop-to-buffer (marker-buffer marker))
510 (goto-char (marker-position marker)))))
511
0808d911
ER		 512(defun fancy-diary-display ()
513 "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
514This function is provided for optional use as the `diary-display-hook'."
515 (save-excursion;; Turn off selective-display in the diary file's buffer.
cdfeb73f 516 (set-buffer (find-buffer-visiting (substitute-in-file-name diary-file)))
0808d911
ER		 517 (let ((diary-modified (buffer-modified-p)))
518 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
519 (setq selective-display nil)
520 (kill-local-variable 'mode-line-format)
521 (set-buffer-modified-p diary-modified)))
522 (if (or (not diary-entries-list)
523 (and (not (cdr diary-entries-list))
524 (string-equal (car (cdr (car diary-entries-list))) "")))
525 (let* ((holiday-list (if holidays-in-diary-buffer
526 (check-calendar-holidays original-date)))
527 (msg (format "No diary entries for %s %s"
528 (concat date-string (if holiday-list ":" ""))
529 (mapconcat 'identity holiday-list "; "))))
530 (if (<= (length msg) (frame-width))
b3099c46 531 (message "%s" msg)
0808d911
ER		 532 (set-buffer (get-buffer-create holiday-buffer))
533 (setq buffer-read-only nil)
534 (calendar-set-mode-line date-string)
535 (erase-buffer)
536 (insert (mapconcat 'identity holiday-list "\n"))
537 (goto-char (point-min))
538 (set-buffer-modified-p nil)
539 (setq buffer-read-only t)
540 (display-buffer holiday-buffer)
541 (message "No diary entries for %s" date-string)))
542 (save-excursion;; Prepare the fancy diary buffer.
543 (set-buffer (make-fancy-diary-buffer))
544 (setq buffer-read-only nil)
545 (let ((entry-list diary-entries-list)
546 (holiday-list)
547 (holiday-list-last-month 1)
548 (holiday-list-last-year 1)
549 (date (list 0 0 0)))
550 (while entry-list
551 (if (not (calendar-date-equal date (car (car entry-list))))
552 (progn
553 (setq date (car (car entry-list)))
554 (and holidays-in-diary-buffer
555 (calendar-date-compare
556 (list (list holiday-list-last-month
557 (calendar-last-day-of-month
558 holiday-list-last-month
559 holiday-list-last-year)
560 holiday-list-last-year))
561 (list date))
562 ;; We need to get the holidays for the next 3 months.
563 (setq holiday-list-last-month
564 (extract-calendar-month date))
565 (setq holiday-list-last-year
566 (extract-calendar-year date))
567 (increment-calendar-month
568 holiday-list-last-month holiday-list-last-year 1)
569 (setq holiday-list
570 (let ((displayed-month holiday-list-last-month)
571 (displayed-year holiday-list-last-year))
572 (calendar-holiday-list)))
573 (increment-calendar-month
574 holiday-list-last-month holiday-list-last-year 1))
575 (let* ((date-string (calendar-date-string date))
576 (date-holiday-list
577 (let ((h holiday-list)
578 (d))
579 ;; Make a list of all holidays for date.
580 (while h
581 (if (calendar-date-equal date (car (car h)))
582 (setq d (append d (cdr (car h)))))
583 (setq h (cdr h)))
584 d)))
585 (insert (if (= (point) (point-min)) "" ?\n) date-string)
586 (if date-holiday-list (insert ": "))
72fb78ce
ER		 587 (let* ((l (current-column))
588 (longest 0))
86855ebd
SM		 589 (insert (mapconcat (lambda (x)
590 (if (< longest (length x))
591 (setq longest (length x)))
592 x)
72fb78ce
ER		 593 date-holiday-list
594 (concat "\n" (make-string l ? ))))
595 (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
c47a201a
JB		 596
597 (setq entry (car (cdr (car entry-list))))
598 (if (< 0 (length entry))
599 (progn
600 (if (nth 3 (car entry-list))
601 (insert-button (concat entry "\n")
602 'marker (nth 3 (car entry-list))
603 :type 'diary-entry)
604 (insert entry ?\n))
605 (save-excursion
61d094de
GM		 606 (let* ((marks (nth 4 (car entry-list)))
607 (temp-face (make-symbol
608 (apply
609 'concat "temp-face-"
610 (mapcar '(lambda (sym)
611 (if (stringp sym)
612 sym
613 (symbol-name sym)))
614 marks))))
615 faceinfo)
616 ;; Remove :face info from the marks,
617 ;; copy the face info into temp-face
618 (setq faceinfo marks)
619 (while (setq faceinfo (memq :face faceinfo))
620 (copy-face (read (nth 1 faceinfo)) temp-face)
621 (setcar faceinfo nil)
622 (setcar (cdr faceinfo) nil))
623 (setq marks (delq nil marks))
c47a201a 624 ;; Apply the font aspects
61d094de
GM		 625 (apply 'set-face-attribute temp-face nil marks)
626 (search-backward entry)
627 (overlay-put
628 (make-overlay (match-beginning 0) (match-end 0))
629 'face temp-face)))))
c47a201a 630 (setq entry-list (cdr entry-list))))
0808d911
ER		 631 (set-buffer-modified-p nil)
632 (goto-char (point-min))
633 (setq buffer-read-only t)
634 (display-buffer fancy-diary-buffer)
86432f81 635 (fancy-diary-display-mode)
0808d911
ER		 636 (message "Preparing diary...done"))))
637
638(defun make-fancy-diary-buffer ()
639 "Create and return the initial fancy diary buffer."
640 (save-excursion
641 (set-buffer (get-buffer-create fancy-diary-buffer))
642 (setq buffer-read-only nil)
0808d911
ER		 643 (calendar-set-mode-line "Diary Entries")
644 (erase-buffer)
645 (set-buffer-modified-p nil)
646 (setq buffer-read-only t)
647 (get-buffer fancy-diary-buffer)))
648
649(defun print-diary-entries ()
650 "Print a hard copy of the diary display.
651
652If the simple diary display is being used, prepare a temp buffer with the
653visible lines of the diary buffer, add a heading line composed from the mode
654line, print the temp buffer, and destroy it.
655
656If the fancy diary display is being used, just print the buffer.
657
658The hooks given by the variable `print-diary-entries-hook' are called to do
659the actual printing."
660 (interactive)
661 (if (bufferp (get-buffer fancy-diary-buffer))
662 (save-excursion
663 (set-buffer (get-buffer fancy-diary-buffer))
664 (run-hooks 'print-diary-entries-hook))
665 (let ((diary-buffer
cdfeb73f 666 (find-buffer-visiting (substitute-in-file-name diary-file))))
0808d911
ER		 667 (if diary-buffer
668 (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
669 (heading))
670 (save-excursion
671 (set-buffer diary-buffer)
672 (setq heading
673 (if (not (stringp mode-line-format))
674 "All Diary Entries"
675 (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
676 (substring mode-line-format
677 (match-beginning 1) (match-end 1))))
678 (copy-to-buffer temp-buffer (point-min) (point-max))
679 (set-buffer temp-buffer)
680 (while (re-search-forward "\^M.*$" nil t)
681 (replace-match ""))
682 (goto-char (point-min))
683 (insert heading "\n"
684 (make-string (length heading) ?=) "\n")
685 (run-hooks 'print-diary-entries-hook)
686 (kill-buffer temp-buffer)))
687 (error "You don't have a diary buffer!")))))
688
689(defun show-all-diary-entries ()
690 "Show all of the diary entries in the diary file.
691This function gets rid of the selective display of the diary file so that
692all entries, not just some, are visible. If there is no diary buffer, one
693is created."
694 (interactive)
c87a1f38
GM		 695 (let ((d-file (diary-check-diary-file)))
696 (save-excursion
697 (set-buffer (or (find-buffer-visiting d-file)
698 (find-file-noselect d-file t)))
699 (let ((buffer-read-only nil)
700 (diary-modified (buffer-modified-p)))
701 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
702 (setq selective-display nil
703 mode-line-format default-mode-line-format)
704 (display-buffer (current-buffer))
705 (set-buffer-modified-p diary-modified)))))
8ffbfaa9 706
4dd618ff 707(defcustom diary-mail-addr
c87a1f38 708 (if (boundp 'user-mail-address) user-mail-address "")
8ffbfaa9
RS		 709 "*Email address that `diary-mail-entries' will send email to."
710 :group 'diary
c87a1f38 711 :type 'string
cd32a7ba 712 :version "20.3")
8ffbfaa9
RS		 713
714(defcustom diary-mail-days 7
c87a1f38 715 "*Default number of days for `diary-mail-entries' to check."
8ffbfaa9 716 :group 'diary
cd32a7ba
DN		 717 :type 'integer
718 :version "20.3")
8ffbfaa9 719
f91adf29 720;;;###autoload
8ffbfaa9
RS		 721(defun diary-mail-entries (&optional ndays)
722 "Send a mail message showing diary entries for next NDAYS days.
723If no prefix argument is given, NDAYS is set to `diary-mail-days'.
c87a1f38 724Mail is sent to the address specified by `diary-mail-addr'.
8ffbfaa9
RS		 725
726You can call `diary-mail-entries' every night using an at/cron job.
727For example, this script will run the program at 2am daily. Since
728`emacs -batch' does not load your `.emacs' file, you must ensure that
729all relevant variables are set, as done here.
730
731#!/bin/sh
732# diary-rem.sh -- repeatedly run the Emacs diary-reminder
733emacs -batch \\
734-eval \"(setq diary-mail-days 3 \\
c87a1f38 735 diary-file \\\"/path/to/diary.file\\\" \\
8ffbfaa9
RS		 736 european-calendar-style t \\
737 diary-mail-addr \\\"user@host.name\\\" )\" \\
4dd618ff 738-l diary-lib -f diary-mail-entries
8ffbfaa9
RS		 739at -f diary-rem.sh 0200 tomorrow
740
741You may have to tweak the syntax of the `at' command to suit your
742system. Alternatively, you can specify a cron entry:
7430 1 * * * diary-rem.sh
744to run it every morning at 1am."
d56aaa64 745 (interactive "P")
c87a1f38
GM		 746 (if (string-equal diary-mail-addr "")
747 (error "You must set `diary-mail-addr' to use this command")
748 (let ((diary-display-hook 'fancy-diary-display))
749 (list-diary-entries (calendar-current-date) (or ndays diary-mail-days)))
750 (compose-mail diary-mail-addr
751 (concat "Diary entries generated "
752 (calendar-date-string (calendar-current-date))))
753 (insert
754 (if (get-buffer fancy-diary-buffer)
755 (save-excursion
756 (set-buffer fancy-diary-buffer)
757 (buffer-substring (point-min) (point-max)))
758 "No entries found"))
759 (call-interactively (get mail-user-agent 'sendfunc))))
d56aaa64 760
ca2a5950
GM		 761(defun diary-name-pattern (string-array &optional abbrev-array paren)
762 "Return a regexp matching the strings in the array STRING-ARRAY.
763If the optional argument ABBREV-ARRAY is present, then the function
764`calendar-abbrev-construct' is used to construct abbreviations from the
765two supplied arrays. The returned regexp will then also match these
766abbreviations, with or without final `.' characters. If the optional
767argument PAREN is non-nil, the regexp is surrounded by parentheses."
768 (regexp-opt (append string-array
769 (if abbrev-array
770 (calendar-abbrev-construct abbrev-array
771 string-array))
772 (if abbrev-array
773 (calendar-abbrev-construct abbrev-array
774 string-array
775 'period))
776 nil)
777 paren))
0808d911
ER		 778
779(defvar marking-diary-entries nil
780 "True during the marking of diary entries, nil otherwise.")
781
782(defvar marking-diary-entry nil
783 "True during the marking of diary entries, if current entry is marking.")
784
785(defun mark-diary-entries ()
786 "Mark days in the calendar window that have diary entries.
787Each entry in the diary file visible in the calendar window is marked.
788After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
789`mark-diary-entries-hook' are run."
790 (interactive)
791 (setq mark-diary-entries-in-calendar t)
c87a1f38
GM		 792 (let ((marking-diary-entries t)
793 file-glob-attrs marks)
794 (save-excursion
795 (set-buffer (find-file-noselect (diary-check-diary-file) t))
796 (message "Marking diary entries...")
797 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
798 (let ((d diary-date-forms)
799 (old-diary-syntax-table (syntax-table))
800 temp)
801 (set-syntax-table diary-syntax-table)
802 (while d
803 (let* ((date-form (if (equal (car (car d)) 'backup)
804 (cdr (car d))
805 (car d)));; ignore 'backup directive
ca2a5950
GM		 806 (dayname
807 (diary-name-pattern calendar-day-name-array
808 calendar-day-abbrev-array))
c87a1f38 809 (monthname
ca2a5950
GM		 810 (format "%s\\|\\*"
811 (diary-name-pattern calendar-month-name-array
812 calendar-month-abbrev-array)))
c87a1f38
GM		 813 (month "[0-9]+\\|\\*")
814 (day "[0-9]+\\|\\*")
815 (year "[0-9]+\\|\\*")
816 (l (length date-form))
817 (d-name-pos (- l (length (memq 'dayname date-form))))
818 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
819 (m-name-pos (- l (length (memq 'monthname date-form))))
820 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
821 (d-pos (- l (length (memq 'day date-form))))
822 (d-pos (if (/= l d-pos) (+ 2 d-pos)))
823 (m-pos (- l (length (memq 'month date-form))))
824 (m-pos (if (/= l m-pos) (+ 2 m-pos)))
825 (y-pos (- l (length (memq 'year date-form))))
826 (y-pos (if (/= l y-pos) (+ 2 y-pos)))
827 (regexp
828 (concat
829 "\\(\\`\\|\^M\\|\n\\)\\("
830 (mapconcat 'eval date-form "\\)\\(")
831 "\\)"))
832 (case-fold-search t))
833 (goto-char (point-min))
834 (while (re-search-forward regexp nil t)
835 (let* ((dd-name
836 (if d-name-pos
837 (buffer-substring-no-properties
838 (match-beginning d-name-pos)
839 (match-end d-name-pos))))
840 (mm-name
841 (if m-name-pos
842 (buffer-substring-no-properties
843 (match-beginning m-name-pos)
844 (match-end m-name-pos))))
845 (mm (string-to-int
846 (if m-pos
847 (buffer-substring-no-properties
848 (match-beginning m-pos)
849 (match-end m-pos))
850 "")))
851 (dd (string-to-int
852 (if d-pos
853 (buffer-substring-no-properties
854 (match-beginning d-pos)
855 (match-end d-pos))
856 "")))
857 (y-str (if y-pos
858 (buffer-substring-no-properties
859 (match-beginning y-pos)
860 (match-end y-pos))))
861 (yy (if (not y-str)
862 0
863 (if (and (= (length y-str) 2)
864 abbreviated-calendar-year)
865 (let* ((current-y
866 (extract-calendar-year
867 (calendar-current-date)))
868 (y (+ (string-to-int y-str)
869 (* 100
870 (/ current-y 100)))))
871 (if (> (- y current-y) 50)
872 (- y 100)
873 (if (> (- current-y y) 50)
874 (+ y 100)
875 y)))
876 (string-to-int y-str))))
877 (save-excursion
878 (setq entry (buffer-substring-no-properties
879 (point) (line-end-position))
880 temp (diary-pull-attrs entry file-glob-attrs)
881 entry (nth 0 temp)
882 marks (nth 1 temp))))
883 (if dd-name
884 (mark-calendar-days-named
885 (cdr (assoc-ignore-case
ca2a5950 886 dd-name
c87a1f38
GM		 887 (calendar-make-alist
888 calendar-day-name-array
ca2a5950 889 0 nil calendar-day-abbrev-array))) marks)
c87a1f38 890 (if mm-name
ca2a5950
GM		 891 (setq mm
892 (if (string-equal mm-name "*") 0
c87a1f38 893 (cdr (assoc-ignore-case
ca2a5950 894 mm-name
c87a1f38
GM		 895 (calendar-make-alist
896 calendar-month-name-array
ca2a5950 897 1 nil calendar-month-abbrev-array))))))
c87a1f38
GM		 898 (mark-calendar-date-pattern mm dd yy marks))))
899 (setq d (cdr d))))
900 (mark-sexp-diary-entries)
901 (run-hooks 'nongregorian-diary-marking-hook
902 'mark-diary-entries-hook)
903 (set-syntax-table old-diary-syntax-table)
904 (message "Marking diary entries...done")))))
0808d911
ER		 905
906(defun mark-sexp-diary-entries ()
907 "Mark days in the calendar window that have sexp diary entries.
908Each entry in the diary file (or included files) visible in the calendar window
909is marked. See the documentation for the function `list-sexp-diary-entries'."
910 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
911 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("
c87a1f38 912 sexp-mark "(\\)\\|\\("
0808d911 913 (regexp-quote diary-nonmarking-symbol)
c87a1f38
GM		 914 sexp-mark "(diary-remind\\)"))
915 (file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
916 m y first-date last-date mark file-glob-attrs)
0808d911
ER		 917 (save-excursion
918 (set-buffer calendar-buffer)
919 (setq m displayed-month)
920 (setq y displayed-year))
921 (increment-calendar-month m y -1)
922 (setq first-date
923 (calendar-absolute-from-gregorian (list m 1 y)))
924 (increment-calendar-month m y 2)
925 (setq last-date
926 (calendar-absolute-from-gregorian
927 (list m (calendar-last-day-of-month m y) y)))
928 (goto-char (point-min))
929 (while (re-search-forward s-entry nil t)
c87a1f38 930 (setq marking-diary-entry (char-equal (preceding-char) ?\())
0808d911
ER		 931 (re-search-backward "(")
932 (let ((sexp-start (point))
61d094de 933 sexp entry entry-start line-start marks)
0808d911 934 (forward-sexp)
e6c3bfbc 935 (setq sexp (buffer-substring-no-properties sexp-start (point)))
0808d911
ER		 936 (save-excursion
937 (re-search-backward "\^M\\|\n\\|\\`")
938 (setq line-start (point)))
939 (forward-char 1)
940 (if (and (or (char-equal (preceding-char) ?\^M)
941 (char-equal (preceding-char) ?\n))
942 (not (looking-at " \\|\^I")))
943 (progn;; Diary entry consists only of the sexp
944 (backward-char 1)
945 (setq entry ""))
946 (setq entry-start (point))
7ff02048 947 ;; Find end of entry
0808d911
ER		 948 (re-search-forward "\^M\\|\n" nil t)
949 (while (looking-at " \\|\^I")
94d1817d
KH		 950 (or (re-search-forward "\^M\\|\n" nil t)
951 (re-search-forward "$" nil t)))
7ff02048
KH		 952 (if (or (char-equal (preceding-char) ?\^M)
953 (char-equal (preceding-char) ?\n))
954 (backward-char 1))
e6c3bfbc 955 (setq entry (buffer-substring-no-properties entry-start (point)))
0808d911
ER		 956 (while (string-match "[\^M]" entry)
957 (aset entry (match-beginning 0) ?\n )))
958 (calendar-for-loop date from first-date to last-date do
fd4a98f0
RS		 959 (if (setq mark (diary-sexp-entry sexp entry
960 (calendar-gregorian-from-absolute date)))
c47a201a
JB		 961 (progn
962 (setq marks (diary-pull-attrs entry file-glob-attrs)
61d094de 963 marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
c47a201a 964 (mark-visible-calendar-date
4e80f517 965 (calendar-gregorian-from-absolute date)
c47a201a
JB		 966 (if (< 0 (length marks))
967 marks
968 (if (consp mark)
969 (car mark)))))))))))
0808d911
ER		 970
971(defun mark-included-diary-files ()
972 "Mark the diary entries from other diary files with those of the diary file.
973This function is suitable for use as the `mark-diary-entries-hook'; it enables
974you to use shared diary files together with your own. The files included are
975specified in the diary-file by lines of this form:
976 #include \"filename\"
977This is recursive; that is, #include directives in diary files thus included
978are obeyed. You can change the `#include' to some other string by
979changing the variable `diary-include-string'."
980 (goto-char (point-min))
981 (while (re-search-forward
982 (concat
983 "\\(\\`\\|\^M\\|\n\\)"
984 (regexp-quote diary-include-string)
985 " \"\\([^\"]*\\)\"")
986 nil t)
987 (let ((diary-file (substitute-in-file-name
e6c3bfbc
ER		 988 (buffer-substring-no-properties
989 (match-beginning 2) (match-end 2))))
0808d911
ER		 990 (mark-diary-entries-hook 'mark-included-diary-files))
991 (if (file-exists-p diary-file)
992 (if (file-readable-p diary-file)
993 (progn
994 (mark-diary-entries)
cdfeb73f 995 (kill-buffer (find-buffer-visiting diary-file)))
0808d911
ER		 996 (beep)
997 (message "Can't read included diary file %s" diary-file)
998 (sleep-for 2))
999 (beep)
1000 (message "Can't find included diary file %s" diary-file)
1001 (sleep-for 2))))
1002 (goto-char (point-min)))
1003
c47a201a 1004(defun mark-calendar-days-named (dayname &optional color)
0808d911
ER		 1005 "Mark all dates in the calendar window that are day DAYNAME of the week.
10060 means all Sundays, 1 means all Mondays, and so on."
1007 (save-excursion
1008 (set-buffer calendar-buffer)
1009 (let ((prev-month displayed-month)
1010 (prev-year displayed-year)
1011 (succ-month displayed-month)
1012 (succ-year displayed-year)
1013 (last-day)
1014 (day))
1015 (increment-calendar-month succ-month succ-year 1)
1016 (increment-calendar-month prev-month prev-year -1)
1017 (setq day (calendar-absolute-from-gregorian
1018 (calendar-nth-named-day 1 dayname prev-month prev-year)))
1019 (setq last-day (calendar-absolute-from-gregorian
1020 (calendar-nth-named-day -1 dayname succ-month succ-year)))
1021 (while (<= day last-day)
c47a201a 1022 (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color)
0808d911
ER		 1023 (setq day (+ day 7))))))
1024
c47a201a 1025(defun mark-calendar-date-pattern (month day year &optional color)
0808d911
ER		 1026 "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
1027A value of 0 in any position is a wildcard."
1028 (save-excursion
1029 (set-buffer calendar-buffer)
1030 (let ((m displayed-month)
1031 (y displayed-year))
1032 (increment-calendar-month m y -1)
1033 (calendar-for-loop i from 0 to 2 do
c47a201a 1034 (mark-calendar-month m y month day year color)
0808d911
ER		 1035 (increment-calendar-month m y 1)))))
1036
c47a201a 1037(defun mark-calendar-month (month year p-month p-day p-year &optional color)
0808d911
ER		 1038 "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
1039A value of 0 in any position of the pattern is a wildcard."
1040 (if (or (and (= month p-month)
1041 (or (= p-year 0) (= year p-year)))
1042 (and (= p-month 0)
1043 (or (= p-year 0) (= year p-year))))
1044 (if (= p-day 0)
1045 (calendar-for-loop
1046 i from 1 to (calendar-last-day-of-month month year) do
c47a201a
JB		 1047 (mark-visible-calendar-date (list month i year) color))
1048 (mark-visible-calendar-date (list month p-day year) color))))
0808d911
ER		 1049
1050(defun sort-diary-entries ()
1051 "Sort the list of diary entries by time of day."
1052 (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
1053
1054(defun diary-entry-compare (e1 e2)
1055 "Returns t if E1 is earlier than E2."
1056 (or (calendar-date-compare e1 e2)
1057 (and (calendar-date-equal (car e1) (car e2))
4dd618ff
SS		 1058 (let* ((ts1 (cadr e1)) (t1 (diary-entry-time ts1))
1059 (ts2 (cadr e2)) (t2 (diary-entry-time ts2)))
1060 (or (< t1 t2)
1061 (and (= t1 t2)
1062 (string-lessp ts1 ts2)))))))
0808d911 1063
a14723d9
KH		 1064(defcustom diary-unknown-time
1065 -9999
1066 "*Value returned by diary-entry-time when no time is found.
1067The default value -9999 causes entries with no recognizable time to be placed
1068before those with times; 9999 would place entries with no recognizable time
1069after those with times."
1070 :type 'integer
cd32a7ba
DN		 1071 :group 'diary
1072 :version "20.3")
4dd618ff 1073
0808d911 1074(defun diary-entry-time (s)
fd4a98f0
RS		 1075 "Return time at the beginning of the string S as a military-style integer.
1076For example, returns 1325 for 1:25pm.
1077Returns `diary-unknown-time' (default value -9999) if no time is recognized. The recognized forms are XXXX, X:XX, or
a14723d9
KH		 1078XX:XX (military time), and XXam, XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm,
1079or XX:XXPM."
0488694c 1080 (let ((case-fold-search nil))
4dd618ff 1081 (cond ((string-match ; Military time
619fdf3d 1082 "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
0488694c
RS		 1083 (+ (* 100 (string-to-int
1084 (substring s (match-beginning 1) (match-end 1))))
1085 (string-to-int (substring s (match-beginning 2) (match-end 2)))))
4dd618ff 1086 ((string-match ; Hour only XXam or XXpm
619fdf3d 1087 "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
0488694c
RS		 1088 (+ (* 100 (% (string-to-int
1089 (substring s (match-beginning 1) (match-end 1)))
1090 12))
1091 (if (equal ?a (downcase (aref s (match-beginning 2))))
1092 0 1200)))
4dd618ff 1093 ((string-match ; Hour and minute XX:XXam or XX:XXpm
619fdf3d 1094 "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
0488694c
RS		 1095 (+ (* 100 (% (string-to-int
1096 (substring s (match-beginning 1) (match-end 1)))
1097 12))
1098 (string-to-int (substring s (match-beginning 2) (match-end 2)))
1099 (if (equal ?a (downcase (aref s (match-beginning 3))))
1100 0 1200)))
4dd618ff 1101 (t diary-unknown-time)))) ; Unrecognizable
619fdf3d 1102
0808d911
ER		 1103(defun list-sexp-diary-entries (date)
1104 "Add sexp entries for DATE from the diary file to `diary-entries-list'.
1105Also, Make them visible in the diary file. Returns t if any entries were
1106found.
1107
1108Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
1109`%%'). The form of a sexp diary entry is
1110
1111 %%(SEXP) ENTRY
1112
1113Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
1114SEXP yields the value nil, the diary entry does not apply. If it yields a
1115non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
1116string, that string will be the diary entry in the fancy diary display.
1117
1118For example, the following diary entry will apply to the 21st of the month
1119if it is a weekday and the Friday before if the 21st is on a weekend:
1120
1121 &%%(let ((dayname (calendar-day-of-week date))
1122 (day (extract-calendar-day date)))
1123 (or
1124 (and (= day 21) (memq dayname '(1 2 3 4 5)))
1125 (and (memq day '(19 20)) (= dayname 5)))
1126 ) UIUC pay checks deposited
1127
1128A number of built-in functions are available for this type of diary entry:
1129
fd4a98f0 1130 %%(diary-date MONTH DAY YEAR &optional MARK) text
0808d911
ER		 1131 Entry applies if date is MONTH, DAY, YEAR if
1132 `european-calendar-style' is nil, and DAY, MONTH, YEAR if
1133 `european-calendar-style' is t. DAY, MONTH, and YEAR
1134 can be lists of integers, the constant t, or an integer.
ee58da1b 1135 The constant t means all values. An optional parameter
fd4a98f0
RS		 1136 MARK specifies a face or single-character string to use
1137 when highlighting the day in the calendar.
0808d911 1138
fd4a98f0 1139 %%(diary-float MONTH DAYNAME N &optional DAY MARK) text
0808d911
ER		 1140 Entry will appear on the Nth DAYNAME of MONTH.
1141 (DAYNAME=0 means Sunday, 1 means Monday, and so on;
1142 if N is negative it counts backward from the end of
1143 the month. MONTH can be a list of months, a single
9b58d144
RS		 1144 month, or t to specify all months. Optional DAY means
1145 Nth DAYNAME of MONTH on or after/before DAY. DAY defaults
ee58da1b
SS		 1146 to 1 if N>0 and the last day of the month if N<0. An
1147 optional parameter MARK specifies a face or single-character
fd4a98f0 1148 string to use when highlighting the day in the calendar.
0808d911 1149
fd4a98f0 1150 %%(diary-block M1 D1 Y1 M2 D2 Y2 &optional MARK) text
0808d911
ER		 1151 Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
1152 inclusive. (If `european-calendar-style' is t, the
1153 order of the parameters should be changed to D1, M1, Y1,
ee58da1b
SS		 1154 D2, M2, Y2.) An optional parameter MARK specifies a face
1155 or single-character string to use when highlighting the
fd4a98f0 1156 day in the calendar.
0808d911 1157
fd4a98f0 1158 %%(diary-anniversary MONTH DAY YEAR &optional MARK) text
0808d911
ER		 1159 Entry will appear on anniversary dates of MONTH DAY, YEAR.
1160 (If `european-calendar-style' is t, the order of the
1161 parameters should be changed to DAY, MONTH, YEAR.) Text
1162 can contain %d or %d%s; %d will be replaced by the number
1163 of years since the MONTH DAY, YEAR and %s will be replaced
1164 by the ordinal ending of that number (that is, `st', `nd',
1165 `rd' or `th', as appropriate. The anniversary of February
ee58da1b
SS		 1166 29 is considered to be March 1 in a non-leap year. An
1167 optional parameter MARK specifies a face or single-character
fd4a98f0 1168 string to use when highlighting the day in the calendar.
0808d911 1169
fd4a98f0 1170 %%(diary-cyclic N MONTH DAY YEAR &optional MARK) text
0808d911
ER		 1171 Entry will appear every N days, starting MONTH DAY, YEAR.
1172 (If `european-calendar-style' is t, the order of the
1173 parameters should be changed to N, DAY, MONTH, YEAR.) Text
1174 can contain %d or %d%s; %d will be replaced by the number
1175 of repetitions since the MONTH DAY, YEAR and %s will
1176 be replaced by the ordinal ending of that number (that is,
ee58da1b
SS		 1177 `st', `nd', `rd' or `th', as appropriate. An optional
1178 parameter MARK specifies a face or single-character string
fd4a98f0 1179 to use when highlighting the day in the calendar.
0808d911
ER		 1180
1181 %%(diary-remind SEXP DAYS &optional MARKING) text
1182 Entry is a reminder for diary sexp SEXP. DAYS is either a
1183 single number or a list of numbers indicating the number(s)
1184 of days before the event that the warning(s) should occur.
1185 If the current date is (one of) DAYS before the event
1186 indicated by EXPR, then a suitable message (as specified
1187 by `diary-remind-message') appears. In addition to the
1188 reminders beforehand, the diary entry also appears on
1189 the date itself. If optional MARKING is non-nil then the
1190 *reminders* are marked on the calendar. Marking of
1191 reminders is independent of whether the entry *itself* is
1192 a marking or nonmarking one.
1193
1194 %%(diary-day-of-year)
1195 Diary entries giving the day of the year and the number of
1196 days remaining in the year will be made every day. Note
1197 that since there is no text, it makes sense only if the
1198 fancy diary display is used.
1199
1200 %%(diary-iso-date)
1201 Diary entries giving the corresponding ISO commercial date
1202 will be made every day. Note that since there is no text,
1203 it makes sense only if the fancy diary display is used.
1204
1205 %%(diary-french-date)
1206 Diary entries giving the corresponding French Revolutionary
1207 date will be made every day. Note that since there is no
1208 text, it makes sense only if the fancy diary display is used.
1209
1210 %%(diary-islamic-date)
1211 Diary entries giving the corresponding Islamic date will be
1212 made every day. Note that since there is no text, it
1213 makes sense only if the fancy diary display is used.
1214
1215 %%(diary-hebrew-date)
1216 Diary entries giving the corresponding Hebrew date will be
1217 made every day. Note that since there is no text, it
1218 makes sense only if the fancy diary display is used.
1219
1220 %%(diary-astro-day-number) Diary entries giving the corresponding
1221 astronomical (Julian) day number will be made every day.
1222 Note that since there is no text, it makes sense only if the
1223 fancy diary display is used.
1224
1225 %%(diary-julian-date) Diary entries giving the corresponding
1226 Julian date will be made every day. Note that since
1227 there is no text, it makes sense only if the fancy diary
1228 display is used.
1229
1230 %%(diary-sunrise-sunset)
1231 Diary entries giving the local times of sunrise and sunset
1232 will be made every day. Note that since there is no text,
1233 it makes sense only if the fancy diary display is used.
1234 Floating point required.
1235
1236 %%(diary-phases-of-moon)
1237 Diary entries giving the times of the phases of the moon
1238 will be when appropriate. Note that since there is no text,
1239 it makes sense only if the fancy diary display is used.
1240 Floating point required.
1241
1242 %%(diary-yahrzeit MONTH DAY YEAR) text
1243 Text is assumed to be the name of the person; the date is
1244 the date of death on the *civil* calendar. The diary entry
1245 will appear on the proper Hebrew-date anniversary and on the
1246 day before. (If `european-calendar-style' is t, the order
1247 of the parameters should be changed to DAY, MONTH, YEAR.)
4dd618ff 1248
0808d911
ER		 1249 %%(diary-rosh-hodesh)
1250 Diary entries will be made on the dates of Rosh Hodesh on
1251 the Hebrew calendar. Note that since there is no text, it
1252 makes sense only if the fancy diary display is used.
1253
1254 %%(diary-parasha)
1255 Diary entries giving the weekly parasha will be made on
1256 every Saturday. Note that since there is no text, it
1257 makes sense only if the fancy diary display is used.
1258
1259 %%(diary-omer)
1260 Diary entries giving the omer count will be made every day
59ba214d 1261 from Passover to Shavuot. Note that since there is no text,
0808d911
ER		 1262 it makes sense only if the fancy diary display is used.
1263
1264Marking these entries is *extremely* time consuming, so these entries are
1265best if they are nonmarking."
c87a1f38
GM		 1266 (let ((s-entry (concat "\\(\\`\\|\^M\\|\n\\)"
1267 (regexp-quote diary-nonmarking-symbol)
1268 "?"
1269 (regexp-quote sexp-diary-entry-symbol)
1270 "("))
1271 entry-found file-glob-attrs marks)
0808d911 1272 (goto-char (point-min))
c47a201a
JB		 1273 (save-excursion
1274 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))
0808d911
ER		 1275 (while (re-search-forward s-entry nil t)
1276 (backward-char 1)
1277 (let ((sexp-start (point))
c87a1f38 1278 sexp entry specifier entry-start line-start)
0808d911 1279 (forward-sexp)
e6c3bfbc 1280 (setq sexp (buffer-substring-no-properties sexp-start (point)))
0808d911
ER		 1281 (save-excursion
1282 (re-search-backward "\^M\\|\n\\|\\`")
1283 (setq line-start (point)))
a14723d9 1284 (setq specifier
86432f81
MR		 1285 (buffer-substring-no-properties (1+ line-start) (point))
1286 entry-start (1+ line-start))
0808d911
ER		 1287 (forward-char 1)
1288 (if (and (or (char-equal (preceding-char) ?\^M)
1289 (char-equal (preceding-char) ?\n))
1290 (not (looking-at " \\|\^I")))
1291 (progn;; Diary entry consists only of the sexp
1292 (backward-char 1)
1293 (setq entry ""))
1294 (setq entry-start (point))
1295 (re-search-forward "\^M\\|\n" nil t)
1296 (while (looking-at " \\|\^I")
1297 (re-search-forward "\^M\\|\n" nil t))
1298 (backward-char 1)
e6c3bfbc 1299 (setq entry (buffer-substring-no-properties entry-start (point)))
0808d911
ER		 1300 (while (string-match "[\^M]" entry)
1301 (aset entry (match-beginning 0) ?\n )))
61d094de
GM		 1302 (let ((diary-entry (diary-sexp-entry sexp entry date))
1303 temp)
c47a201a
JB		 1304 (setq entry (if (consp diary-entry)
1305 (cdr diary-entry)
1306 diary-entry))
0808d911 1307 (if diary-entry
c47a201a
JB		 1308 (progn
1309 (subst-char-in-region line-start (point) ?\^M ?\n t)
1310 (if (< 0 (length entry))
1311 (setq temp (diary-pull-attrs entry file-glob-attrs)
1312 entry (nth 0 temp)
1313 marks (nth 1 temp)))))
1314 (add-to-diary-list date
1315 entry
86432f81
MR		 1316 specifier
1317 (if entry-start (copy-marker entry-start)
4e80f517 1318 nil)
c47a201a 1319 marks)
fd4a98f0 1320 (setq entry-found (or entry-found diary-entry)))))
0808d911
ER		 1321 entry-found))
1322
1323(defun diary-sexp-entry (sexp entry date)
1324 "Process a SEXP diary ENTRY for DATE."
1325 (let ((result (if calendar-debug-sexp
1326 (let ((stack-trace-on-error t))
1327 (eval (car (read-from-string sexp))))
1328 (condition-case nil
1329 (eval (car (read-from-string sexp)))
1330 (error
1331 (beep)
1332 (message "Bad sexp at line %d in %s: %s"
1333 (save-excursion
1334 (save-restriction
1335 (narrow-to-region 1 (point))
1336 (goto-char (point-min))
1337 (let ((lines 1))
1338 (while (re-search-forward "\n\\|\^M" nil t)
1339 (setq lines (1+ lines)))
1340 lines)))
1341 diary-file sexp)
1342 (sleep-for 2))))))
fd4a98f0
RS		 1343 (cond ((stringp result) result)
1344 ((and (consp result)
1345 (stringp (cdr result))) result)
1346 (result entry)
1347 (t nil))))
0808d911 1348
fd4a98f0 1349(defun diary-date (month day year &optional mark)
0808d911
ER		 1350 "Specific date(s) diary entry.
1351Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil,
1352and DAY, MONTH, YEAR if `european-calendar-style' is t. DAY, MONTH, and YEAR
1353can be lists of integers, the constant t, or an integer. The constant t means
fd4a98f0
RS		 1354all values.
1355
ee58da1b 1356An optional parameter MARK specifies a face or single-character string to
fd4a98f0 1357use when highlighting the day in the calendar."
c87a1f38 1358 (let ((dd (if european-calendar-style
0808d911
ER		 1359 month
1360 day))
c87a1f38 1361 (mm (if european-calendar-style
0808d911
ER		 1362 day
1363 month))
c87a1f38
GM		 1364 (m (extract-calendar-month date))
1365 (y (extract-calendar-year date))
1366 (d (extract-calendar-day date)))
0808d911
ER		 1367 (if (and
1368 (or (and (listp dd) (memq d dd))
1369 (equal d dd)
1370 (eq dd t))
1371 (or (and (listp mm) (memq m mm))
1372 (equal m mm)
1373 (eq mm t))
1374 (or (and (listp year) (memq y year))
1375 (equal y year)
1376 (eq year t)))
86432f81 1377 (cons mark entry))))
0808d911 1378
fd4a98f0 1379(defun diary-block (m1 d1 y1 m2 d2 y2 &optional mark)
0808d911 1380 "Block diary entry.
5860ba6e
RS		 1381Entry applies if date is between, or on one of, two dates.
1382The order of the parameters is
666333c0 1383M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and
fd4a98f0
RS		 1384D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t.
1385
ee58da1b 1386An optional parameter MARK specifies a face or single-character string to
fd4a98f0
RS		 1387use when highlighting the day in the calendar."
1388
0808d911
ER		 1389 (let ((date1 (calendar-absolute-from-gregorian
1390 (if european-calendar-style
1391 (list d1 m1 y1)
1392 (list m1 d1 y1))))
1393 (date2 (calendar-absolute-from-gregorian
1394 (if european-calendar-style
1395 (list d2 m2 y2)
1396 (list m2 d2 y2))))
1397 (d (calendar-absolute-from-gregorian date)))
1398 (if (and (<= date1 d) (<= d date2))
fd4a98f0 1399 (cons mark entry))))
0808d911 1400
fd4a98f0 1401(defun diary-float (month dayname n &optional day mark)
0808d911
ER		 1402 "Floating diary entry--entry applies if date is the nth dayname of month.
1403Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
1404t, or an integer. The constant t means all months. If N is negative, count
9b58d144
RS		 1405backward from the end of the month.
1406
fd4a98f0 1407An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
ee58da1b 1408Optional MARK specifies a face or single-character string to use when
fd4a98f0 1409highlighting the day in the calendar."
9b58d144
RS		 1410;; This is messy because the diary entry may apply, but the date on which it
1411;; is based can be in a different month/year. For example, asking for the
1412;; first Monday after December 30. For large values of |n| the problem is
1413;; more grotesque.
1414 (and (= dayname (calendar-day-of-week date))
1415 (let* ((m (extract-calendar-month date))
1416 (d (extract-calendar-day date))
1417 (y (extract-calendar-year date))
1418 (limit; last (n>0) or first (n<0) possible base date for entry
1419 (calendar-nth-named-absday (- n) dayname m y d))
1420 (last-abs (if (> n 0) limit (+ limit 6)))
1421 (first-abs (if (> n 0) (- limit 6) limit))
1422 (last (calendar-gregorian-from-absolute last-abs))
1423 (first (calendar-gregorian-from-absolute first-abs))
1424 ; m1, d1 is first possible base date
1425 (m1 (extract-calendar-month first))
1426 (d1 (extract-calendar-day first))
1427 (y1 (extract-calendar-year first))
1428 ; m2, d2 is last possible base date
1429 (m2 (extract-calendar-month last))
1430 (d2 (extract-calendar-day last))
1431 (y2 (extract-calendar-year last)))
a2faecac 1432 (if (or (and (= m1 m2) ; only possible base dates in one month
d56aaa64
GM		 1433 (or (eq month t)
1434 (if (listp month)
1435 (memq m1 month)
1436 (= m1 month)))
9f596b33
RS		 1437 (let ((d (or day (if (> n 0)
1438 1
1439 (calendar-last-day-of-month m1 y1)))))
1440 (and (<= d1 d) (<= d d2))))
1441 ;; only possible base dates straddle two months
b5972d79
RS		 1442 (and (or (< y1 y2)
1443 (and (= y1 y2) (< m1 m2)))
9f596b33 1444 (or
a2faecac 1445 ;; m1, d1 works as a base date
9f596b33 1446 (and
d56aaa64
GM		 1447 (or (eq month t)
1448 (if (listp month)
1449 (memq m1 month)
1450 (= m1 month)))
9f596b33
RS		 1451 (<= d1 (or day (if (> n 0)
1452 1
1453 (calendar-last-day-of-month m1 y1)))))
a2faecac 1454 ;; m2, d2 works as a base date
d56aaa64
GM		 1455 (and (or (eq month t)
1456 (if (listp month)
1457 (memq m2 month)
1458 (= m2 month)))
9f596b33
RS		 1459 (<= (or day (if (> n 0)
1460 1
1461 (calendar-last-day-of-month m2 y2)))
1462 d2)))))
fd4a98f0 1463 (cons mark entry)))))
0808d911 1464
d56aaa64 1465
fd4a98f0 1466(defun diary-anniversary (month day year &optional mark)
0808d911
ER		 1467 "Anniversary diary entry.
1468Entry applies if date is the anniversary of MONTH, DAY, YEAR if
1469`european-calendar-style' is nil, and DAY, MONTH, YEAR if
1470`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the
1471%d will be replaced by the number of years since the MONTH DAY, YEAR and the
1472%s will be replaced by the ordinal ending of that number (that is, `st', `nd',
1473`rd' or `th', as appropriate. The anniversary of February 29 is considered
fd4a98f0
RS		 1474to be March 1 in non-leap years.
1475
ee58da1b 1476An optional parameter MARK specifies a face or single-character string to
fd4a98f0 1477use when highlighting the day in the calendar."
0808d911
ER		 1478 (let* ((d (if european-calendar-style
1479 month
1480 day))
1481 (m (if european-calendar-style
1482 day
1483 month))
1484 (y (extract-calendar-year date))
1485 (diff (- y year)))
1486 (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
1487 (setq m 3
1488 d 1))
1489 (if (and (> diff 0) (calendar-date-equal (list m d y) date))
fd4a98f0 1490 (cons mark (format entry diff (diary-ordinal-suffix diff))))))
0808d911 1491
fd4a98f0 1492(defun diary-cyclic (n month day year &optional mark)
0808d911
ER		 1493 "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1494If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1495ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
d861718a
GM		 1496repetitions since the MONTH DAY, YEAR and %s will be replaced by the
1497ordinal ending of that number (that is, `st', `nd', `rd' or `th', as
fd4a98f0
RS		 1498appropriate.
1499
ee58da1b 1500An optional parameter MARK specifies a face or single-character string to
fd4a98f0 1501use when highlighting the day in the calendar."
0808d911
ER		 1502 (let* ((d (if european-calendar-style
1503 month
1504 day))
1505 (m (if european-calendar-style
1506 day
1507 month))
1508 (diff (- (calendar-absolute-from-gregorian date)
1509 (calendar-absolute-from-gregorian
1510 (list m d year))))
1511 (cycle (/ diff n)))
1512 (if (and (>= diff 0) (zerop (% diff n)))
fd4a98f0 1513 (cons mark (format entry cycle (diary-ordinal-suffix cycle))))))
0808d911
ER		 1514
1515(defun diary-ordinal-suffix (n)
1516 "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
1517 (if (or (memq (% n 100) '(11 12 13))
1518 (< 3 (% n 10)))
1519 "th"
1520 (aref ["th" "st" "nd" "rd"] (% n 10))))
1521
1522(defun diary-day-of-year ()
1523 "Day of year and number of days remaining in the year of date diary entry."
1524 (calendar-day-of-year-string date))
1525
5e11a170 1526(defcustom diary-remind-message
0808d911
ER		 1527 '("Reminder: Only "
1528 (if (= 0 (% days 7))
1529 (concat (int-to-string (/ days 7)) (if (= 7 days) " week" " weeks"))
1530 (concat (int-to-string days) (if (= 1 days) " day" " days")))
1531 " until "
1532 diary-entry)
1533 "*Pseudo-pattern giving form of reminder messages in the fancy diary
1534display.
4dd618ff 1535
0808d911
ER		 1536Used by the function `diary-remind', a pseudo-pattern is a list of
1537expressions that can involve the keywords `days' (a number), `date' (a list of
5e11a170
RS		 1538month, day, year), and `diary-entry' (a string)."
1539 :type 'sexp
1540 :group 'diary)
0808d911
ER		 1541
1542(defun diary-remind (sexp days &optional marking)
1543 "Provide a reminder of a diary entry.
1544SEXP is a diary-sexp. DAYS is either a single number or a list of numbers
1545indicating the number(s) of days before the event that the warning(s) should
1546occur on. If the current date is (one of) DAYS before the event indicated by
1547SEXP, then a suitable message (as specified by `diary-remind-message' is
1548returned.
1549
17b7580f
KH		 1550In addition to the reminders beforehand, the diary entry also appears on the
1551date itself.
1552
1553A `diary-nonmarking-symbol' at the beginning of the line of the diary-remind
1554entry specifies that the diary entry (not the reminder) is non-marking.
1555Marking of reminders is independent of whether the entry itself is a marking
1556or nonmarking; if optional parameter MARKING is non-nil then the reminders are
1557marked on the calendar."
1558 (let ((diary-entry (eval sexp)))
1559 (cond
1560 ;; Diary entry applies on date
1561 ((and diary-entry
1562 (or (not marking-diary-entries) marking-diary-entry))
1563 diary-entry)
1564 ;; Diary entry may apply to `days' before date
1565 ((and (integerp days)
1566 (not diary-entry); Diary entry does not apply to date
1567 (or (not marking-diary-entries) marking))
1568 (let ((date (calendar-gregorian-from-absolute
1569 (+ (calendar-absolute-from-gregorian date) days))))
1570 (if (setq diary-entry (eval sexp))
1571 (mapconcat 'eval diary-remind-message ""))))
1572 ;; Diary entry may apply to one of a list of days before date
1573 ((and (listp days) days)
1574 (or (diary-remind sexp (car days) marking)
1575 (diary-remind sexp (cdr days) marking))))))
0808d911 1576
c47a201a
JB		 1577(defun add-to-diary-list (date string specifier marker &optional globcolor)
1578 "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'.
0808d911 1579Do nothing if DATE or STRING is nil."
61d094de
GM		 1580 (when (and date string)
1581 (if diary-file-name-prefix
1582 (let ((prefix (funcall diary-file-name-prefix-function
1583 (buffer-file-name))))
1584 (or (string= prefix "")
1585 (setq string (format "[%s] %s" prefix string)))))
1586 (setq diary-entries-list
1587 (append diary-entries-list
1588 (list (list date string specifier marker globcolor))))))
0808d911
ER		 1589
1590(defun make-diary-entry (string &optional nonmarking file)
1591 "Insert a diary entry STRING which may be NONMARKING in FILE.
c87a1f38 1592If omitted, NONMARKING defaults to nil and FILE defaults to `diary-file'."
8ec6d48a
GM		 1593 (let ((pop-up-frames (window-dedicated-p (selected-window))))
1594 (find-file-other-window (substitute-in-file-name (or file diary-file))))
b8f2671f 1595 (widen)
0808d911 1596 (goto-char (point-max))
b8f2671f
JB		 1597 (when (let ((case-fold-search t))
1598 (search-backward "Local Variables:"
1599 (max (- (point-max) 3000) (point-min))
1600 t))
1601 (beginning-of-line)
1602 (insert "\n")
1603 (previous-line 1))
0808d911
ER		 1604 (insert
1605 (if (bolp) "" "\n")
1606 (if nonmarking diary-nonmarking-symbol "")
1607 string " "))
1608
1609(defun insert-diary-entry (arg)
1610 "Insert a diary entry for the date indicated by point.
1611Prefix arg will make the entry nonmarking."
1612 (interactive "P")
1613 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t)
1614 arg))
1615
1616(defun insert-weekly-diary-entry (arg)
1617 "Insert a weekly diary entry for the day of the week indicated by point.
1618Prefix arg will make the entry nonmarking."
1619 (interactive "P")
1620 (make-diary-entry (calendar-day-name (calendar-cursor-to-date t))
1621 arg))
1622
1623(defun insert-monthly-diary-entry (arg)
1624 "Insert a monthly diary entry for the day of the month indicated by point.
1625Prefix arg will make the entry nonmarking."
1626 (interactive "P")
c87a1f38
GM		 1627 (let ((calendar-date-display-form
1628 (if european-calendar-style
1629 '(day " * ")
1630 '("* " day))))
0808d911
ER		 1631 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1632 arg)))
1633
1634(defun insert-yearly-diary-entry (arg)
1635 "Insert an annual diary entry for the day of the year indicated by point.
1636Prefix arg will make the entry nonmarking."
1637 (interactive "P")
c87a1f38
GM		 1638 (let ((calendar-date-display-form
1639 (if european-calendar-style
1640 '(day " " monthname)
1641 '(monthname " " day))))
0808d911
ER		 1642 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1643 arg)))
1644
1645(defun insert-anniversary-diary-entry (arg)
1646 "Insert an anniversary diary entry for the date given by point.
1647Prefix arg will make the entry nonmarking."
1648 (interactive "P")
c87a1f38
GM		 1649 (let ((calendar-date-display-form
1650 (if european-calendar-style
1651 '(day " " month " " year)
1652 '(month " " day " " year))))
0808d911
ER		 1653 (make-diary-entry
1654 (format "%s(diary-anniversary %s)"
1655 sexp-diary-entry-symbol
1656 (calendar-date-string (calendar-cursor-to-date t) nil t))
1657 arg)))
1658
1659(defun insert-block-diary-entry (arg)
1660 "Insert a block diary entry for the days between the point and marked date.
1661Prefix arg will make the entry nonmarking."
1662 (interactive "P")
c87a1f38
GM		 1663 (let ((calendar-date-display-form
1664 (if european-calendar-style
1665 '(day " " month " " year)
1666 '(month " " day " " year)))
0808d911
ER		 1667 (cursor (calendar-cursor-to-date t))
1668 (mark (or (car calendar-mark-ring)
1669 (error "No mark set in this buffer")))
c87a1f38 1670 start end)
0808d911
ER		 1671 (if (< (calendar-absolute-from-gregorian mark)
1672 (calendar-absolute-from-gregorian cursor))
1673 (setq start mark
1674 end cursor)
1675 (setq start cursor
1676 end mark))
1677 (make-diary-entry
1678 (format "%s(diary-block %s %s)"
1679 sexp-diary-entry-symbol
1680 (calendar-date-string start nil t)
1681 (calendar-date-string end nil t))
1682 arg)))
1683
1684(defun insert-cyclic-diary-entry (arg)
1685 "Insert a cyclic diary entry starting at the date given by point.
1686Prefix arg will make the entry nonmarking."
1687 (interactive "P")
c87a1f38
GM		 1688 (let ((calendar-date-display-form
1689 (if european-calendar-style
1690 '(day " " month " " year)
1691 '(month " " day " " year))))
0808d911
ER		 1692 (make-diary-entry
1693 (format "%s(diary-cyclic %d %s)"
1694 sexp-diary-entry-symbol
1695 (calendar-read "Repeat every how many days: "
86855ebd 1696 (lambda (x) (> x 0)))
0808d911
ER		 1697 (calendar-date-string (calendar-cursor-to-date t) nil t))
1698 arg)))
1699
86432f81
MR		 1700;;;###autoload
1701(define-derived-mode diary-mode text-mode
1702 "Diary"
1703 "Major mode for editing the diary file."
1704 (set (make-local-variable 'font-lock-defaults)
1705 '(diary-font-lock-keywords t)))
1706
1707(define-derived-mode fancy-diary-display-mode text-mode
1708 "Diary"
1709 "Major mode used while displaying diary entries using Fancy Display."
1710 (set (make-local-variable 'font-lock-defaults)
4e80f517
SS		 1711 '(fancy-diary-font-lock-keywords t))
1712 (define-key (current-local-map) "q" 'quit-window))
86432f81
MR		 1713
1714
1715(defvar fancy-diary-font-lock-keywords
1716 (list
1717 (cons
1718 (concat
ca2a5950
GM		 1719 (let ((dayname (diary-name-pattern calendar-day-name-array nil t))
1720 (monthname (diary-name-pattern calendar-month-name-array nil t))
86432f81 1721 (day "[0-9]+")
e440b20e 1722 (month "[0-9]+")
86432f81
MR		 1723 (year "-?[0-9]+"))
1724 (mapconcat 'eval calendar-date-display-form ""))
1725 "\\(\\(: .*\\)\\|\\(\n +.*\\)\\)*\n=+$")
1726 'diary-face)
1727 '("^.*anniversary.*$" . font-lock-keyword-face)
1728 '("^.*birthday.*$" . font-lock-keyword-face)
1729 '("^.*Yahrzeit.*$" . font-lock-reference-face)
1730 '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
1731 '("^Day.*omer.*$" . font-lock-builtin-face)
1732 '("^Parashat.*$" . font-lock-comment-face)
1733 '("^[ \t]*[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)?\\(-[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)?\\)?"
1734 . font-lock-variable-name-face))
1735 "Keywords to highlight in fancy diary display")
1736
1737
1738(defun font-lock-diary-sexps (limit)
1739 "Recognize sexp diary entry for font-locking."
1740 (if (re-search-forward
1741 (concat "^" (regexp-quote diary-nonmarking-symbol)
1742 "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
1743 limit t)
1744 (condition-case nil
1745 (save-restriction
1746 (narrow-to-region (point-min) limit)
1747 (let ((start (point)))
1748 (forward-sexp 1)
1749 (store-match-data (list start (point)))
1750 t))
1751 (error t))))
1752
ca2a5950
GM		 1753(defun font-lock-diary-date-forms (month-array &optional symbol abbrev-array)
1754 "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY.
86432f81 1755If given, optional SYMBOL must be a prefix to entries.
ca2a5950
GM		 1756If optional ABBREV-ARRAY is present, the abbreviations constructed
1757from this array by the function `calendar-abbrev-construct' are
1758matched (with or without a final `.'), in addition to the full month
1759names."
1760 (let ((dayname (diary-name-pattern calendar-day-name-array
1761 calendar-day-abbrev-array t))
1762 (monthname (format "\\(%s\\|\\*\\)"
1763 (diary-name-pattern month-array abbrev-array)))
c87a1f38
GM		 1764 (month "\\([0-9]+\\|\\*\\)")
1765 (day "\\([0-9]+\\|\\*\\)")
1766 (year "-?\\([0-9]+\\|\\*\\)"))
86432f81
MR		 1767 (mapcar '(lambda (x)
1768 (cons
1769 (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
1770 (if symbol (regexp-quote symbol) "") "\\("
1771 (mapconcat 'eval
1772 ;; If backup, omit first item (backup)
1773 ;; and last item (not part of date)
1774 (if (equal (car x) 'backup)
1775 (reverse (cdr (reverse (cdr x))))
1776 x)
1777 "")
1778 ;; With backup, last item is not part of date
1779 (if (equal (car x) 'backup)
1780 (concat "\\)" (eval (car (reverse x))))
1781 "\\)"))
1782 '(1 diary-face)))
1783 diary-date-forms)))
1784
ca2a5950
GM		 1785(eval-when-compile (require 'cal-hebrew)
1786 (require 'cal-islam))
1787
86432f81
MR		 1788(defvar diary-font-lock-keywords
1789 (append
ca2a5950
GM		 1790 (font-lock-diary-date-forms calendar-month-name-array
1791 nil calendar-month-abbrev-array)
c87a1f38
GM		 1792 (when (or (memq 'mark-hebrew-diary-entries
1793 nongregorian-diary-marking-hook)
1794 (memq 'list-hebrew-diary-entries
1795 nongregorian-diary-listing-hook))
1796 (require 'cal-hebrew)
1797 (font-lock-diary-date-forms
1798 calendar-hebrew-month-name-array-leap-year
ca2a5950 1799 hebrew-diary-entry-symbol))
c87a1f38
GM		 1800 (when (or (memq 'mark-islamic-diary-entries
1801 nongregorian-diary-marking-hook)
1802 (memq 'list-islamic-diary-entries
1803 nongregorian-diary-listing-hook))
1804 (require 'cal-islam)
1805 (font-lock-diary-date-forms
1806 calendar-islamic-month-name-array
ca2a5950 1807 islamic-diary-entry-symbol))
86432f81
MR		 1808 (list
1809 (cons
1810 (concat "^" (regexp-quote diary-include-string) ".*$")
1811 'font-lock-keyword-face)
1812 (cons
1813 (concat "^" (regexp-quote diary-nonmarking-symbol)
1814 "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
1815 '(1 font-lock-reference-face))
1816 (cons
1817 (concat "^" (regexp-quote diary-nonmarking-symbol))
1818 'font-lock-reference-face)
1819 (cons
1820 (concat "^" (regexp-quote diary-nonmarking-symbol)
1821 "?\\(" (regexp-quote hebrew-diary-entry-symbol) "\\)")
1822 '(1 font-lock-reference-face))
1823 (cons
1824 (concat "^" (regexp-quote diary-nonmarking-symbol)
1825 "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)")
1826 '(1 font-lock-reference-face))
1827 '(font-lock-diary-sexps . font-lock-keyword-face)
1828 '("[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\(-[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\)?"
1829 . font-lock-function-name-face)))
1830 "Forms to highlight in diary-mode")
a1506d29 1831
86432f81 1832
e4ca7ef9 1833(provide 'diary-lib)
0808d911 1834
ab5796a9 1835;;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
e4ca7ef9 1836;;; diary-lib.el ends here
Unnamed repository; edit this file 'description' to name the repository.