;;; 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, 2001, 2002, 2003,
+;; 2004, 2005 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.
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(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!"))))
-
-(defun view-diary-entries (arg)
+ (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")
- (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)
+ (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.
-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))
+ (list (prefix-numeric-value current-prefix-arg)
(read-file-name "Enter diary file name: " default-directory nil t)))
(let ((diary-file d-file))
(view-diary-entries arg)))
(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."
+ t)
+
+(autoload 'list-bahai-diary-entries "cal-bahai"
+ "Add any Baha'i date entries from the diary file to `diary-entries-list'."
+ t)
+
+(autoload 'mark-bahai-diary-entries "cal-bahai"
+ "Mark days in the calendar window that have Baha'i date diary entries."
+ t)
+
+(autoload 'mark-bahai-calendar-date-pattern "cal-bahai"
+ "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR."
+ t)
+
(autoload 'diary-hebrew-date "cal-hebrew"
"Hebrew calendar equivalent of date diary entry.")
"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 (copy-syntax-table (standard-syntax-table))
+(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 `*' changed to be a word constituent.")
-
-(modify-syntax-entry ?* "w" diary-syntax-table)
-(modify-syntax-entry ?: "w" diary-syntax-table)
+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))))
+
+
+;; 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, `diary-simple-display' will show a header line.
+The format of the header is specified by `diary-header-line-format'."
+ :group 'diary
+ :type 'boolean
+ :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 `diary-simple-display'.
+Only used if `diary-header-line-flag' is non-nil."
+ :group 'diary
+ :type 'sexp
+ :version "22.1")
+
+(defvar diary-saved-point) ; internal
+
+
+(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 display the entries
+for the current date and the day after on Monday through Thursday,
+display Friday through Monday's entries on Friday, and display 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")))
+ :group 'diary)
-(defun list-diary-entries (date number)
- "Create and display a buffer containing the relevant lines in diary-file.
+(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.
+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)
+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',
add-hook to set this to ignore.
`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
- (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
- (goto-char (point-max))
- (insert "\^M")))
- (goto-char (point-min))
- (if (not (looking-at "\^M\\|\n"))
- (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)
- (month (extract-calendar-month date))
+ 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.
+ (when (eq major-mode default-major-mode) (diary-mode))
+ ;; 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)))
- (while d
+ (dolist (date-form diary-date-forms)
(let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)))
- (backup (equal (car (car d)) 'backup))
+ ((backup (when (eq (car date-form) 'backup)
+ (setq date-form (cdr date-form))
+ t))
(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
(regexp
(concat
"\\(\\`\\|\^M\\|\n\\)" mark "?\\("
- (mapconcat 'eval date-form "\\)\\(")
+ (mapconcat 'eval date-form "\\)\\(?:")
"\\)"))
(case-fold-search t))
(goto-char (point-min))
(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.
+ ;; Found a nonempty diary entry--make it
+ ;; visible and 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)
+ ;; 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 t))
- (backward-char 1)
- (subst-char-in-region date-start
- (point) ?\^M ?\n t)
+ (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
- entry-start (point))
- (buffer-substring
- (1+ date-start) (1- entry-start)))))))
- (setq d (cdr d)))
+ (1+ date-start) (1- entry-start))
+ (copy-marker entry-start) (nth 1 temp)))))))
(or entry-found
(not diary-list-include-blanks)
(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))))
- (setq entry-found nil)))
- (set-buffer-modified-p diary-modified))
- (set-syntax-table old-diary-syntax-table))
- (goto-char (point-min))
- (run-hooks 'nongregorian-diary-listing-hook
- 'list-diary-entries-hook)
- (if diary-display-hook
- (run-hooks 'diary-display-hook)
- (simple-diary-display))
- (run-hooks 'diary-hook)
- diary-entries-list))))
+ (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.
(goto-char (point-min))
(while (re-search-forward
(concat
- "\\(\\`\\|\^M\\|\n\\)"
+ "\\(?:\\`\\|\^M\\|\n\\)"
(regexp-quote diary-include-string)
" \"\\([^\"]*\\)\"")
nil t)
(let* ((diary-file (substitute-in-file-name
- (buffer-substring-no-properties
- (match-beginning 2) (match-end 2))))
+ (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)
- (d-buffer (find-buffer-visiting diary-file))
- (diary-modified (if d-buffer
- (save-excursion
- (set-buffer d-buffer)
- (buffer-modified-p)))))
+ (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
(list-diary-entries original-date number)))
- (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)))
+ (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))
"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 "; "))))
- (calendar-set-mode-line
- (concat "Diary for " 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))
- (display-buffer (find-buffer-visiting d-file))
+ (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 ((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'."
- (save-excursion;; Turn off selective-display in the diary file's buffer.
- (set-buffer (find-buffer-visiting (substitute-in-file-name diary-file)))
- (let ((diary-modified (buffer-modified-p)))
- (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
- (setq selective-display nil)
- (kill-local-variable 'mode-line-format)
- (set-buffer-modified-p diary-modified)))
+ (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))) "")))
(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))
(setq buffer-read-only t)
(display-buffer holiday-buffer)
(message "No diary entries for %s" date-string)))
- (save-excursion;; Prepare the fancy diary buffer.
- (set-buffer (make-fancy-diary-buffer))
+ (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)
(extract-calendar-month date))
(setq holiday-list-last-year
(extract-calendar-year date))
- (increment-calendar-month
- holiday-list-last-month holiday-list-last-year 1)
+ (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))
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)
+ (calendar-set-mode-line date-string)
(message "Preparing diary...done"))))
(defun make-fancy-diary-buffer ()
"Create and return the initial fancy diary buffer."
- (save-excursion
- (set-buffer (get-buffer-create fancy-diary-buffer))
+ (with-current-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)
the actual printing."
(interactive)
(if (bufferp (get-buffer fancy-diary-buffer))
- (save-excursion
- (set-buffer (get-buffer fancy-diary-buffer))
+ (with-current-buffer (get-buffer fancy-diary-buffer)
(run-hooks 'print-diary-entries-hook))
(let ((diary-buffer
(find-buffer-visiting (substitute-in-file-name diary-file))))
(if diary-buffer
- (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
+ (let ((temp-buffer (get-buffer-create " *Printable Diary Entries*"))
(heading))
- (save-excursion
- (set-buffer diary-buffer)
+ (with-current-buffer diary-buffer
(setq heading
(if (not (stringp mode-line-format))
"All Diary Entries"
(string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
- (substring mode-line-format
- (match-beginning 1) (match-end 1))))
- (copy-to-buffer temp-buffer (point-min) (point-max))
+ (match-string 1 mode-line-format)))
+ (let ((start (point-min))
+ end)
+ (while
+ (progn
+ (setq end (next-single-char-property-change
+ start 'invisible))
+ (if (get-char-property start 'invisible)
+ nil
+ (with-current-buffer temp-buffer
+ (insert-buffer-substring diary-buffer
+ start (or end (point-max)))))
+ (setq start end)
+ (and end (< end (point-max))))))
(set-buffer temp-buffer)
- (while (re-search-forward "\^M.*$" nil t)
- (replace-match ""))
(goto-char (point-min))
(insert heading "\n"
(make-string (length heading) ?=) "\n")
(kill-buffer temp-buffer)))
(error "You don't have a diary buffer!")))))
-(defun show-all-diary-entries ()
+(define-obsolete-function-alias 'show-all-diary-entries 'diary-show-all-entries)
+(defun diary-show-all-entries ()
"Show all of the diary entries in the diary file.
This function gets rid of the selective display of the diary file so that
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!"))))
-
-
+ (let ((d-file (diary-check-diary-file))
+ (pop-up-frames (window-dedicated-p (selected-window))))
+ (with-current-buffer (or (find-buffer-visiting d-file)
+ (find-file-noselect d-file t))
+ (when (eq major-mode default-major-mode) (diary-mode))
+ (diary-unhide-everything)
+ (display-buffer (current-buffer)))))
(defcustom diary-mail-addr
- (if (boundp 'user-mail-address) user-mail-address nil)
- "*Email address that `diary-mail-entries' will send email to."
+ (if (boundp 'user-mail-address) user-mail-address "")
+ "Email address that `diary-mail-entries' will send email to."
:group 'diary
- :type '(choice string (const nil))
+ :type 'string
:version "20.3")
(defcustom diary-mail-days 7
- "*Number of days for `diary-mail-entries' to check."
+ "Default number of days for `diary-mail-entries' to check."
:group 'diary
:type 'integer
:version "20.3")
(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
# 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
0 1 * * * diary-rem.sh
to run it every morning at 1am."
(interactive "P")
- (let* ((diary-display-hook 'fancy-diary-display)
- (diary-list-include-blanks t)
- (text (progn (list-diary-entries (calendar-current-date)
- (if ndays ndays diary-mail-days))
- (set-buffer fancy-diary-buffer)
- (buffer-substring (point-min) (point-max)))))
- (mail)
- (mail-to) (insert diary-mail-addr)
- (mail-subject) (insert "Diary entries generated "
- (calendar-date-string (calendar-current-date)))
- (mail-text) (insert text)
- (mail-send-and-exit nil)))
-
-
-(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))
+ (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)
+ (with-current-buffer fancy-diary-buffer (buffer-string))
+ "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.")
(defvar marking-diary-entry nil
"True during the marking of diary entries, if current entry is marking.")
-(defun mark-diary-entries ()
+(defun mark-diary-entries (&optional redraw)
"Mark days in the calendar window that have diary entries.
-Each entry in the diary file visible in the calendar window is marked.
-After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
-`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-ignore-case
- (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-ignore-case
- (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!"))))
+Each entry in the diary file visible in the calendar window is
+marked. After the entries are marked, the hooks
+`nongregorian-diary-marking-hook' and `mark-diary-entries-hook'
+are run. If the optional argument REDRAW is non-nil (which is
+the case interactively, for example) then any existing diary
+marks are first removed. This is intended to deal with deleted
+diary entries."
+ (interactive "p")
+ ;; To remove any deleted diary entries. Do not redraw when:
+ ;; i) processing #include diary files (else only get the marks from
+ ;; the last #include file processed).
+ ;; ii) called via calendar-redraw (since calendar has already been
+ ;; erased).
+ ;; Use of REDRAW handles both of these cases.
+ (when (and redraw mark-diary-entries-in-calendar)
+ (setq mark-diary-entries-in-calendar nil)
+ (redraw-calendar))
+ (let ((marking-diary-entries t)
+ file-glob-attrs marks)
+ (with-current-buffer (find-file-noselect (diary-check-diary-file) t)
+ (save-excursion
+ (when (eq major-mode default-major-mode) (diary-mode))
+ (setq mark-diary-entries-in-calendar t)
+ (message "Marking diary entries...")
+ (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
+ (with-syntax-table diary-syntax-table
+ (dolist (date-form diary-date-forms)
+ (if (eq (car date-form) 'backup)
+ (setq date-form (cdr date-form))) ;; ignore 'backup directive
+ (let* ((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
+ (match-string-no-properties d-name-pos)))
+ (mm-name
+ (if m-name-pos
+ (match-string-no-properties m-name-pos)))
+ (mm (string-to-number
+ (if m-pos
+ (match-string-no-properties m-pos)
+ "")))
+ (dd (string-to-number
+ (if d-pos
+ (match-string-no-properties d-pos)
+ "")))
+ (y-str (if y-pos
+ (match-string-no-properties 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-number y-str)
+ (* 100
+ (/ current-y 100)))))
+ (if (> (- y current-y) 50)
+ (- y 100)
+ (if (> (- current-y y) 50)
+ (+ y 100)
+ y)))
+ (string-to-number y-str)))))
+ (let ((tmp (diary-pull-attrs (buffer-substring-no-properties
+ (point) (line-end-position))
+ file-glob-attrs)))
+ (setq entry (nth 0 tmp)
+ marks (nth 1 tmp)))
+ (if dd-name
+ (mark-calendar-days-named
+ (cdr (assoc-string
+ dd-name
+ (calendar-make-alist
+ calendar-day-name-array
+ 0 nil calendar-day-abbrev-array) t)) marks)
+ (if mm-name
+ (setq mm
+ (if (string-equal mm-name "*") 0
+ (cdr (assoc-string
+ mm-name
+ (calendar-make-alist
+ calendar-month-name-array
+ 1 nil calendar-month-abbrev-array) t)))))
+ (mark-calendar-date-pattern mm dd yy marks))))))
+ (mark-sexp-diary-entries)
+ (run-hooks 'nongregorian-diary-marking-hook
+ 'mark-diary-entries-hook))
+ (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)
- (mark))
- (save-excursion
- (set-buffer calendar-buffer)
+ sexp-mark "(diary-remind\\)"))
+ (file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
+ m y first-date last-date mark file-glob-attrs)
+ (with-current-buffer calendar-buffer
(setq m displayed-month)
(setq y displayed-year))
(increment-calendar-month m y -1)
(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
(calendar-for-loop date from first-date to last-date do
(if (setq mark (diary-sexp-entry sexp entry
(calendar-gregorian-from-absolute date)))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date)
- (if (consp mark)
- (car mark)))))))))
+ (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.
(goto-char (point-min))
(while (re-search-forward
(concat
- "\\(\\`\\|\^M\\|\n\\)"
+ "\\(?:\\`\\|\^M\\|\n\\)"
(regexp-quote diary-include-string)
" \"\\([^\"]*\\)\"")
nil t)
- (let ((diary-file (substitute-in-file-name
- (buffer-substring-no-properties
- (match-beginning 2) (match-end 2))))
- (mark-diary-entries-hook 'mark-included-diary-files))
+ (let* ((diary-file (substitute-in-file-name
+ (match-string-no-properties 1)))
+ (mark-diary-entries-hook 'mark-included-diary-files)
+ (dbuff (find-buffer-visiting diary-file)))
(if (file-exists-p diary-file)
(if (file-readable-p diary-file)
(progn
(mark-diary-entries)
- (kill-buffer (find-buffer-visiting diary-file)))
+ (unless dbuff
+ (kill-buffer (find-buffer-visiting diary-file))))
(beep)
(message "Can't read included diary file %s" diary-file)
(sleep-for 2))
(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
- (set-buffer calendar-buffer)
+ (with-current-buffer calendar-buffer
(let ((prev-month displayed-month)
(prev-year displayed-year)
(succ-month displayed-month)
(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
- (set-buffer calendar-buffer)
+ (with-current-buffer calendar-buffer
(let ((m displayed-month)
(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."
(defcustom diary-unknown-time
-9999
- "*Value returned by diary-entry-time when no time is found.
+ "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."
(defun diary-entry-time (s)
"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."
+
+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)))))
+ "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
+ s)
+ (+ (* 100 (string-to-number (match-string 1 s)))
+ (string-to-number (match-string 2 s))))
((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))
+ (+ (* 100 (% (string-to-number (match-string 1 s)) 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)))
+ "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
+ (string-to-number (match-string 2 s))
(if (equal ?a (downcase (aref s (match-beginning 3))))
0 1200)))
(t diary-unknown-time)))) ; Unrecognizable
+;; Unrecognizable
+
(defun list-sexp-diary-entries (date)
"Add sexp entries for DATE from the diary file to `diary-entries-list'.
Also, Make them visible in the diary file. Returns t if any entries were
`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. An optional parameter
+ 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.
the month. MONTH can be a list of months, a single
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
+ 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 &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.) An optional parameter MARK specifies a face
- or single-character string to use when highlighting the
+ 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 &optional MARK) 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. An
- optional parameter MARK specifies a face or single-character
+ 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 &optional MARK) 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. An optional
- parameter MARK specifies a face or single-character string
+ `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
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)
- (specifier)
- (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)))
+ (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
- (if (consp diary-entry)
- (cdr diary-entry)
- diary-entry)
- specifier)
+ (progn
+ (remove-overlays line-start (point) 'invisible 'diary)
+ (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))
(error
(beep)
(message "Bad sexp at line %d in %s: %s"
- (save-excursion
- (save-restriction
- (narrow-to-region 1 (point))
- (goto-char (point-min))
- (let ((lines 1))
- (while (re-search-forward "\n\\|\^M" nil t)
- (setq lines (1+ lines)))
- lines)))
+ (count-lines (point-min) (point))
diary-file sexp)
(sleep-for 2))))))
(cond ((stringp result) result)
can be lists of integers, the constant t, or an integer. The constant t means
all values.
-An optional parameter MARK specifies a face or single-character string to
+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
+ (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 &optional mark)
"Block diary entry.
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
+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
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
+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
(cons mark entry)))))
-(defun diary-anniversary (month day year &optional mark)
+(defun diary-anniversary (month day &optional year 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
`rd' or `th', as appropriate. The anniversary of February 29 is considered
to be March 1 in non-leap years.
-An optional parameter MARK specifies a face or single-character string to
+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
month))
(y (extract-calendar-year date))
- (diff (- y year)))
+ (diff (if year (- y year) 100)))
(if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
(setq m 3
d 1))
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
+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
(concat (int-to-string days) (if (= 1 days) " day" " days")))
" until "
diary-entry)
- "*Pseudo-pattern giving form of reminder messages in the fancy diary
+ "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
(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 ""))))
+ (when (setq diary-entry (eval sexp)) ; re-evaluate with adjusted date
+ ;; Discard any mark portion from diary-anniversary, etc.
+ (if (consp diary-entry) (setq diary-entry (cdr diary-entry)))
+ (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)
- "Add the entry (DATE STRING SPECIFIER) to `diary-entries-list'.
+(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)
+ "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 specifier))))))
+ (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 marker globcolor))))))
+
+(defun diary-redraw-calendar ()
+ "If `calendar-buffer' is live and diary entries are marked, redraw it."
+ (and mark-diary-entries-in-calendar
+ (save-excursion
+ (redraw-calendar)))
+ ;; Return value suitable for `write-contents-functions'.
+ nil)
(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))))
+ (when (eq major-mode default-major-mode) (diary-mode))
+ (widen)
+ (diary-unhide-everything)
(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")
+ (forward-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-date-string (calendar-cursor-to-date t) nil t))
arg)))
+(defvar diary-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-s" 'diary-show-all-entries)
+ (define-key map "\C-c\C-q" 'quit-window)
+ map)
+ "Keymap for `diary-mode'.")
+
+;;;###autoload
+(define-derived-mode diary-mode fundamental-mode "Diary"
+ "Major mode for editing the diary file."
+ (set (make-local-variable 'font-lock-defaults)
+ '(diary-font-lock-keywords t))
+ (add-to-invisibility-spec '(diary . nil))
+ (add-hook 'after-save-hook 'diary-redraw-calendar nil t)
+ (if diary-header-line-flag
+ (setq header-line-format diary-header-line-format)))
+
+(define-derived-mode fancy-diary-display-mode fundamental-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))
+ (local-set-key "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 diary-font-lock-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 diary-font-lock-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)
+ (nreverse (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))
+
+(defconst diary-time-regexp
+ ;; Formats that should be accepted:
+ ;; 10:00 10.00 10h00 10h 10am 10:00am 10.00am
+ (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\("
+ "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]"
+ "\\)\\([AaPp][Mm]\\)?\\)"))
+
+(defvar diary-font-lock-keywords
+ (append
+ (diary-font-lock-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)
+ (diary-font-lock-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)
+ (diary-font-lock-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))
+ '(diary-font-lock-sexps . font-lock-keyword-face)
+ (cons
+ (concat ;; "^[ \t]+"
+ diary-time-regexp "\\(-" diary-time-regexp "\\)?")
+ 'font-lock-function-name-face)))
+ "Forms to highlight in `diary-mode'.")
+
+
+;; Following code from Dave Love <fx@gnu.org>.
+;; Import Outlook-format appointments from mail messages in Gnus or
+;; Rmail using command `diary-from-outlook'. This, or the specialized
+;; functions `diary-from-outlook-gnus' and `diary-from-outlook-rmail',
+;; could be run from hooks to notice appointments automatically (in
+;; which case they will prompt about adding to the diary). The
+;; message formats recognized are customizable through
+;; `diary-outlook-formats'.
+
+(defcustom diary-outlook-formats
+ '(
+ ;; When: 11 October 2001 12:00-14:00 (GMT) Greenwich Mean Time : Dublin, ...
+ ;; [Current UK format? The timezone is meaningless. Sometimes the
+ ;; Where is missing.]
+ ("When: \\([0-9]+ [[:alpha:]]+ [0-9]+\\) \
+\\([^ ]+\\) [^\n]+
+\[^\n]+
+\\(?:Where: \\([^\n]+\\)\n+\\)?
+\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*"
+ . "\\1\n \\2 %s, \\3")
+ ;; When: Tuesday, April 30, 2002 03:00 PM-03:30 PM (GMT) Greenwich Mean ...
+ ;; [Old UK format?]
+ ("^When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \\([0-9]\\{4\\}\\) \
+\\([^ ]+\\) [^\n]+
+\[^\n]+
+\\(?:Where: \\([^\n]+\\)\\)?\n+"
+ . "\\2 \\1 \\3\n \\4 %s, \\5")
+ (
+ ;; German format, apparently.
+ "^Zeit: [^ ]+, +\\([0-9]+\\)\. +\\([[:upper:]][[:lower:]][[:lower:]]\\)[^ ]* +\\([0-9]+\\) +\\([^ ]+\\).*$"
+ . "\\1 \\2 \\3\n \\4 %s"))
+ "Alist of regexps matching message text and replacement text.
+
+The regexp must match the start of the message text containing an
+appointment, but need not include a leading `^'. If it matches the
+current message, a diary entry is made from the corresponding
+template. If the template is a string, it should be suitable for
+passing to `replace-match', and so will have occurrences of `\\D' to
+substitute the match for the Dth subexpression. It must also contain
+a single `%s' which will be replaced with the text of the message's
+Subject field. Any other `%' characters must be doubled, so that the
+template can be passed to `format'.
+
+If the template is actually a function, it is called with the message
+body text as argument, and may use `match-string' etc. to make a
+template following the rules above."
+ :type '(alist :key-type (regexp :tag "Regexp matching time/place")
+ :value-type (choice
+ (string :tag "Template for entry")
+ (function :tag "Unary function providing template")))
+ :version "22.1"
+ :group 'diary)
+
+
+;; Dynamically bound.
+(defvar body)
+(defvar subject)
+
+(defun diary-from-outlook-internal (&optional test-only)
+ "Snarf a diary entry from a message assumed to be from MS Outlook.
+Assumes `body' is bound to a string comprising the body of the message and
+`subject' is bound to a string comprising its subject.
+Arg TEST-ONLY non-nil means return non-nil if and only if the
+message contains an appointment, don't make a diary entry."
+ (catch 'finished
+ (let (format-string)
+ (dotimes (i (length diary-outlook-formats))
+ (when (eq 0 (string-match (car (nth i diary-outlook-formats))
+ body))
+ (unless test-only
+ (setq format-string (cdr (nth i diary-outlook-formats)))
+ (save-excursion
+ (save-window-excursion
+ ;; Fixme: References to optional fields in the format
+ ;; are treated literally, not replaced by the empty
+ ;; string. I think this is an Emacs bug.
+ (make-diary-entry
+ (format (replace-match (if (functionp format-string)
+ (funcall format-string body)
+ format-string)
+ t nil (match-string 0 body))
+ subject))
+ (save-buffer))))
+ (throw 'finished t))))
+ nil))
+
+(defun diary-from-outlook (&optional noconfirm)
+ "Maybe snarf diary entry from current Outlook-generated message.
+Currently knows about Gnus and Rmail modes. Unless the optional
+argument NOCONFIRM is non-nil (which is the case when this
+function is called interactively), then if an entry is found the
+user is asked to confirm its addition."
+ (interactive "p")
+ (let ((func (cond
+ ((eq major-mode 'rmail-mode)
+ #'diary-from-outlook-rmail)
+ ((memq major-mode '(gnus-summary-mode gnus-article-mode))
+ #'diary-from-outlook-gnus)
+ (t (error "Don't know how to snarf in `%s'" major-mode)))))
+ (funcall func noconfirm)))
+
+
+(defvar gnus-article-mime-handles)
+(defvar gnus-article-buffer)
+
+(autoload 'gnus-fetch-field "gnus-util")
+(autoload 'gnus-narrow-to-body "gnus")
+(autoload 'mm-get-part "mm-decode")
+
+(defun diary-from-outlook-gnus (&optional noconfirm)
+ "Maybe snarf diary entry from Outlook-generated message in Gnus.
+Unless the optional argument NOCONFIRM is non-nil (which is the case when
+this function is called interactively), then if an entry is found the
+user is asked to confirm its addition.
+Add this function to `gnus-article-prepare-hook' to notice appointments
+automatically."
+ (interactive "p")
+ (with-current-buffer gnus-article-buffer
+ (let ((subject (gnus-fetch-field "subject"))
+ (body (if gnus-article-mime-handles
+ ;; We're multipart. Don't get confused by part
+ ;; buttons &c. Assume info is in first part.
+ (mm-get-part (nth 1 gnus-article-mime-handles))
+ (save-restriction
+ (gnus-narrow-to-body)
+ (buffer-string)))))
+ (when (diary-from-outlook-internal t)
+ (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
+
+(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus)
+
+
+(defvar rmail-buffer)
+
+(defun diary-from-outlook-rmail (&optional noconfirm)
+ "Maybe snarf diary entry from Outlook-generated message in Rmail.
+Unless the optional argument NOCONFIRM is non-nil (which is the case when
+this function is called interactively), then if an entry is found the
+user is asked to confirm its addition."
+ (interactive "p")
+ (with-current-buffer rmail-buffer
+ (let ((subject (mail-fetch-field "subject"))
+ (body (buffer-substring (save-excursion
+ (rfc822-goto-eoh)
+ (point))
+ (point-max))))
+ (when (diary-from-outlook-internal t)
+ (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
+
+
(provide 'diary-lib)
+;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
;;; diary-lib.el ends here
HCoop / bpt / emacs.git / blobdiff