lisp/calendar/diary-lib.el

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