-;;; diary-lib.el --- diary functions.
+;;; diary-lib.el --- diary functions
-;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2003, 2004
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keywords: calendar
(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'. This function is suitable for
-execution in a `.emacs' file."
+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")
- (let ((d-file (substitute-in-file-name diary-file))
- (date (calendar-current-date)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (list-diary-entries
- date
- (cond
- (arg (prefix-numeric-value arg))
- ((vectorp number-of-diary-entries)
- (aref number-of-diary-entries (calendar-day-of-week date)))
- (t number-of-diary-entries)))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
+ (diary-check-diary-file)
+ (let ((date (calendar-current-date)))
+ (list-diary-entries
+ date
+ (cond (arg (prefix-numeric-value arg))
+ ((vectorp number-of-diary-entries)
+ (aref number-of-diary-entries (calendar-day-of-week date)))
+ (t number-of-diary-entries)))))
(defun view-diary-entries (arg)
"Prepare and display a buffer with diary entries.
match ARG days starting with the date indicated by the cursor position
in the displayed three-month calendar."
(interactive "p")
- (let ((d-file (substitute-in-file-name diary-file)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (list-diary-entries (calendar-cursor-to-date t) arg)
- (error "Diary file is not readable!"))
- (error "You don't have a diary file!"))))
+ (diary-check-diary-file)
+ (list-diary-entries (calendar-cursor-to-date t) arg))
-(defun view-other-diary-entries (arg diary-file)
+(defun view-other-diary-entries (arg d-file)
"Prepare and display buffer of diary entries from an alternative diary file.
-Prompts for a file name and searches that file for entries that match ARG
-days starting with the date indicated by the cursor position in the displayed
-three-month calendar."
+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 (cond ((null current-prefix-arg) 1)
- ((listp current-prefix-arg) (car current-prefix-arg))
- (t current-prefix-arg))
- (setq diary-file (read-file-name "Enter diary file name: "
- default-directory nil t))))
- (view-diary-entries arg))
+ (list (if arg (prefix-numeric-value arg) 1)
+ (read-file-name "Enter diary file name: " default-directory nil t)))
+ (let ((diary-file d-file))
+ (view-diary-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'."
- t)
+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'."
- t)
+The holidays are those in the list `calendar-holidays'.")
(autoload 'diary-french-date "cal-french"
- "French calendar equivalent of date diary entry."
- t)
+ "French calendar equivalent of date diary entry.")
(autoload 'diary-mayan-date "cal-mayan"
- "Mayan calendar equivalent of date diary entry."
- t)
+ "Mayan calendar equivalent of date diary entry.")
(autoload 'diary-iso-date "cal-iso"
- "ISO calendar equivalent of date diary entry."
- t)
+ "ISO calendar equivalent of date diary entry.")
(autoload 'diary-julian-date "cal-julian"
- "Julian calendar equivalent of date diary entry."
- t)
+ "Julian calendar equivalent of date diary entry.")
(autoload 'diary-astro-day-number "cal-julian"
- "Astronomical (Julian) day number diary entry."
- t)
+ "Astronomical (Julian) day number diary entry.")
(autoload 'diary-chinese-date "cal-china"
- "Chinese calendar equivalent of date diary entry."
- t)
+ "Chinese calendar equivalent of date diary entry.")
(autoload 'diary-islamic-date "cal-islam"
- "Islamic calendar equivalent of date diary entry."
- t)
+ "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'."
- t)
+ "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."
- t)
+ "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."
- t)
+ "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.")
(autoload 'diary-hebrew-date "cal-hebrew"
- "Hebrew calendar equivalent of date diary entry."
- t)
+ "Hebrew calendar equivalent of date diary entry.")
(autoload 'diary-omer "cal-hebrew"
- "Omer count diary entry."
- t)
+ "Omer count diary entry.")
(autoload 'diary-yahrzeit "cal-hebrew"
- "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before."
- t)
+ "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."
- t)
+ "Parasha diary entry--entry applies if date is a Saturday.")
(autoload 'diary-rosh-hodesh "cal-hebrew"
- "Rosh Hodesh diary entry."
- t)
+ "Rosh Hodesh diary entry.")
(autoload 'list-hebrew-diary-entries "cal-hebrew"
- "Add any Hebrew date entries from the diary file to `diary-entries-list'."
- t)
+ "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."
- t)
+ "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."
- t)
+ "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."
- t)
+ "Coptic calendar equivalent of date diary entry.")
(autoload 'diary-ethiopic-date "cal-coptic"
- "Ethiopic calendar equivalent of date diary entry."
- t)
+ "Ethiopic calendar equivalent of date diary entry.")
(autoload 'diary-persian-date "cal-persia"
- "Persian calendar equivalent of date diary entry."
- t)
+ "Persian calendar equivalent of date diary entry.")
-(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
+(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."
- t)
+ "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."
- t)
+No diary entry if there is no sunset on that date.")
(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
"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 `*' changed to be a word constituent.")
+syntax of `*' and `:' changed to be word constituents.")
(modify-syntax-entry ?* "w" diary-syntax-table)
+(modify-syntax-entry ?: "w" diary-syntax-table)
+
+(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-int 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 (buffer-substring-no-properties
+ (match-beginning regnum)
+ (match-end 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 (substring-no-properties entry
+ (match-beginning regnum)
+ (match-end regnum)))
+ (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))))
+
+
+;; 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
+ :version "21.4")
+
+(defcustom diary-header-line-format
+ '(:eval (calendar-string-spread
+ (list (if selective-display
+ "Selective display active - press \"s\" in calendar \
+before edit/copy"
+ "Diary"))
+ ?\ (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
+ :version "21.4")
(defun list-diary-entries (date number)
"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.
+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). 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.
+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.
`diary-hook' is run last. This can be used for an appointment
notification function."
- (if (< 0 number)
- (let* ((original-date date);; save for possible use in the hooks
- (old-diary-syntax-table)
- (diary-entries-list)
- (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))))
- (setq selective-display t)
- (setq selective-display-ellipses nil)
- (setq old-diary-syntax-table (syntax-table))
- (set-syntax-table diary-syntax-table)
- (unwind-protect
+ (when (> number 0)
+ (let ((original-date date);; save for possible use in the hooks
+ old-diary-syntax-table
+ 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))))
+ (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
+ (setq selective-display t)
+ (setq selective-display-ellipses nil)
+ (if diary-header-line-flag
+ (setq header-line-format diary-header-line-format))
+ (setq old-diary-syntax-table (syntax-table))
+ (set-syntax-table diary-syntax-table)
+ (unwind-protect
(let ((buffer-read-only nil)
(diary-modified (buffer-modified-p))
(mark (regexp-quote diary-nonmarking-symbol)))
+ ;; First and last characters must be ^M or \n for
+ ;; selective display to work properly
(goto-char (1- (point-max)))
(if (not (looking-at "\^M\\|\n"))
(progn
- (forward-char 1)
- (insert-string "\^M")))
+ (goto-char (point-max))
+ (insert "\^M")))
(goto-char (point-min))
(if (not (looking-at "\^M\\|\n"))
- (insert-string "\^M"))
+ (insert "\^M"))
(subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
(calendar-for-loop i from 1 to number do
(let ((d diary-date-forms)
(car d)))
(backup (equal (car (car d)) 'backup))
(dayname
- (concat
- (calendar-day-name date) "\\|"
- (substring (calendar-day-name date) 0 3) ".?"))
+ (format "%s\\|%s\\.?"
+ (calendar-day-name date)
+ (calendar-day-name date 'abbrev)))
(monthname
- (concat
- "\\*\\|"
- (calendar-month-name month) "\\|"
- (substring (calendar-month-name month) 0 3) ".?"))
+ (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 "\\|" (int-to-string (% year 100)))
+ (concat "\\|" (format "%02d" (% year 100)))
"")))
(regexp
(concat
;; add it to the list.
(setq entry-found t)
(let ((entry-start (point))
- (date-start))
+ date-start temp)
(re-search-backward "\^M\\|\n\\|\\`")
(setq date-start (point))
(re-search-forward "\^M\\|\n" nil t 2)
(backward-char 1)
(subst-char-in-region date-start
(point) ?\^M ?\n t)
+ (setq entry (buffer-substring entry-start (point))
+ temp (diary-pull-attrs entry file-glob-attrs)
+ entry (nth 0 temp))
(add-to-diary-list
- date
- (buffer-substring-no-properties
- entry-start (point)))))))
+ date
+ entry
+ (buffer-substring
+ (1+ date-start) (1- entry-start))
+ (copy-marker entry-start) (nth 1 temp))))))
(setq d (cdr d)))
(or entry-found
(not diary-list-include-blanks)
- (setq diary-entries-list
+ (setq diary-entries-list
(append diary-entries-list
- (list (list date "")))))
+ (list (list date "" "" "" "")))))
(setq date
(calendar-gregorian-from-absolute
(1+ (calendar-absolute-from-gregorian date))))
(regexp-quote diary-include-string)
" \"\\([^\"]*\\)\"")
nil t)
- (let ((diary-file (substitute-in-file-name
- (buffer-substring-no-properties
- (match-beginning 2) (match-end 2))))
- (diary-list-include-blanks nil)
- (list-diary-entries-hook 'include-other-diary-files)
- (diary-display-hook 'ignore)
- (diary-hook nil))
+ (let* ((diary-file (substitute-in-file-name
+ (buffer-substring-no-properties
+ (match-beginning 2) (match-end 2))))
+ (diary-list-include-blanks nil)
+ (list-diary-entries-hook 'include-other-diary-files)
+ (diary-display-hook 'ignore)
+ (diary-hook nil)
+ (d-buffer (find-buffer-visiting diary-file))
+ (diary-modified (if d-buffer
+ (save-excursion
+ (set-buffer d-buffer)
+ (buffer-modified-p)))))
(if (file-exists-p diary-file)
(if (file-readable-p diary-file)
(unwind-protect
(setq diary-entries-list
(append diary-entries-list
(list-diary-entries original-date number)))
- (kill-buffer (find-buffer-visiting diary-file)))
+ (save-excursion
+ (set-buffer (find-buffer-visiting diary-file))
+ (let ((inhibit-read-only t))
+ (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))
+ (setq selective-display nil)
+ (set-buffer-modified-p diary-modified)))
(beep)
(message "Can't read included diary file %s" diary-file)
(sleep-for 2))
"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)))
- (msg (format "No diary entries for %s %s"
- (concat date-string (if holiday-list ":" ""))
- (mapconcat 'identity holiday-list "; "))))
+ (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))
+ (if (< (length msg) (frame-width))
(message "%s" msg)
(set-buffer (get-buffer-create holiday-buffer))
(setq buffer-read-only nil)
(setq buffer-read-only t)
(display-buffer holiday-buffer)
(message "No diary entries for %s" date-string))
- (calendar-set-mode-line
- (concat "Diary for " date-string
- (if holiday-list ": " "")
- (mapconcat 'identity holiday-list "; ")))
- (display-buffer (find-buffer-visiting d-file))
+ (display-buffer (find-buffer-visiting
+ (substitute-in-file-name diary-file)))
(message "Preparing diary...done"))))
+(defface diary-button-face '((((type pc) (class color))
+ (:foreground "lightblue")))
+ "Default face used for buttons."
+ :version "21.4"
+ :group 'diary)
+
+(define-button-type 'diary-entry
+ 'action #'diary-goto-entry
+ 'face #'diary-button-face)
+
+(defun diary-goto-entry (button)
+ (let ((marker (button-get button 'marker)))
+ (when marker
+ (pop-to-buffer (marker-buffer marker))
+ (goto-char (marker-position marker)))))
+
(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'."
(if date-holiday-list (insert ": "))
(let* ((l (current-column))
(longest 0))
- (insert (mapconcat '(lambda (x)
- (if (< longest (length x))
- (setq longest (length x)))
- x)
+ (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)))))
- (if (< 0 (length (car (cdr (car entry-list)))))
- (insert (car (cdr (car entry-list))) ?\n))
- (setq entry-list (cdr entry-list))))
+
+ (setq entry (car (cdr (car entry-list))))
+ (if (< 0 (length entry))
+ (progn
+ (if (nth 3 (car entry-list))
+ (insert-button (concat entry "\n")
+ 'marker (nth 3 (car entry-list))
+ :type 'diary-entry)
+ (insert entry ?\n))
+ (save-excursion
+ (let* ((marks (nth 4 (car entry-list)))
+ (temp-face (make-symbol
+ (apply
+ 'concat "temp-face-"
+ (mapcar '(lambda (sym)
+ (if (stringp sym)
+ sym
+ (symbol-name sym)))
+ marks))))
+ (faceinfo marks))
+ (make-face temp-face)
+ ;; Remove :face info from the marks,
+ ;; copy the face info into temp-face
+ (while (setq faceinfo (memq :face faceinfo))
+ (copy-face (read (nth 1 faceinfo)) temp-face)
+ (setcar faceinfo nil)
+ (setcar (cdr faceinfo) nil))
+ (setq marks (delq nil marks))
+ ;; Apply the font aspects
+ (apply 'set-face-attribute temp-face nil marks)
+ (search-backward entry)
+ (overlay-put
+ (make-overlay (match-beginning 0) (match-end 0))
+ 'face temp-face)))))
+ (setq entry-list (cdr entry-list))))
(set-buffer-modified-p nil)
(goto-char (point-min))
(setq buffer-read-only t)
(display-buffer fancy-diary-buffer)
+ (fancy-diary-display-mode)
(message "Preparing diary...done"))))
(defun make-fancy-diary-buffer ()
(save-excursion
(set-buffer (get-buffer-create fancy-diary-buffer))
(setq buffer-read-only nil)
- (make-local-variable 'mode-line-format)
(calendar-set-mode-line "Diary Entries")
(erase-buffer)
(set-buffer-modified-p nil)
all entries, not just some, are visible. If there is no diary buffer, one
is created."
(interactive)
- (let ((d-file (substitute-in-file-name diary-file)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (save-excursion
- (let ((diary-buffer (find-buffer-visiting d-file)))
- (set-buffer (if diary-buffer
- diary-buffer
- (find-file-noselect d-file t)))
- (let ((buffer-read-only nil)
- (diary-modified (buffer-modified-p)))
- (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
- (setq selective-display nil)
- (make-local-variable 'mode-line-format)
- (setq mode-line-format default-mode-line-format)
- (display-buffer (current-buffer))
- (set-buffer-modified-p diary-modified))))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
-
-(defun diary-name-pattern (string-array &optional fullname)
- "Convert an STRING-ARRAY, an array of strings to a pattern.
-The pattern will match any of the strings, either entirely or abbreviated
-to three characters. An abbreviated form will match with or without a period;
-If the optional FULLNAME is t, abbreviations will not match, just the full
-name."
- (let ((pattern ""))
- (calendar-for-loop i from 0 to (1- (length string-array)) do
- (setq pattern
- (concat
- pattern
- (if (string-equal pattern "") "" "\\|")
- (aref string-array i)
- (if fullname
- ""
- (concat
- "\\|"
- (substring (aref string-array i) 0 3) ".?")))))
- pattern))
+ (let ((d-file (diary-check-diary-file))
+ (pop-up-frames (window-dedicated-p (selected-window))))
+ (save-excursion
+ (set-buffer (or (find-buffer-visiting d-file)
+ (find-file-noselect d-file t)))
+ (let ((buffer-read-only nil)
+ (diary-modified (buffer-modified-p)))
+ (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
+ (setq selective-display nil
+ mode-line-format default-mode-line-format)
+ (display-buffer (current-buffer))
+ (set-buffer-modified-p diary-modified)))))
+
+(defcustom diary-mail-addr
+ (if (boundp 'user-mail-address) user-mail-address "")
+ "*Email address that `diary-mail-entries' will send email to."
+ :group 'diary
+ :type 'string
+ :version "20.3")
+
+(defcustom diary-mail-days 7
+ "*Default number of days for `diary-mail-entries' to check."
+ :group 'diary
+ :type 'integer
+ :version "20.3")
+
+;;;###autoload
+(defun diary-mail-entries (&optional ndays)
+ "Send a mail message showing diary entries for next NDAYS days.
+If no prefix argument is given, NDAYS is set to `diary-mail-days'.
+Mail is sent to the address specified by `diary-mail-addr'.
+
+You can call `diary-mail-entries' every night using an at/cron job.
+For example, this script will run the program at 2am daily. Since
+`emacs -batch' does not load your `.emacs' file, you must ensure that
+all relevant variables are set, as done here.
+
+#!/bin/sh
+# diary-rem.sh -- repeatedly run the Emacs diary-reminder
+emacs -batch \\
+-eval \"(setq diary-mail-days 3 \\
+ diary-file \\\"/path/to/diary.file\\\" \\
+ european-calendar-style t \\
+ diary-mail-addr \\\"user@host.name\\\" )\" \\
+-l diary-lib -f diary-mail-entries
+at -f diary-rem.sh 0200 tomorrow
+
+You may have to tweak the syntax of the `at' command to suit your
+system. Alternatively, you can specify a cron entry:
+0 1 * * * diary-rem.sh
+to run it every morning at 1am."
+ (interactive "P")
+ (if (string-equal diary-mail-addr "")
+ (error "You must set `diary-mail-addr' to use this command")
+ (let ((diary-display-hook 'fancy-diary-display))
+ (list-diary-entries (calendar-current-date) (or ndays diary-mail-days)))
+ (compose-mail diary-mail-addr
+ (concat "Diary entries generated "
+ (calendar-date-string (calendar-current-date))))
+ (insert
+ (if (get-buffer fancy-diary-buffer)
+ (save-excursion
+ (set-buffer fancy-diary-buffer)
+ (buffer-substring (point-min) (point-max)))
+ "No entries found"))
+ (call-interactively (get mail-user-agent 'sendfunc))))
+
+(defun diary-name-pattern (string-array &optional abbrev-array paren)
+ "Return a regexp matching the strings in the array STRING-ARRAY.
+If the optional argument ABBREV-ARRAY is present, then the function
+`calendar-abbrev-construct' is used to construct abbreviations from the
+two supplied arrays. The returned regexp will then also match these
+abbreviations, with or without final `.' characters. If the optional
+argument PAREN is non-nil, the regexp is surrounded by parentheses."
+ (regexp-opt (append string-array
+ (if abbrev-array
+ (calendar-abbrev-construct abbrev-array
+ string-array))
+ (if abbrev-array
+ (calendar-abbrev-construct abbrev-array
+ string-array
+ 'period))
+ nil)
+ paren))
(defvar marking-diary-entries nil
"True during the marking of diary entries, nil otherwise.")
`mark-diary-entries-hook' are run."
(interactive)
(setq mark-diary-entries-in-calendar t)
- (let ((d-file (substitute-in-file-name diary-file))
- (marking-diary-entries t))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (save-excursion
- (message "Marking diary entries...")
- (set-buffer (find-file-noselect d-file t))
- (let ((d diary-date-forms)
- (old-diary-syntax-table))
- (setq old-diary-syntax-table (syntax-table))
- (set-syntax-table diary-syntax-table)
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)));; ignore 'backup directive
- (dayname (diary-name-pattern calendar-day-name-array))
- (monthname
- (concat
- (diary-name-pattern calendar-month-name-array)
- "\\|\\*"))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (+ 2 d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (+ 2 m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (+ 2 y-pos)))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (buffer-substring-no-properties
- (match-beginning d-name-pos)
- (match-end d-name-pos))))
- (mm-name
- (if m-name-pos
- (buffer-substring-no-properties
- (match-beginning m-name-pos)
- (match-end m-name-pos))))
- (mm (string-to-int
- (if m-pos
- (buffer-substring-no-properties
- (match-beginning m-pos)
- (match-end m-pos))
- "")))
- (dd (string-to-int
- (if d-pos
- (buffer-substring-no-properties
- (match-beginning d-pos)
- (match-end d-pos))
- "")))
- (y-str (if y-pos
- (buffer-substring-no-properties
- (match-beginning y-pos)
- (match-end y-pos))))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- abbreviated-calendar-year)
- (let* ((current-y
- (extract-calendar-year
- (calendar-current-date)))
- (y (+ (string-to-int y-str)
- (* 100
- (/ current-y 100)))))
- (if (> (- y current-y) 50)
- (- y 100)
- (if (> (- current-y y) 50)
- (+ y 100)
- y)))
- (string-to-int y-str)))))
- (if dd-name
- (mark-calendar-days-named
- (cdr (assoc (capitalize (substring dd-name 0 3))
- (calendar-make-alist
- calendar-day-name-array
- 0
- '(lambda (x) (substring x 0 3))))))
- (if mm-name
- (if (string-equal mm-name "*")
- (setq mm 0)
- (setq mm
- (cdr (assoc
- (capitalize
- (substring mm-name 0 3))
- (calendar-make-alist
- calendar-month-name-array
- 1
- '(lambda (x) (substring x 0 3)))
- )))))
- (mark-calendar-date-pattern mm dd yy))))
- (setq d (cdr d))))
- (mark-sexp-diary-entries)
- (run-hooks 'nongregorian-diary-marking-hook
- 'mark-diary-entries-hook)
- (set-syntax-table old-diary-syntax-table)
- (message "Marking diary entries...done")))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
+ (let ((marking-diary-entries t)
+ file-glob-attrs marks)
+ (save-excursion
+ (set-buffer (find-file-noselect (diary-check-diary-file) t))
+ (message "Marking diary entries...")
+ (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
+ (let ((d diary-date-forms)
+ (old-diary-syntax-table (syntax-table))
+ temp)
+ (set-syntax-table diary-syntax-table)
+ (while d
+ (let* ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)));; ignore 'backup directive
+ (dayname
+ (diary-name-pattern calendar-day-name-array
+ calendar-day-abbrev-array))
+ (monthname
+ (format "%s\\|\\*"
+ (diary-name-pattern calendar-month-name-array
+ calendar-month-abbrev-array)))
+ (month "[0-9]+\\|\\*")
+ (day "[0-9]+\\|\\*")
+ (year "[0-9]+\\|\\*")
+ (l (length date-form))
+ (d-name-pos (- l (length (memq 'dayname date-form))))
+ (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
+ (m-name-pos (- l (length (memq 'monthname date-form))))
+ (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
+ (d-pos (- l (length (memq 'day date-form))))
+ (d-pos (if (/= l d-pos) (+ 2 d-pos)))
+ (m-pos (- l (length (memq 'month date-form))))
+ (m-pos (if (/= l m-pos) (+ 2 m-pos)))
+ (y-pos (- l (length (memq 'year date-form))))
+ (y-pos (if (/= l y-pos) (+ 2 y-pos)))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let* ((dd-name
+ (if d-name-pos
+ (buffer-substring-no-properties
+ (match-beginning d-name-pos)
+ (match-end d-name-pos))))
+ (mm-name
+ (if m-name-pos
+ (buffer-substring-no-properties
+ (match-beginning m-name-pos)
+ (match-end m-name-pos))))
+ (mm (string-to-int
+ (if m-pos
+ (buffer-substring-no-properties
+ (match-beginning m-pos)
+ (match-end m-pos))
+ "")))
+ (dd (string-to-int
+ (if d-pos
+ (buffer-substring-no-properties
+ (match-beginning d-pos)
+ (match-end d-pos))
+ "")))
+ (y-str (if y-pos
+ (buffer-substring-no-properties
+ (match-beginning y-pos)
+ (match-end y-pos))))
+ (yy (if (not y-str)
+ 0
+ (if (and (= (length y-str) 2)
+ abbreviated-calendar-year)
+ (let* ((current-y
+ (extract-calendar-year
+ (calendar-current-date)))
+ (y (+ (string-to-int y-str)
+ (* 100
+ (/ current-y 100)))))
+ (if (> (- y current-y) 50)
+ (- y 100)
+ (if (> (- current-y y) 50)
+ (+ y 100)
+ y)))
+ (string-to-int y-str))))
+ (save-excursion
+ (setq entry (buffer-substring-no-properties
+ (point) (line-end-position))
+ temp (diary-pull-attrs entry file-glob-attrs)
+ entry (nth 0 temp)
+ marks (nth 1 temp))))
+ (if dd-name
+ (mark-calendar-days-named
+ (cdr (assoc-ignore-case
+ dd-name
+ (calendar-make-alist
+ calendar-day-name-array
+ 0 nil calendar-day-abbrev-array))) marks)
+ (if mm-name
+ (setq mm
+ (if (string-equal mm-name "*") 0
+ (cdr (assoc-ignore-case
+ mm-name
+ (calendar-make-alist
+ calendar-month-name-array
+ 1 nil calendar-month-abbrev-array))))))
+ (mark-calendar-date-pattern mm dd yy marks))))
+ (setq d (cdr d))))
+ (mark-sexp-diary-entries)
+ (run-hooks 'nongregorian-diary-marking-hook
+ 'mark-diary-entries-hook)
+ (set-syntax-table old-diary-syntax-table)
+ (message "Marking diary entries...done")))))
(defun mark-sexp-diary-entries ()
"Mark days in the calendar window that have sexp diary entries.
is marked. See the documentation for the function `list-sexp-diary-entries'."
(let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
(s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("
- (regexp-quote sexp-mark) "(\\)\\|\\("
+ sexp-mark "(\\)\\|\\("
(regexp-quote diary-nonmarking-symbol)
- (regexp-quote sexp-mark) "(diary-remind\\)"))
- (m)
- (y)
- (first-date)
- (last-date))
+ sexp-mark "(diary-remind\\)"))
+ (file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
+ m y first-date last-date mark file-glob-attrs)
(save-excursion
(set-buffer calendar-buffer)
(setq m displayed-month)
(list m (calendar-last-day-of-month m y) y)))
(goto-char (point-min))
(while (re-search-forward s-entry nil t)
- (if (char-equal (preceding-char) ?\()
- (setq marking-diary-entry t)
- (setq marking-diary-entry nil))
+ (setq marking-diary-entry (char-equal (preceding-char) ?\())
(re-search-backward "(")
(let ((sexp-start (point))
- (sexp)
- (entry)
- (entry-start)
- (line-start))
+ sexp entry entry-start line-start marks)
(forward-sexp)
(setq sexp (buffer-substring-no-properties sexp-start (point)))
(save-excursion
(backward-char 1)
(setq entry ""))
(setq entry-start (point))
+ ;; Find end of entry
(re-search-forward "\^M\\|\n" nil t)
(while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
+ (or (re-search-forward "\^M\\|\n" nil t)
+ (re-search-forward "$" nil t)))
+ (if (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (backward-char 1))
(setq entry (buffer-substring-no-properties entry-start (point)))
(while (string-match "[\^M]" entry)
(aset entry (match-beginning 0) ?\n )))
(calendar-for-loop date from first-date to last-date do
- (if (diary-sexp-entry sexp entry
- (calendar-gregorian-from-absolute date))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date))))))))
+ (if (setq mark (diary-sexp-entry sexp entry
+ (calendar-gregorian-from-absolute date)))
+ (progn
+ (setq marks (diary-pull-attrs entry file-glob-attrs)
+ marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date)
+ (if (< 0 (length marks))
+ marks
+ (if (consp mark)
+ (car mark)))))))))))
(defun mark-included-diary-files ()
"Mark the diary entries from other diary files with those of the diary file.
(sleep-for 2))))
(goto-char (point-min)))
-(defun mark-calendar-days-named (dayname)
+(defun mark-calendar-days-named (dayname &optional color)
"Mark all dates in the calendar window that are day DAYNAME of the week.
0 means all Sundays, 1 means all Mondays, and so on."
(save-excursion
(setq last-day (calendar-absolute-from-gregorian
(calendar-nth-named-day -1 dayname succ-month succ-year)))
(while (<= day last-day)
- (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
+ (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color)
(setq day (+ day 7))))))
-(defun mark-calendar-date-pattern (month day year)
+(defun mark-calendar-date-pattern (month day year &optional color)
"Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
A value of 0 in any position is a wildcard."
(save-excursion
(y displayed-year))
(increment-calendar-month m y -1)
(calendar-for-loop i from 0 to 2 do
- (mark-calendar-month m y month day year)
+ (mark-calendar-month m y month day year color)
(increment-calendar-month m y 1)))))
-(defun mark-calendar-month (month year p-month p-day p-year)
+(defun mark-calendar-month (month year p-month p-day p-year &optional color)
"Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
A value of 0 in any position of the pattern is a wildcard."
(if (or (and (= month p-month)
(if (= p-day 0)
(calendar-for-loop
i from 1 to (calendar-last-day-of-month month year) do
- (mark-visible-calendar-date (list month i year)))
- (mark-visible-calendar-date (list month p-day year)))))
+ (mark-visible-calendar-date (list month i year) color))
+ (mark-visible-calendar-date (list month p-day year) color))))
(defun sort-diary-entries ()
"Sort the list of diary entries by time of day."
"Returns t if E1 is earlier than E2."
(or (calendar-date-compare e1 e2)
(and (calendar-date-equal (car e1) (car e2))
- (< (diary-entry-time (car (cdr e1)))
- (diary-entry-time (car (cdr e2)))))))
+ (let* ((ts1 (cadr e1)) (t1 (diary-entry-time ts1))
+ (ts2 (cadr e2)) (t2 (diary-entry-time ts2)))
+ (or (< t1 t2)
+ (and (= t1 t2)
+ (string-lessp ts1 ts2)))))))
+
+(defcustom diary-unknown-time
+ -9999
+ "*Value returned by diary-entry-time when no time is found.
+The default value -9999 causes entries with no recognizable time to be placed
+before those with times; 9999 would place entries with no recognizable time
+after those with times."
+ :type 'integer
+ :group 'diary
+ :version "20.3")
(defun diary-entry-time (s)
- "Time at the beginning of the string S in a military-style integer.
-For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
-The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
-and XX:XXam or XX:XXpm."
- (cond ((string-match;; Military time
- "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
- (+ (* 100 (string-to-int
- (substring s (match-beginning 1) (match-end 1))))
- (string-to-int (substring s (match-beginning 2) (match-end 2)))))
- ((string-match;; Hour only XXam or XXpm
- "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-int
- (substring s (match-beginning 1) (match-end 1)))
- 12))
- (if (string-equal "a"
- (substring s (match-beginning 2) (match-end 2)))
- 0 1200)))
- ((string-match;; Hour and minute XX:XXam or XX:XXpm
- "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-int
- (substring s (match-beginning 1) (match-end 1)))
- 12))
- (string-to-int (substring s (match-beginning 2) (match-end 2)))
- (if (string-equal "a"
- (substring s (match-beginning 3) (match-end 3)))
- 0 1200)))
- (t -9999)));; Unrecognizable
+ "Return time at the beginning of the string S as a military-style integer.
+For example, returns 1325 for 1:25pm.
+
+Returns `diary-unknown-time' (default value -9999) if no time is recognized.
+The recognized forms are XXXX, X:XX, or XX:XX (military time), and XXam,
+XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, or XX:XXPM. A period (.) can
+be used instead of a colon (:) to separate the hour and minute parts."
+ (let ((case-fold-search nil))
+ (cond ((string-match ; Military time
+ "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
+ s)
+ (+ (* 100 (string-to-int
+ (substring s (match-beginning 1) (match-end 1))))
+ (string-to-int (substring s (match-beginning 2) (match-end 2)))))
+ ((string-match ; Hour only XXam or XXpm
+ "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-int
+ (substring s (match-beginning 1) (match-end 1)))
+ 12))
+ (if (equal ?a (downcase (aref s (match-beginning 2))))
+ 0 1200)))
+ ((string-match ; Hour and minute XX:XXam or XX:XXpm
+ "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-int
+ (substring s (match-beginning 1) (match-end 1)))
+ 12))
+ (string-to-int (substring s (match-beginning 2) (match-end 2)))
+ (if (equal ?a (downcase (aref s (match-beginning 3))))
+ 0 1200)))
+ (t diary-unknown-time)))) ; Unrecognizable
(defun list-sexp-diary-entries (date)
"Add sexp entries for DATE from the diary file to `diary-entries-list'.
A number of built-in functions are available for this type of diary entry:
- %%(diary-date MONTH DAY YEAR) text
+ %%(diary-date MONTH DAY YEAR &optional MARK) text
Entry applies if date is MONTH, DAY, YEAR if
`european-calendar-style' is nil, and DAY, MONTH, YEAR if
`european-calendar-style' is t. DAY, MONTH, and YEAR
can be lists of integers, the constant t, or an integer.
- The constant t means all values.
+ The constant t means all values. An optional parameter
+ MARK specifies a face or single-character string to use
+ when highlighting the day in the calendar.
- %%(diary-float MONTH DAYNAME N) text
+ %%(diary-float MONTH DAYNAME N &optional DAY MARK) text
Entry will appear on the Nth DAYNAME of MONTH.
(DAYNAME=0 means Sunday, 1 means Monday, and so on;
if N is negative it counts backward from the end of
the month. MONTH can be a list of months, a single
- month, or t to specify all months.
+ month, or t to specify all months. Optional DAY means
+ Nth DAYNAME of MONTH on or after/before DAY. DAY defaults
+ to 1 if N>0 and the last day of the month if N<0. An
+ optional parameter MARK specifies a face or single-character
+ string to use when highlighting the day in the calendar.
- %%(diary-block M1 D1 Y1 M2 D2 Y2) text
+ %%(diary-block M1 D1 Y1 M2 D2 Y2 &optional MARK) text
Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
inclusive. (If `european-calendar-style' is t, the
order of the parameters should be changed to D1, M1, Y1,
- D2, M2, Y2.)
+ D2, M2, Y2.) An optional parameter MARK specifies a face
+ or single-character string to use when highlighting the
+ day in the calendar.
- %%(diary-anniversary MONTH DAY YEAR) text
+ %%(diary-anniversary MONTH DAY YEAR &optional MARK) text
Entry will appear on anniversary dates of MONTH DAY, YEAR.
(If `european-calendar-style' is t, the order of the
parameters should be changed to DAY, MONTH, YEAR.) Text
of years since the MONTH DAY, YEAR and %s will be replaced
by the ordinal ending of that number (that is, `st', `nd',
`rd' or `th', as appropriate. The anniversary of February
- 29 is considered to be March 1 in a non-leap year.
+ 29 is considered to be March 1 in a non-leap year. An
+ optional parameter MARK specifies a face or single-character
+ string to use when highlighting the day in the calendar.
- %%(diary-cyclic N MONTH DAY YEAR) text
+ %%(diary-cyclic N MONTH DAY YEAR &optional MARK) text
Entry will appear every N days, starting MONTH DAY, YEAR.
(If `european-calendar-style' is t, the order of the
parameters should be changed to N, DAY, MONTH, YEAR.) Text
can contain %d or %d%s; %d will be replaced by the number
of repetitions since the MONTH DAY, YEAR and %s will
be replaced by the ordinal ending of that number (that is,
- `st', `nd', `rd' or `th', as appropriate.
+ `st', `nd', `rd' or `th', as appropriate. An optional
+ parameter MARK specifies a face or single-character string
+ to use when highlighting the day in the calendar.
%%(diary-remind SEXP DAYS &optional MARKING) text
Entry is a reminder for diary sexp SEXP. DAYS is either a
will appear on the proper Hebrew-date anniversary and on the
day before. (If `european-calendar-style' is t, the order
of the parameters should be changed to DAY, MONTH, YEAR.)
-
+
%%(diary-rosh-hodesh)
Diary entries will be made on the dates of Rosh Hodesh on
the Hebrew calendar. Note that since there is no text, it
Marking these entries is *extremely* time consuming, so these entries are
best if they are nonmarking."
- (let* ((mark (regexp-quote diary-nonmarking-symbol))
- (sexp-mark (regexp-quote sexp-diary-entry-symbol))
- (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
- (entry-found))
+ (let ((s-entry (concat "\\(\\`\\|\^M\\|\n\\)"
+ (regexp-quote diary-nonmarking-symbol)
+ "?"
+ (regexp-quote sexp-diary-entry-symbol)
+ "("))
+ entry-found file-glob-attrs marks)
(goto-char (point-min))
+ (save-excursion
+ (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))
(while (re-search-forward s-entry nil t)
(backward-char 1)
(let ((sexp-start (point))
- (sexp)
- (entry)
- (entry-start)
- (line-start))
+ sexp entry specifier entry-start line-start)
(forward-sexp)
(setq sexp (buffer-substring-no-properties sexp-start (point)))
(save-excursion
(re-search-backward "\^M\\|\n\\|\\`")
(setq line-start (point)))
+ (setq specifier
+ (buffer-substring-no-properties (1+ line-start) (point))
+ entry-start (1+ line-start))
(forward-char 1)
(if (and (or (char-equal (preceding-char) ?\^M)
(char-equal (preceding-char) ?\n))
(setq entry (buffer-substring-no-properties entry-start (point)))
(while (string-match "[\^M]" entry)
(aset entry (match-beginning 0) ?\n )))
- (let ((diary-entry (diary-sexp-entry sexp entry date)))
+ (let ((diary-entry (diary-sexp-entry sexp entry date))
+ temp)
+ (setq entry (if (consp diary-entry)
+ (cdr diary-entry)
+ diary-entry))
(if diary-entry
- (subst-char-in-region line-start (point) ?\^M ?\n t))
- (add-to-diary-list date diary-entry)
- (setq entry-found (or entry-found diary-entry)))))
+ (progn
+ (subst-char-in-region line-start (point) ?\^M ?\n t)
+ (if (< 0 (length entry))
+ (setq temp (diary-pull-attrs entry file-glob-attrs)
+ entry (nth 0 temp)
+ marks (nth 1 temp)))))
+ (add-to-diary-list date
+ entry
+ specifier
+ (if entry-start (copy-marker entry-start)
+ nil)
+ marks)
+ (setq entry-found (or entry-found diary-entry)))))
entry-found))
(defun diary-sexp-entry (sexp entry date)
lines)))
diary-file sexp)
(sleep-for 2))))))
- (if (stringp result)
- result
- (if result
- entry
- nil))))
+ (cond ((stringp result) result)
+ ((and (consp result)
+ (stringp (cdr result))) result)
+ (result entry)
+ (t nil))))
-(defun diary-date (month day year)
+(defun diary-date (month day year &optional mark)
"Specific date(s) diary entry.
Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil,
and DAY, MONTH, YEAR if `european-calendar-style' is t. DAY, MONTH, and YEAR
can be lists of integers, the constant t, or an integer. The constant t means
-all values."
- (let* ((dd (if european-calendar-style
+all values.
+
+An optional parameter MARK specifies a face or single-character string to
+use when highlighting the day in the calendar."
+ (let ((dd (if european-calendar-style
month
day))
- (mm (if european-calendar-style
+ (mm (if european-calendar-style
day
month))
- (m (extract-calendar-month date))
- (y (extract-calendar-year date))
- (d (extract-calendar-day date)))
+ (m (extract-calendar-month date))
+ (y (extract-calendar-year date))
+ (d (extract-calendar-day date)))
(if (and
(or (and (listp dd) (memq d dd))
(equal d dd)
(or (and (listp year) (memq y year))
(equal y year)
(eq year t)))
- entry)))
+ (cons mark entry))))
-(defun diary-block (m1 d1 y1 m2 d2 y2)
+(defun diary-block (m1 d1 y1 m2 d2 y2 &optional mark)
"Block diary entry.
-Entry applies if date is between two dates. Order of the parameters is
-M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
-D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
+Entry applies if date is between, or on one of, two dates.
+The order of the parameters is
+M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and
+D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t.
+
+An optional parameter MARK specifies a face or single-character string to
+use when highlighting the day in the calendar."
+
(let ((date1 (calendar-absolute-from-gregorian
(if european-calendar-style
(list d1 m1 y1)
(list m2 d2 y2))))
(d (calendar-absolute-from-gregorian date)))
(if (and (<= date1 d) (<= d date2))
- entry)))
+ (cons mark entry))))
-(defun diary-float (month dayname n)
+(defun diary-float (month dayname n &optional day mark)
"Floating diary entry--entry applies if date is the nth dayname of month.
Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
t, or an integer. The constant t means all months. If N is negative, count
-backward from the end of the month."
- (let ((m (extract-calendar-month date))
- (y (extract-calendar-year date)))
- (if (and
- (or (and (listp month) (memq m month))
- (equal m month)
- (eq month t))
- (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
- entry)))
-
-(defun diary-anniversary (month day year)
+backward from the end of the month.
+
+An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
+Optional MARK specifies a face or single-character string to use when
+highlighting the day in the calendar."
+;; This is messy because the diary entry may apply, but the date on which it
+;; is based can be in a different month/year. For example, asking for the
+;; first Monday after December 30. For large values of |n| the problem is
+;; more grotesque.
+ (and (= dayname (calendar-day-of-week date))
+ (let* ((m (extract-calendar-month date))
+ (d (extract-calendar-day date))
+ (y (extract-calendar-year date))
+ (limit; last (n>0) or first (n<0) possible base date for entry
+ (calendar-nth-named-absday (- n) dayname m y d))
+ (last-abs (if (> n 0) limit (+ limit 6)))
+ (first-abs (if (> n 0) (- limit 6) limit))
+ (last (calendar-gregorian-from-absolute last-abs))
+ (first (calendar-gregorian-from-absolute first-abs))
+ ; m1, d1 is first possible base date
+ (m1 (extract-calendar-month first))
+ (d1 (extract-calendar-day first))
+ (y1 (extract-calendar-year first))
+ ; m2, d2 is last possible base date
+ (m2 (extract-calendar-month last))
+ (d2 (extract-calendar-day last))
+ (y2 (extract-calendar-year last)))
+ (if (or (and (= m1 m2) ; only possible base dates in one month
+ (or (eq month t)
+ (if (listp month)
+ (memq m1 month)
+ (= m1 month)))
+ (let ((d (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m1 y1)))))
+ (and (<= d1 d) (<= d d2))))
+ ;; only possible base dates straddle two months
+ (and (or (< y1 y2)
+ (and (= y1 y2) (< m1 m2)))
+ (or
+ ;; m1, d1 works as a base date
+ (and
+ (or (eq month t)
+ (if (listp month)
+ (memq m1 month)
+ (= m1 month)))
+ (<= d1 (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m1 y1)))))
+ ;; m2, d2 works as a base date
+ (and (or (eq month t)
+ (if (listp month)
+ (memq m2 month)
+ (= m2 month)))
+ (<= (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m2 y2)))
+ d2)))))
+ (cons mark entry)))))
+
+
+(defun diary-anniversary (month day year &optional mark)
"Anniversary diary entry.
Entry applies if date is the anniversary of MONTH, DAY, YEAR if
`european-calendar-style' is nil, and DAY, MONTH, YEAR if
%d will be replaced by the number of years since the MONTH DAY, YEAR and the
%s will be replaced by the ordinal ending of that number (that is, `st', `nd',
`rd' or `th', as appropriate. The anniversary of February 29 is considered
-to be March 1 in non-leap years."
+to be March 1 in non-leap years.
+
+An optional parameter MARK specifies a face or single-character string to
+use when highlighting the day in the calendar."
(let* ((d (if european-calendar-style
month
day))
(setq m 3
d 1))
(if (and (> diff 0) (calendar-date-equal (list m d y) date))
- (format entry diff (diary-ordinal-suffix diff)))))
+ (cons mark (format entry diff (diary-ordinal-suffix diff))))))
-(defun diary-cyclic (n month day year)
+(defun diary-cyclic (n month day year &optional mark)
"Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
-years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
-ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
+repetitions since the MONTH DAY, YEAR and %s will be replaced by the
+ordinal ending of that number (that is, `st', `nd', `rd' or `th', as
+appropriate.
+
+An optional parameter MARK specifies a face or single-character string to
+use when highlighting the day in the calendar."
(let* ((d (if european-calendar-style
month
day))
(list m d year))))
(cycle (/ diff n)))
(if (and (>= diff 0) (zerop (% diff n)))
- (format entry cycle (diary-ordinal-suffix cycle)))))
+ (cons mark (format entry cycle (diary-ordinal-suffix cycle))))))
(defun diary-ordinal-suffix (n)
"Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
diary-entry)
"*Pseudo-pattern giving form of reminder messages in the fancy diary
display.
-
+
Used by the function `diary-remind', a pseudo-pattern is a list of
expressions that can involve the keywords `days' (a number), `date' (a list of
month, day, year), and `diary-entry' (a string)."
SEXP, then a suitable message (as specified by `diary-remind-message' is
returned.
-In addition to the reminders beforehand, the diary entry also appears on
-the date itself.
-
-If optional parameter MARKING is non-nil then the reminders are marked on the
-calendar. Marking of reminders is independent of whether the entry itself is
-a marking or nonmarking one."
- (let ((diary-entry))
- (if (or (not marking-diary-entries) marking)
- (cond
- ((integerp days)
- (let ((date (calendar-gregorian-from-absolute
- (+ (calendar-absolute-from-gregorian date) days))))
- (if (setq diary-entry (eval sexp))
- (setq diary-entry (mapconcat 'eval diary-remind-message "")))))
- ((and (listp days) days)
- (setq diary-entry (diary-remind sexp (car days) marking))
- (if (not diary-entry)
- (setq diary-entry (diary-remind sexp (cdr days) marking))))))
- (or diary-entry
- (and (or (not marking-diary-entries) marking-diary-entry)
- (eval sexp)))))
-
-(defun add-to-diary-list (date string)
- "Add the entry (DATE STRING) to `diary-entries-list'.
+In addition to the reminders beforehand, the diary entry also appears on the
+date itself.
+
+A `diary-nonmarking-symbol' at the beginning of the line of the diary-remind
+entry specifies that the diary entry (not the reminder) is non-marking.
+Marking of reminders is independent of whether the entry itself is a marking
+or nonmarking; if optional parameter MARKING is non-nil then the reminders are
+marked on the calendar."
+ (let ((diary-entry (eval sexp)))
+ (cond
+ ;; Diary entry applies on date
+ ((and diary-entry
+ (or (not marking-diary-entries) marking-diary-entry))
+ diary-entry)
+ ;; Diary entry may apply to `days' before date
+ ((and (integerp days)
+ (not diary-entry); Diary entry does not apply to date
+ (or (not marking-diary-entries) marking))
+ (let ((date (calendar-gregorian-from-absolute
+ (+ (calendar-absolute-from-gregorian date) days))))
+ (if (setq diary-entry (eval sexp))
+ (mapconcat 'eval diary-remind-message ""))))
+ ;; Diary entry may apply to one of a list of days before date
+ ((and (listp days) days)
+ (or (diary-remind sexp (car days) marking)
+ (diary-remind sexp (cdr days) marking))))))
+
+(defun add-to-diary-list (date string specifier marker &optional globcolor)
+ "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'.
Do nothing if DATE or STRING is nil."
- (and date string
- (setq diary-entries-list
- (append diary-entries-list (list (list date string))))))
+ (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)))))
+ (setq diary-entries-list
+ (append diary-entries-list
+ (list (list date string specifier marker globcolor))))))
(defun make-diary-entry (string &optional nonmarking file)
"Insert a diary entry STRING which may be NONMARKING in FILE.
-If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
- (find-file-other-window
- (substitute-in-file-name (if file file diary-file)))
+If omitted, NONMARKING defaults to nil and FILE defaults to `diary-file'."
+ (let ((pop-up-frames (window-dedicated-p (selected-window))))
+ (find-file-other-window (substitute-in-file-name (or file diary-file))))
+ (widen)
(goto-char (point-max))
+ (when (let ((case-fold-search t))
+ (search-backward "Local Variables:"
+ (max (- (point-max) 3000) (point-min))
+ t))
+ (beginning-of-line)
+ (insert "\n")
+ (previous-line 1))
(insert
(if (bolp) "" "\n")
(if nonmarking diary-nonmarking-symbol "")
"Insert a monthly diary entry for the day of the month indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " * ")
- '("* " day))))
+ (let ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " * ")
+ '("* " day))))
(make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
arg)))
"Insert an annual diary entry for the day of the year indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " monthname)
- '(monthname " " day))))
+ (let ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " monthname)
+ '(monthname " " day))))
(make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
arg)))
"Insert an anniversary diary entry for the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year))))
+ (let ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year))))
(make-diary-entry
(format "%s(diary-anniversary %s)"
sexp-diary-entry-symbol
"Insert a block diary entry for the days between the point and marked date.
Prefix arg will make the entry nonmarking."
(interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year)))
+ (let ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year)))
(cursor (calendar-cursor-to-date t))
(mark (or (car calendar-mark-ring)
(error "No mark set in this buffer")))
- (start)
- (end))
+ start end)
(if (< (calendar-absolute-from-gregorian mark)
(calendar-absolute-from-gregorian cursor))
(setq start mark
"Insert a cyclic diary entry starting at the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year))))
+ (let ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year))))
(make-diary-entry
(format "%s(diary-cyclic %d %s)"
sexp-diary-entry-symbol
(calendar-read "Repeat every how many days: "
- '(lambda (x) (> x 0)))
+ (lambda (x) (> x 0)))
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))
+;;;###autoload
+(define-derived-mode diary-mode text-mode
+ "Diary"
+ "Major mode for editing the diary file."
+ (set (make-local-variable 'font-lock-defaults)
+ '(diary-font-lock-keywords t)))
+
+(define-derived-mode fancy-diary-display-mode text-mode
+ "Diary"
+ "Major mode used while displaying diary entries using Fancy Display."
+ (set (make-local-variable 'font-lock-defaults)
+ '(fancy-diary-font-lock-keywords t))
+ (define-key (current-local-map) "q" 'quit-window))
+
+
+(defvar fancy-diary-font-lock-keywords
+ (list
+ (cons
+ (concat
+ (let ((dayname (diary-name-pattern calendar-day-name-array nil t))
+ (monthname (diary-name-pattern calendar-month-name-array nil t))
+ (day "[0-9]+")
+ (month "[0-9]+")
+ (year "-?[0-9]+"))
+ (mapconcat 'eval calendar-date-display-form ""))
+ "\\(\\(: .*\\)\\|\\(\n +.*\\)\\)*\n=+$")
+ 'diary-face)
+ '("^.*anniversary.*$" . font-lock-keyword-face)
+ '("^.*birthday.*$" . font-lock-keyword-face)
+ '("^.*Yahrzeit.*$" . font-lock-reference-face)
+ '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
+ '("^Day.*omer.*$" . font-lock-builtin-face)
+ '("^Parashat.*$" . font-lock-comment-face)
+ '("^[ \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\\)?\\)?"
+ . font-lock-variable-name-face))
+ "Keywords to highlight in fancy diary display")
+
+
+(defun font-lock-diary-sexps (limit)
+ "Recognize sexp diary entry for font-locking."
+ (if (re-search-forward
+ (concat "^" (regexp-quote diary-nonmarking-symbol)
+ "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
+ limit t)
+ (condition-case nil
+ (save-restriction
+ (narrow-to-region (point-min) limit)
+ (let ((start (point)))
+ (forward-sexp 1)
+ (store-match-data (list start (point)))
+ t))
+ (error t))))
+
+(defun font-lock-diary-date-forms (month-array &optional symbol abbrev-array)
+ "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY.
+If given, optional SYMBOL must be a prefix to entries.
+If optional ABBREV-ARRAY is present, the abbreviations constructed
+from this array by the function `calendar-abbrev-construct' are
+matched (with or without a final `.'), in addition to the full month
+names."
+ (let ((dayname (diary-name-pattern calendar-day-name-array
+ calendar-day-abbrev-array t))
+ (monthname (format "\\(%s\\|\\*\\)"
+ (diary-name-pattern month-array abbrev-array)))
+ (month "\\([0-9]+\\|\\*\\)")
+ (day "\\([0-9]+\\|\\*\\)")
+ (year "-?\\([0-9]+\\|\\*\\)"))
+ (mapcar '(lambda (x)
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
+ (if symbol (regexp-quote symbol) "") "\\("
+ (mapconcat 'eval
+ ;; If backup, omit first item (backup)
+ ;; and last item (not part of date)
+ (if (equal (car x) 'backup)
+ (reverse (cdr (reverse (cdr x))))
+ x)
+ "")
+ ;; With backup, last item is not part of date
+ (if (equal (car x) 'backup)
+ (concat "\\)" (eval (car (reverse x))))
+ "\\)"))
+ '(1 diary-face)))
+ diary-date-forms)))
+
+(eval-when-compile (require 'cal-hebrew)
+ (require 'cal-islam))
+
+(defvar diary-font-lock-keywords
+ (append
+ (font-lock-diary-date-forms calendar-month-name-array
+ nil calendar-month-abbrev-array)
+ (when (or (memq 'mark-hebrew-diary-entries
+ nongregorian-diary-marking-hook)
+ (memq 'list-hebrew-diary-entries
+ nongregorian-diary-listing-hook))
+ (require 'cal-hebrew)
+ (font-lock-diary-date-forms
+ calendar-hebrew-month-name-array-leap-year
+ hebrew-diary-entry-symbol))
+ (when (or (memq 'mark-islamic-diary-entries
+ nongregorian-diary-marking-hook)
+ (memq 'list-islamic-diary-entries
+ nongregorian-diary-listing-hook))
+ (require 'cal-islam)
+ (font-lock-diary-date-forms
+ calendar-islamic-month-name-array
+ islamic-diary-entry-symbol))
+ (list
+ (cons
+ (concat "^" (regexp-quote diary-include-string) ".*$")
+ 'font-lock-keyword-face)
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol)
+ "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
+ '(1 font-lock-reference-face))
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol))
+ 'font-lock-reference-face)
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol)
+ "?\\(" (regexp-quote hebrew-diary-entry-symbol) "\\)")
+ '(1 font-lock-reference-face))
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol)
+ "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)")
+ '(1 font-lock-reference-face))
+ '(font-lock-diary-sexps . font-lock-keyword-face)
+ '("[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\(-[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\)?"
+ . font-lock-function-name-face)))
+ "Forms to highlight in diary-mode")
+
+
(provide 'diary-lib)
+;;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
;;; diary-lib.el ends here