+(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)))
+
+
+(defvar diary-fancy-date-pattern
+ (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 ""))
+ ;; Optional ": holiday name" after the date.
+ "\\(: .*\\)?")
+ "Regular expression matching a date header in Fancy Diary.")
+
+(defconst diary-time-regexp
+ ;; Accepted formats: 10:00 10.00 10h00 10h 10am 10:00am 10.00am
+ ;; Use of "." as a separator annoyingly matches numbers, eg "123.45".
+ ;; Hence often prefix this with "\\(^\\|\\s-\\)."
+ (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\("
+ "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]"
+ "\\)\\([AaPp][Mm]\\)?\\)")
+ "Regular expression matching a time of day.")
+
+(defface diary-anniversary '((t :inherit font-lock-keyword-face))
+ "Face used for anniversaries in the diary."
+ :version "22.1"
+ :group 'diary)
+
+(defface diary-time '((t :inherit font-lock-variable-name-face))
+ "Face used for times of day in the diary."
+ :version "22.1"
+ :group 'diary)
+
+(defvar fancy-diary-font-lock-keywords
+ (list
+ (list
+ ;; Any number of " other holiday name" lines, followed by "==" line.
+ (concat diary-fancy-date-pattern "\\(\n +.*\\)*\n=+$")
+ '(0 (progn (put-text-property (match-beginning 0) (match-end 0)
+ 'font-lock-multiline t)
+ diary-face)))
+ '("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary)
+ '("^.*Yahrzeit.*$" . font-lock-reference-face)
+ '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
+ '("^Day.*omer.*$" . font-lock-builtin-face)
+ '("^Parashat.*$" . font-lock-comment-face)
+ `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
+ diary-time-regexp) . 'diary-time))
+ "Keywords to highlight in fancy diary display")
+
+;; If region looks like it might start or end in the middle of a
+;; multiline pattern, extend the region to encompass the whole pattern.
+(defun diary-fancy-font-lock-fontify-region-function (beg end &optional verbose)
+ "Function to use for `font-lock-fontify-region-function' in Fancy Diary.
+Needed to handle multiline keyword in `fancy-diary-font-lock-keywords'."
+ (goto-char beg)
+ (forward-line 0)
+ (if (looking-at "=+$") (forward-line -1))
+ (while (and (looking-at " +[^ ]")
+ (zerop (forward-line -1))))
+ ;; This check not essential.
+ (if (looking-at diary-fancy-date-pattern)
+ (setq beg (line-beginning-position)))
+ (goto-char end)
+ (forward-line 0)
+ (while (and (looking-at " +[^ ]")
+ (zerop (forward-line 1))))
+ (if (looking-at "=+$")
+ (setq end (line-beginning-position 2)))
+ (font-lock-default-fontify-region beg end verbose))
+
+(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 nil nil nil
+ (font-lock-fontify-region-function
+ . diary-fancy-font-lock-fontify-region-function)))
+ (local-set-key "q" 'quit-window))
+
+
+(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))
+
+(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)
+ `(,(concat "\\(^\\|\\s-\\)"
+ diary-time-regexp "\\(-" diary-time-regexp "\\)?")
+ . 'diary-time)))
+ "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"))))))
+
+