root/trunk/lisp/calendar/diary-lib.el

;;; diary-lib.el --- diary functions

;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2001, 2002, 2003,
;;   2004, 2005, 2006, 2007, 2008  Free Software Foundation, Inc.

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This collection of functions implements the diary features as described
;; in calendar.el.

;;; Code:

(require 'calendar)

(defun diary-check-diary-file ()
  "Check that the file specified by `diary-file' exists and is readable.
If so, return the expanded file name, otherwise signal an error."
  (let ((d-file (substitute-in-file-name diary-file)))
    (if (and d-file (file-exists-p d-file))
        (if (file-readable-p d-file)
            d-file
          (error "Diary file `%s' is not readable" diary-file))
      (error "Diary file `%s' does not exist" diary-file))))

;;;###autoload
(defun diary (&optional arg)
  "Generate the diary window for ARG days starting with the current date.
If no argument is provided, the number of days of diary entries is governed
by the variable `number-of-diary-entries'.  A value of ARG less than 1
does nothing.  This function is suitable for execution in a `.emacs' file."
  (interactive "P")
  (diary-check-diary-file)
  (let ((date (calendar-current-date)))
    (diary-list-entries date (if arg (prefix-numeric-value arg)))))

(define-obsolete-function-alias 'view-diary-entries 'diary-view-entries)
(defun diary-view-entries (&optional arg)
  "Prepare and display a buffer with diary entries.
Searches the file named in `diary-file' for entries that
match ARG days starting with the date indicated by the cursor position
in the displayed three-month calendar."
  (interactive "p")
  (diary-check-diary-file)
  (diary-list-entries (calendar-cursor-to-date t) arg))

(defun view-other-diary-entries (arg d-file)
  "Prepare and display buffer of diary entries from an alternative diary file.
Searches for entries that match ARG days, starting with the date indicated
by the cursor position in the displayed three-month calendar.
D-FILE specifies the file to use as the diary file."
  (interactive
   (list (prefix-numeric-value current-prefix-arg)
         (read-file-name "Enter diary file name: " default-directory nil t)))
  (let ((diary-file d-file))
    (diary-view-entries arg)))

(autoload 'check-calendar-holidays "holidays"
  "Check the list of holidays for any that occur on DATE.
The value returned is a list of strings of relevant holiday descriptions.
The holidays are those in the list `calendar-holidays'.")

(autoload 'calendar-holiday-list "holidays"
  "Form the list of holidays that occur on dates in the calendar window.
The holidays are those in the list `calendar-holidays'.")

(autoload 'diary-french-date "cal-french"
  "French calendar equivalent of date diary entry.")

(autoload 'diary-mayan-date "cal-mayan"
  "Mayan calendar equivalent of date diary entry.")

(autoload 'diary-iso-date "cal-iso"
  "ISO calendar equivalent of date diary entry.")

(autoload 'diary-julian-date "cal-julian"
  "Julian calendar equivalent of date diary entry.")

(autoload 'diary-astro-day-number "cal-julian"
  "Astronomical (Julian) day number diary entry.")

(autoload 'diary-chinese-date "cal-china"
  "Chinese calendar equivalent of date diary entry.")

(autoload 'diary-islamic-date "cal-islam"
  "Islamic calendar equivalent of date diary entry.")

(autoload 'list-islamic-diary-entries "cal-islam"
  "Add any Islamic date entries from the diary file to `diary-entries-list'.")

(autoload 'mark-islamic-diary-entries "cal-islam"
  "Mark days in the calendar window that have Islamic date diary entries.")

(autoload 'mark-islamic-calendar-date-pattern "cal-islam"
   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.")

(autoload 'diary-bahai-date "cal-bahai"
  "Baha'i calendar equivalent of date diary entry.")

(autoload 'list-bahai-diary-entries "cal-bahai"
  "Add any Baha'i date entries from the diary file to `diary-entries-list'.")

(autoload 'mark-bahai-diary-entries "cal-bahai"
  "Mark days in the calendar window that have Baha'i date diary entries.")

(autoload 'mark-bahai-calendar-date-pattern "cal-bahai"
   "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.")

(autoload 'diary-hebrew-date "cal-hebrew"
  "Hebrew calendar equivalent of date diary entry.")

(autoload 'diary-omer "cal-hebrew"
  "Omer count diary entry.")

(autoload 'diary-yahrzeit "cal-hebrew"
  "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.")

(autoload 'diary-parasha "cal-hebrew"
  "Parasha diary entry--entry applies if date is a Saturday.")

(autoload 'diary-rosh-hodesh "cal-hebrew"
  "Rosh Hodesh diary entry.")

(autoload 'list-hebrew-diary-entries "cal-hebrew"
  "Add any Hebrew date entries from the diary file to `diary-entries-list'.")

(autoload 'mark-hebrew-diary-entries "cal-hebrew"
  "Mark days in the calendar window that have Hebrew date diary entries.")

(autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew"
   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.")

(autoload 'diary-coptic-date "cal-coptic"
  "Coptic calendar equivalent of date diary entry.")

(autoload 'diary-ethiopic-date "cal-coptic"
  "Ethiopic calendar equivalent of date diary entry.")

(autoload 'diary-persian-date "cal-persia"
  "Persian calendar equivalent of date diary entry.")

(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry.")

(autoload 'diary-sunrise-sunset "solar"
  "Local time of sunrise and sunset as a diary entry.")

(autoload 'diary-sabbath-candles "solar"
  "Local time of candle lighting diary entry--applies if date is a Friday.
No diary entry if there is no sunset on that date.")

(defvar diary-syntax-table
  (let ((st (copy-syntax-table (standard-syntax-table))))
    (modify-syntax-entry ?* "w" st)
    (modify-syntax-entry ?: "w" st)
    st)
  "The syntax table used when parsing dates in the diary file.
It is the standard syntax table used in Fundamental mode, but with the
syntax of `*' and `:' changed to be word constituents.")

(defvar diary-entries-list)
(defvar displayed-year)
(defvar displayed-month)
(defvar entry)
(defvar date)
(defvar number)
(defvar date-string)
(defvar original-date)

(defun diary-attrtype-convert (attrvalue type)
  "Convert string ATTRVALUE to TYPE appropriate for a face description.
Valid TYPEs are: string, symbol, int, stringtnil, tnil."
  (let (ret)
    (setq ret (cond ((eq type 'string) attrvalue)
                    ((eq type 'symbol) (read attrvalue))
                    ((eq type 'int) (string-to-number attrvalue))
                    ((eq type 'stringtnil)
                     (cond ((string= "t" attrvalue) t)
                           ((string= "nil" attrvalue) nil)
                           (t attrvalue)))
                    ((eq type 'tnil)
                     (cond ((string= "t" attrvalue) t)
                           ((string= "nil" attrvalue) nil)))))
;    (message "(%s)[%s]=[%s]" (print type) attrvalue ret)
    ret))


(defun diary-pull-attrs (entry fileglobattrs)
  "Pull the face-related attributes off the entry, merge with the
fileglobattrs, and return the (possibly modified) entry and face
data in a list of attrname attrvalue values.
The entry will be modified to drop all tags that are used for face matching.
If entry is nil, then the fileglobattrs are being searched for,
the fileglobattrs variable is ignored, and
diary-glob-file-regexp-prefix is prepended to the regexps before each
search."
  (save-excursion
    (let (regexp regnum attrname attr-list attrname attrvalue type
                 ret-attr attr)
      (if (null entry)
          (progn
            (setq ret-attr '()
                  attr-list diary-face-attrs)
            (while attr-list
              (goto-char (point-min))
              (setq attr (car attr-list)
                    regexp (nth 0 attr)
                    regnum (nth 1 attr)
                    attrname (nth 2 attr)
                    type (nth 3 attr)
                    regexp (concat diary-glob-file-regexp-prefix regexp))
              (setq attrvalue nil)
              (if (re-search-forward regexp (point-max) t)
                  (setq attrvalue (match-string-no-properties regnum)))
              (if (and attrvalue
                       (setq attrvalue (diary-attrtype-convert attrvalue type)))
                  (setq ret-attr (append ret-attr (list attrname attrvalue))))
              (setq attr-list (cdr attr-list)))
            (setq fileglobattrs ret-attr))
        (progn
          (setq ret-attr fileglobattrs
                attr-list diary-face-attrs)
          (while attr-list
            (goto-char (point-min))
            (setq attr (car attr-list)
                  regexp (nth 0 attr)
                  regnum (nth 1 attr)
                  attrname (nth 2 attr)
                  type (nth 3 attr))
            (setq attrvalue nil)
            (if (string-match regexp entry)
                (progn
                  (setq attrvalue (match-string-no-properties regnum entry))
                  (setq entry (replace-match "" t t entry))))
            (if (and attrvalue
                     (setq attrvalue (diary-attrtype-convert attrvalue type)))
                (setq ret-attr (append ret-attr (list attrname attrvalue))))
            (setq attr-list (cdr attr-list)))))
      (list entry ret-attr))))

(defun diary-set-maybe-redraw (symbol value)
  "Set SYMBOL's value to VALUE, and redraw the diary if necessary.
Redraws the diary if it is being displayed (note this is not the same as
just visiting the `diary-file'), and SYMBOL's value is to be changed."
  (let ((oldvalue (eval symbol)))
    (custom-set-default symbol value)
    (and (not (equal value oldvalue))
         (diary-live-p)
         ;; Note this assumes diary was called without prefix arg.
         (diary))))

;; This can be removed once the kill/yank treatment of invisible text
;; (see etc/TODO) is fixed. -- gm
(defcustom diary-header-line-flag t
  "If non-nil, `simple-diary-display' will show a header line.
The format of the header is specified by `diary-header-line-format'."
  :group   'diary
  :type    'boolean
  :initialize 'custom-initialize-default
  ;; FIXME overkill.
  :set 'diary-set-maybe-redraw
  :version "22.1")

(defvar diary-selective-display nil)

(defcustom diary-header-line-format
  '(:eval (calendar-string-spread
           (list (if diary-selective-display
                     "Selective display active - press \"s\" in calendar \
before edit/copy"
                   "Diary"))
           ?\s (frame-width)))
  "Format of the header line displayed by `simple-diary-display'.
Only used if `diary-header-line-flag' is non-nil."
  :group   'diary
  :type    'sexp
  :initialize 'custom-initialize-default
  ;; FIXME overkill.
  :set 'diary-set-maybe-redraw
  :version "22.1")

(defvar diary-saved-point)              ; internal

;; The first version of this also checked for diary-selective-display
;; in the non-fancy case. This was an attempt to distinguish between
;; displaying the diary and just visiting the diary file. However,
;; when using fancy diary, calling diary when there are no entries to
;; display does not create the fancy buffer, nor does it switch on
;; selective-display in the diary buffer. This means some
;; customizations will not take effect, eg:
;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-03/msg00466.html
;; So the check for selective-display was dropped. This means the
;; diary will be displayed if one customizes a diary variable while
;; just visiting the diary-file. This is i) unlikely, and ii) no great loss.
(defun diary-live-p ()
  "Return non-nil if the diary is being displayed."
  (or (get-buffer fancy-diary-buffer)
      (and diary-file
           (find-buffer-visiting (substitute-in-file-name diary-file)))))

(defcustom number-of-diary-entries 1
  "Specifies how many days of diary entries are to be displayed initially.
This variable affects the diary display when the command \\[diary] is used,
or if the value of the variable `view-diary-entries-initially' is t.  For
example, if the default value 1 is used, then only the current day's diary
entries will be displayed.  If the value 2 is used, then both the current
day's and the next day's entries will be displayed.

The value can also be a vector such as [0 2 2 2 2 4 1]; this value
says to display no diary entries on Sunday, the entries for
the current date and the day after on Monday through Thursday,
Friday through Monday's entries on Friday, and only Saturday's
entries on Saturday.

This variable does not affect the diary display with the `d' command
from the calendar; in that case, the prefix argument controls the
number of days of diary entries displayed."
  :type '(choice (integer :tag "Entries")
                 (vector :value [0 0 0 0 0 0 0]
                         (integer :tag "Sunday")
                         (integer :tag "Monday")
                         (integer :tag "Tuesday")
                         (integer :tag "Wednesday")
                         (integer :tag "Thursday")
                         (integer :tag "Friday")
                         (integer :tag "Saturday")))
  :initialize 'custom-initialize-default
  :set 'diary-set-maybe-redraw
  :group 'diary)


(defvar diary-modify-entry-list-string-function nil
  "Function applied to entry string before putting it into the entries list.
Can be used by programs integrating a diary list into other buffers (e.g.
org.el and planner.el) to modify the string or add properties to it.
The function takes a string argument and must return a string.")

(defun add-to-diary-list (date string specifier &optional marker
                               globcolor literal)
  "Add an entry to `diary-entries-list'.
Do nothing if DATE or STRING is nil.  DATE is the (MONTH DAY
YEAR) for which the entry applies; STRING is the text of the
entry as it will appear in the diary (i.e. with any format
strings such as \"%d\" expanded); SPECIFIER is the date part of
the entry as it appears in the diary-file; LITERAL is the entry
as it appears in the diary-file (i.e. before expansion).  If
LITERAL is nil, it is taken to be the same as STRING.

The entry is added to the list as (DATE STRING SPECIFIER LOCATOR
GLOBCOLOR), where LOCATOR has the form (MARKER FILENAME LITERAL),
FILENAME being the file containing the diary entry."
  (when (and date string)
    (if diary-file-name-prefix
        (let ((prefix (funcall diary-file-name-prefix-function
                               (buffer-file-name))))
          (or (string= prefix "")
              (setq string (format "[%s] %s" prefix string)))))
    (and diary-modify-entry-list-string-function
         (setq string (funcall diary-modify-entry-list-string-function
                               string)))
    (setq diary-entries-list
          (append diary-entries-list
                  (list (list date string specifier
                              (list marker (buffer-file-name) literal)
                              globcolor))))))

(define-obsolete-function-alias 'list-diary-entries 'diary-list-entries)
(defun diary-list-entries (date number &optional list-only)
  "Create and display a buffer containing the relevant lines in `diary-file'.
The arguments are DATE and NUMBER; the entries selected are those
for NUMBER days starting with date DATE.  The other entries are hidden
using selective display.  If NUMBER is less than 1, this function does nothing.

Returns a list of all relevant diary entries found, if any, in order by date.
The list entries have the form ((MONTH DAY YEAR) STRING SPECIFIER) where
\(MONTH DAY YEAR) is the date of the entry, STRING is the entry text, and
SPECIFIER is the applicability.  If the variable `diary-list-include-blanks'
is t, this list includes a dummy diary entry consisting of the empty string
for a date with no diary entries.

After the list is prepared, the hooks `nongregorian-diary-listing-hook',
`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
These hooks have the following distinct roles:

    `nongregorian-diary-listing-hook' can cull dates from the diary
        and each included file.  Usually used for Hebrew or Islamic
        diary entries in files.  Applied to *each* file.

    `list-diary-entries-hook' adds or manipulates diary entries from
        external sources.  Used, for example, to include diary entries
        from other files or to sort the diary entries.  Invoked *once* only,
        before the display hook is run.

    `diary-display-hook' does the actual display of information.  If this is
        nil, simple-diary-display will be used.  Use add-hook to set this to
        fancy-diary-display, if desired.  If you want no diary display, use
        add-hook to set this to ignore.

    `diary-hook' is run last.  This can be used for an appointment
        notification function.

If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
  (unless number
    (setq number (if (vectorp number-of-diary-entries)
                     (aref number-of-diary-entries (calendar-day-of-week date))
                   number-of-diary-entries)))
  (when (> number 0)
    (let ((original-date date);; save for possible use in the hooks
          diary-entries-list
          file-glob-attrs
          (date-string (calendar-date-string date))
          (d-file (substitute-in-file-name diary-file)))
      (message "Preparing diary...")
      (save-excursion
        (let ((diary-buffer (find-buffer-visiting d-file)))
          (if (not diary-buffer)
              (set-buffer (find-file-noselect d-file t))
            (set-buffer diary-buffer)
            (or (verify-visited-file-modtime diary-buffer)
                (revert-buffer t t))))
        ;; Setup things like the header-line-format and invisibility-spec.
        (if (eq major-mode default-major-mode)
            (diary-mode)
          ;; This kludge is to make customizations to
          ;; diary-header-line-flag after diary has been displayed
          ;; take effect. Unconditionally calling (diary-mode)
          ;; clobbers file local variables.
          ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-03/msg00363.html
          ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-04/msg00404.html
          (if (eq major-mode 'diary-mode)
              (setq header-line-format (and diary-header-line-flag
                                            diary-header-line-format))))
        ;; d-s-p is passed to the diary display function.
        (let ((diary-saved-point (point)))
          (save-excursion
            (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
            (with-syntax-table diary-syntax-table
              (let ((mark (regexp-quote diary-nonmarking-symbol)))
                (goto-char (point-min))
                (unless list-only
                  (let ((ol (make-overlay (point-min) (point-max) nil t nil)))
                    (set (make-local-variable 'diary-selective-display) t)
                    (overlay-put ol 'invisible 'diary)
                    (overlay-put ol 'evaporate t)))
                (calendar-for-loop
                 i from 1 to number do
                 (let ((month (extract-calendar-month date))
                       (day (extract-calendar-day date))
                       (year (extract-calendar-year date))
                       (entry-found (list-sexp-diary-entries date)))
                   (dolist (date-form diary-date-forms)
                     (let*
                         ((backup (when (eq (car date-form) 'backup)
                                    (setq date-form (cdr date-form))
                                    t))
                          (dayname
                           (format "%s\\|%s\\.?"
                                   (calendar-day-name date)
                                   (calendar-day-name date 'abbrev)))
                          (monthname
                           (format "\\*\\|%s\\|%s\\.?"
                                   (calendar-month-name month)
                                   (calendar-month-name month 'abbrev)))
                          (month (concat "\\*\\|0*" (int-to-string month)))
                          (day (concat "\\*\\|0*" (int-to-string day)))
                          (year
                           (concat
                            "\\*\\|0*" (int-to-string year)
                            (if abbreviated-calendar-year
                                (concat "\\|" (format "%02d" (% year 100)))
                              "")))
                          (regexp
                           (concat
                            "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
                            (mapconcat 'eval date-form "\\)\\(?:")
                            "\\)"))
                          (case-fold-search t))
                       (goto-char (point-min))
                       (while (re-search-forward regexp nil t)
                         (if backup (re-search-backward "\\<" nil t))
                         (if (and (or (char-equal (preceding-char) ?\^M)
                                      (char-equal (preceding-char) ?\n))
                                  (not (looking-at " \\|\^I")))
                             ;;  Diary entry that consists only of date.
                             (backward-char 1)
                           ;; Found a nonempty diary entry--make it
                           ;; visible and add it to the list.
                           (setq entry-found t)
                           (let ((entry-start (point))
                                 date-start temp)
                             (re-search-backward "\^M\\|\n\\|\\`")
                             (setq date-start (point))
                             ;; When selective display (rather than
                             ;; overlays) was used, diary file used to
                             ;; start in a blank line and end in a
                             ;; newline. Now that neither of these
                             ;; need be true, 'move handles the latter
                             ;; and 1/2 kludge the former.
                             (re-search-forward
                              "\^M\\|\n" nil 'move
                              (if (and (bobp) (not (looking-at "\^M\\|\n")))
                                  1
                                2))
                             (while (looking-at " \\|\^I")
                               (re-search-forward "\^M\\|\n" nil 'move))
                             (unless (and (eobp) (not (bolp)))
                               (backward-char 1))
                             (unless list-only
                               (remove-overlays date-start (point)
                                                'invisible 'diary))
                             (setq entry (buffer-substring entry-start (point))
                                   temp (diary-pull-attrs entry file-glob-attrs)
                                   entry (nth 0 temp))
                             (add-to-diary-list
                              date
                              entry
                              (buffer-substring
                               (1+ date-start) (1- entry-start))
                              (copy-marker entry-start) (nth 1 temp)))))))
                   (or entry-found
                       (not diary-list-include-blanks)
                       (add-to-diary-list date "" "" "" ""))
                   (setq date
                         (calendar-gregorian-from-absolute
                          (1+ (calendar-absolute-from-gregorian date))))
                   (setq entry-found nil)))))
            (goto-char (point-min))
            (run-hooks 'nongregorian-diary-listing-hook
                       'list-diary-entries-hook)
            (unless list-only
              (if diary-display-hook
                  (run-hooks 'diary-display-hook)
                (simple-diary-display)))
            (run-hooks 'diary-hook)
            diary-entries-list))))))

(defun diary-unhide-everything ()
  (kill-local-variable 'diary-selective-display)
  (remove-overlays (point-min) (point-max) 'invisible 'diary)
  (kill-local-variable 'mode-line-format))

(defun include-other-diary-files ()
  "Include the diary entries from other diary files with those of diary-file.
This function is suitable for use in `list-diary-entries-hook';
it enables you to use shared diary files together with your own.
The files included are specified in the diaryfile by lines of this form:
        #include \"filename\"
This is recursive; that is, #include directives in diary files thus included
are obeyed.  You can change the `#include' to some other string by
changing the variable `diary-include-string'."
  (goto-char (point-min))
  (while (re-search-forward
          (concat
           "\\(?:\\`\\|\^M\\|\n\\)"
           (regexp-quote diary-include-string)
           " \"\\([^\"]*\\)\"")
          nil t)
    (let* ((diary-file (substitute-in-file-name
                        (match-string-no-properties 1)))
           (diary-list-include-blanks nil)
           (list-diary-entries-hook 'include-other-diary-files)
           (diary-display-hook 'ignore)
           (diary-hook nil))
      (if (file-exists-p diary-file)
          (if (file-readable-p diary-file)
              (unwind-protect
                  (setq diary-entries-list
                        (append diary-entries-list
                                (diary-list-entries original-date number)))
                (with-current-buffer (find-buffer-visiting diary-file)
                  (diary-unhide-everything)))
            (beep)
            (message "Can't read included diary file %s" diary-file)
            (sleep-for 2))
        (beep)
        (message "Can't find included diary file %s" diary-file)
        (sleep-for 2))))
    (goto-char (point-min)))

(defun simple-diary-display ()
  "Display the diary buffer if there are any relevant entries or holidays."
  (let* ((holiday-list (if holidays-in-diary-buffer
                           (check-calendar-holidays original-date)))
         (hol-string (format "%s%s%s"
                             date-string
                             (if holiday-list ": " "")
                             (mapconcat 'identity holiday-list "; ")))
         (msg (format "No diary entries for %s" hol-string))
         ;; If selected window is dedicated (to the calendar),
         ;; need a new one to display the diary.
         (pop-up-frames (window-dedicated-p (selected-window))))
    (calendar-set-mode-line (format "Diary for %s" hol-string))
    (if (or (not diary-entries-list)
            (and (not (cdr diary-entries-list))
                 (string-equal (car (cdr (car diary-entries-list))) "")))
        (if (< (length msg) (frame-width))
            (message "%s" msg)
          (set-buffer (get-buffer-create holiday-buffer))
          (setq buffer-read-only nil)
          (calendar-set-mode-line date-string)
          (erase-buffer)
          (insert (mapconcat 'identity holiday-list "\n"))
          (goto-char (point-min))
          (set-buffer-modified-p nil)
          (setq buffer-read-only t)
          (display-buffer holiday-buffer)
          (message  "No diary entries for %s" date-string))
      (with-current-buffer
          (find-buffer-visiting (substitute-in-file-name diary-file))
        (let ((window (display-buffer (current-buffer))))
          ;; d-s-p is passed from list-diary-entries.
          (set-window-point window diary-saved-point)
          (set-window-start window (point-min))))
      (message "Preparing diary...done"))))

(defface diary-button '((((type pc) (class color))
                         (:foreground "lightblue")))
  "Default face used for buttons."
  :version "22.1"
  :group 'diary)
;; backward-compatibility alias
(put 'diary-button-face 'face-alias 'diary-button)

(define-button-type 'diary-entry
  'action #'diary-goto-entry
  'face 'diary-button)

(defun diary-goto-entry (button)
  (let* ((locator (button-get button 'locator))
         (marker (car locator))
         markbuf file)
    ;; If marker pointing to diary location is valid, use that.
    (if (and marker (setq markbuf (marker-buffer marker)))
        (progn
          (pop-to-buffer markbuf)
          (goto-char (marker-position marker)))
      ;; Marker is invalid (eg buffer has been killed).
      (or (and (setq file (cadr locator))
               (file-exists-p file)
               (find-file-other-window file)
               (progn
                 (when (eq major-mode default-major-mode) (diary-mode))
                 (goto-char (point-min))
                 (if (re-search-forward (format "%s.*\\(%s\\)"
                                                (regexp-quote (nth 2 locator))
                                                (regexp-quote (nth 3 locator)))
                                        nil t)
                     (goto-char (match-beginning 1)))))
          (message "Unable to locate this diary entry")))))

(defun fancy-diary-display ()
  "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
This function is provided for optional use as the `diary-display-hook'."
  (with-current-buffer ;; Turn off selective-display in the diary file's buffer.
      (find-buffer-visiting (substitute-in-file-name diary-file))
    (diary-unhide-everything))
  (if (or (not diary-entries-list)
          (and (not (cdr diary-entries-list))
               (string-equal (car (cdr (car diary-entries-list))) "")))
      (let* ((holiday-list (if holidays-in-diary-buffer
                               (check-calendar-holidays original-date)))
             (msg (format "No diary entries for %s %s"
                          (concat date-string (if holiday-list ":" ""))
                          (mapconcat 'identity holiday-list "; "))))
        (if (<= (length msg) (frame-width))
            (message "%s" msg)
          (set-buffer (get-buffer-create holiday-buffer))
          (setq buffer-read-only nil)
          (erase-buffer)
          (insert (mapconcat 'identity holiday-list "\n"))
          (goto-char (point-min))
          (set-buffer-modified-p nil)
          (setq buffer-read-only t)
          (display-buffer holiday-buffer)
          (message  "No diary entries for %s" date-string)))
    (with-current-buffer;; Prepare the fancy diary buffer.
        (make-fancy-diary-buffer)
      (setq buffer-read-only nil)
      (let ((entry-list diary-entries-list)
            (holiday-list)
            (holiday-list-last-month 1)
            (holiday-list-last-year 1)
            (date (list 0 0 0)))
        (while entry-list
          (if (not (calendar-date-equal date (car (car entry-list))))
              (progn
                (setq date (car (car entry-list)))
                (and holidays-in-diary-buffer
                     (calendar-date-compare
                      (list (list holiday-list-last-month
                                  (calendar-last-day-of-month
                                   holiday-list-last-month
                                   holiday-list-last-year)
                                  holiday-list-last-year))
                      (list date))
                     ;; We need to get the holidays for the next 3 months.
                     (setq holiday-list-last-month
                           (extract-calendar-month date))
                     (setq holiday-list-last-year
                           (extract-calendar-year date))
                     (progn
                       (increment-calendar-month
                        holiday-list-last-month holiday-list-last-year 1)
                       t)
                     (setq holiday-list
                           (let ((displayed-month holiday-list-last-month)
                                 (displayed-year holiday-list-last-year))
                             (calendar-holiday-list)))
                     (increment-calendar-month
                      holiday-list-last-month holiday-list-last-year 1))
                (let* ((date-string (calendar-date-string date))
                       (date-holiday-list
                        (let ((h holiday-list)
                              (d))
                          ;; Make a list of all holidays for date.
                          (while h
                            (if (calendar-date-equal date (car (car h)))
                                (setq d (append d (cdr (car h)))))
                            (setq h (cdr h)))
                          d)))
                  (insert (if (= (point) (point-min)) "" ?\n) date-string)
                  (if date-holiday-list (insert ":  "))
                  (let* ((l (current-column))
                         (longest 0))
                    (insert (mapconcat (lambda (x)
                                         (if (< longest (length x))
                                             (setq longest (length x)))
                                         x)
                                       date-holiday-list
                                       (concat "\n" (make-string l ? ))))
                    (insert ?\n (make-string (+ l longest) ?=) ?\n)))))

          (setq entry (car (cdr (car entry-list))))
          (if (< 0 (length entry))
              (let ((this-entry (car entry-list))
                    this-loc)
                (if (setq this-loc (nth 3 this-entry))
                    (insert-button (concat entry "\n")