emacs: lisp/calendar/diary-lib.el comparison

comparison lisp/calendar/diary-lib.el @ 90428:a8190f7e546e

Merge from emacs--devo--0 Patches applied: * emacs--devo--0 (patch 285-296) - Update from CVS - Merge from gnus--rel--5.10 - Update from CVS: admin/FOR-RELEASE: Update refcard section. * gnus--rel--5.10 (patch 102-104) - Update from CVS Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-64

author	Miles Bader <miles@gnu.org>
date	Wed, 07 Jun 2006 18:05:10 +0000
parents	a5812696f7bf 9a90863c52b1
children	95d0cdf160ea

comparison

equal deleted inserted replaced

-:ddb25860d044
+:a8190f7e546e
 (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."
+"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'."
+"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."
+"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."
+"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.")
 (autoload 'diary-omer "cal-hebrew"
 			 (integer :tag "Wednesday")
 			 (integer :tag "Thursday")
 			 (integer :tag "Friday")
 			 (integer :tag "Saturday")))
 :group 'diary)
+(defvar diary-modify-entry-list-string-function nil
+"Function applied to entry string before putting it into the entries list.
+Can be used by programs integrating a diary list into other buffers (e.g.
+org.el and planner.el) to modify the string or add properties to it.
+The function takes a string argument and must return a string.")
+(defun add-to-diary-list (date string specifier &optional marker
+globcolor literal)
+"Add an entry to `diary-entries-list'.
+Do nothing if DATE or STRING is nil.  DATE is the (MONTH DAY
+YEAR) for which the entry applies; STRING is the text of the
+entry as it will appear in the diary (i.e. with any format
+strings such as \"%d\" expanded); SPECIFIER is the date part of
+the entry as it appears in the diary-file; LITERAL is the entry
+as it appears in the diary-file (i.e. before expansion).  If
+LITERAL is nil, it is taken to be the same as STRING.
+The entry is added to the list as (DATE STRING SPECIFIER LOCATOR
+GLOBCOLOR), where LOCATOR has the form (MARKER FILENAME LITERAL),
+FILENAME being the file containing the diary entry."
+(when (and date string)
+(if diary-file-name-prefix
+(let ((prefix (funcall diary-file-name-prefix-function
+(buffer-file-name))))
+(or (string= prefix "")
+(setq string (format "[%s] %s" prefix string)))))
+(and diary-modify-entry-list-string-function
+	 (setq string (funcall diary-modify-entry-list-string-function
+			       string)))
+(setq diary-entries-list
+(append diary-entries-list
+(list (list date string specifier
+(list marker (buffer-file-name) literal)
+globcolor))))))
 (define-obsolete-function-alias 'list-diary-entries 'diary-list-entries)
 (defun diary-list-entries (date number &optional list-only)
 "Create and display a buffer containing the relevant lines in `diary-file'.
 The arguments are DATE and NUMBER; the entries selected are those
 (buffer-substring
 (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
+(add-to-diary-list date "" "" "" ""))
-(append diary-entries-list
-(list (list date "" "" "" "")))))
 (setq date
 (calendar-gregorian-from-absolute
 (1+ (calendar-absolute-from-gregorian date))))
 (setq entry-found nil)))))
 (goto-char (point-min))
 (define-button-type 'diary-entry
 'action #'diary-goto-entry
 'face 'diary-button)
 (defun diary-goto-entry (button)
-(let ((marker (button-get button 'marker)))
+(let* ((locator (button-get button 'locator))
-(when marker
+(marker (car locator))
-(pop-to-buffer (marker-buffer marker))
+markbuf file)
-(goto-char (marker-position marker)))))
+;; If marker pointing to diary location is valid, use that.
+(if (and marker (setq markbuf (marker-buffer marker)))
+(progn
+(pop-to-buffer markbuf)
+(goto-char (marker-position marker)))
+;; Marker is invalid (eg buffer has been killed).
+(or (and (setq file (cadr locator))
+(file-exists-p file)
+(find-file-other-window file)
+(progn
+(when (eq major-mode default-major-mode) (diary-mode))
+(goto-char (point-min))
+(if (re-search-forward (format "%s.*\\(%s\\)"
+(regexp-quote (nth 2 locator))
+(regexp-quote (nth 3 locator)))
+nil t)
+(goto-char (match-beginning 1)))))
+(message "Unable to locate this diary entry")))))
 (defun fancy-diary-display ()
 "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
 This function is provided for optional use as the `diary-display-hook'."
 (with-current-buffer ;; Turn off selective-display in the diary file's buffer.
 (concat "\n" (make-string l ? ))))
 (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
 	  (setq entry (car (cdr (car entry-list))))
 	  (if (< 0 (length entry))
-	      (progn
+(let ((this-entry (car entry-list))
-		(if (nth 3 (car entry-list))
+this-loc)
+		(if (setq this-loc (nth 3 this-entry))
 		    (insert-button (concat entry "\n")
-				   'marker (nth 3 (car entry-list))
+;; (MARKER FILENAME SPECIFIER LITERAL)
+'locator (list (car this-loc)
+(cadr this-loc)
+(nth 2 this-entry)
+(or (nth 2 this-loc)
+(nth 1 this-entry)))
 				   :type 'diary-entry)
 		  (insert entry ?\n))
 		(save-excursion
-(let* ((marks (nth 4 (car entry-list)))
+(let* ((marks (nth 4 this-entry))
-(temp-face (make-symbol
+(faceinfo marks)
-(apply
+temp-face)
-'concat "temp-face-"
+(when marks
-(mapcar (lambda (sym)
+(setq temp-face (make-symbol
-(if (stringp sym)
+(apply
-sym
+'concat "temp-face-"
-(symbol-name sym)))
+(mapcar (lambda (sym)
-marks))))
+(if (stringp sym)
-(faceinfo marks))
+sym
-(make-face temp-face)
+(symbol-name sym)))
-;; Remove :face info from the marks,
+marks))))
-;; copy the face info into temp-face
+(make-face temp-face)
-(while (setq faceinfo (memq :face faceinfo))
+;; Remove :face info from the marks,
-(copy-face (read (nth 1 faceinfo)) temp-face)
+;; copy the face info into temp-face
-(setcar faceinfo nil)
+(while (setq faceinfo (memq :face faceinfo))
-(setcar (cdr faceinfo) nil))
+(copy-face (read (nth 1 faceinfo)) temp-face)
-(setq marks (delq nil marks))
+(setcar faceinfo nil)
-;; Apply the font aspects.
+(setcar (cdr faceinfo) nil))
-(apply 'set-face-attribute temp-face nil marks)
+(setq marks (delq nil marks))
-(search-backward entry)
+;; Apply the font aspects.
-(overlay-put
+(apply 'set-face-attribute temp-face nil marks)
-(make-overlay (match-beginning 0) (match-end 0))
+(search-backward entry)
-'face temp-face)))))
+(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)
 (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))
+entry-start (1+ line-start))
 (forward-char 1)
 (if (and (or (char-equal (preceding-char) ?\^M)
 (char-equal (preceding-char) ?\n))
 (not (looking-at " \\|\^I")))
 (progn;; Diary entry consists only of the sexp
 (backward-char 1)
 (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))
-temp)
+temp literal)
-	  (setq entry (if (consp diary-entry)
+(setq literal entry           ; before evaluation
-			  (cdr diary-entry)
+entry (if (consp diary-entry)
-			diary-entry))
+(cdr diary-entry)
+diary-entry))
 (if diary-entry
-	      (progn
+(progn
 (remove-overlays line-start (point) 'invisible 'diary)
-		(if (< 0 (length entry))
+(if (< 0 (length entry))
-		    (setq temp (diary-pull-attrs entry file-glob-attrs)
+(setq temp (diary-pull-attrs entry file-glob-attrs)
-			  entry (nth 0 temp)
+entry (nth 0 temp)
-			  marks (nth 1 temp)))))
+marks (nth 1 temp)))))
-	  (add-to-diary-list date
+(add-to-diary-list date
-			     entry
+entry
-			     specifier
+specifier
-			     (if entry-start (copy-marker entry-start)
+(if entry-start (copy-marker entry-start)
-			       nil)
+nil)
-			     marks)
+marks
-	  (setq entry-found (or entry-found diary-entry)))))
+literal)
+(setq entry-found (or entry-found diary-entry)))))
 entry-found))
 (defun diary-sexp-entry (sexp entry date)
 "Process a SEXP diary ENTRY for DATE."
 (let ((result (if calendar-debug-sexp
 ;; 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))))))
-(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."
-(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)))
 (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))
+'(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))
-(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
 '(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)
 (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 "\\(^\\|\\s-\\)"
-(concat ;; "^[ \t]+"
+diary-time-regexp "\\(-" diary-time-regexp "\\)?")
-diary-time-regexp "\\(-" diary-time-regexp "\\)?")
+. 'diary-time)))
-'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

Mercurial > emacs

comparison lisp/calendar/diary-lib.el @ 90428:a8190f7e546e