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

comparison lisp/calendar/diary-lib.el @ 92994:deb2f6126df1

(diary-remind-message, mark-sexp-diary-entries, list-sexp-diary-entries) (diary-font-lock-sexps): Use format rather than concat. (diary): Remove un-needed let. (view-other-diary-entries): Rename argument. (diary-list-entries-2): New function. (diary-list-entries-1, diary-list-entries): Use diary-list-entries-2. (print-diary-entries): Use unless. (diary-mark-entries-1): Change argument order, make all but markfunc optional. Handle the standard (Gregorian) case. Use match-string-no-properties. Handle marks. (mark-diary-entries): Use diary-mark-entries-1. (calendar-mark-complex, calendar-mark-1): New functions. (diary-font-lock-keywords-1): New macro. (diary-font-lock-keywords): Use diary-font-lock-keywords-1.

author	Glenn Morris <rgm@gnu.org>
date	Sun, 16 Mar 2008 01:26:48 +0000
parents	122f4beea537
children	9c718a4c0412

comparison

equal deleted inserted replaced

-:61c2483cb400
+:deb2f6126df1
 :version "20.3")
 (defcustom diary-remind-message
 '("Reminder: Only "
 (if (zerop (% days 7))
-(concat (int-to-string (/ days 7)) (if (= 7 days) " week" " weeks"))
+(format "%d week%s" (/ days 7) (if (= 7 days) "" "s"))
-(concat (int-to-string days) (if (= 1 days) " day" " days")))
+(format "%d day%s" days (if (= 1 days) "" "s")))
 " until "
 diary-entry)
 "Pseudo-pattern giving form of reminder messages in the fancy diary display.
 Used by the function `diary-remind', a pseudo-pattern is a list of
 If no argument is provided, the number of days of diary entries is governed
 by the variable `number-of-diary-entries'.  A value of ARG less than 1
 does nothing.  This function is suitable for execution in a `.emacs' file."
 (interactive "P")
 (diary-check-diary-file)
-(let ((date (calendar-current-date)))
+(diary-list-entries (calendar-current-date)
-(diary-list-entries date (if arg (prefix-numeric-value arg)))))
+(if arg (prefix-numeric-value arg))))
 (define-obsolete-function-alias 'view-diary-entries 'diary-view-entries)
 ;;;###cal-autoload
 (defun diary-view-entries (&optional arg)
 "Prepare and display a buffer with diary entries.
 (interactive "p")
 (diary-check-diary-file)
 (diary-list-entries (calendar-cursor-to-date t) arg))
 ;;;###cal-autoload
-(defun view-other-diary-entries (arg d-file)
+(defun view-other-diary-entries (arg dfile)
 "Prepare and display buffer of diary entries from an alternative diary file.
 Searches for entries that match ARG days, starting with the date indicated
 by the cursor position in the displayed three-month calendar.
-D-FILE specifies the file to use as the diary file."
+DFILE specifies the file to use as the diary file."
 (interactive
 (list (prefix-numeric-value current-prefix-arg)
 (read-file-name "Enter diary file name: " default-directory nil t)))
-(let ((diary-file d-file))
+(let ((diary-file dfile))
 (diary-view-entries arg)))
 (defvar diary-syntax-table
 (let ((st (copy-syntax-table (standard-syntax-table))))
 (modify-syntax-entry ?* "w" st)
 (append diary-entries-list
 (list (list date string specifier
 (list marker (buffer-file-name) literal)
 globcolor))))))
-(defvar number)
+(defvar number)                     ; not clear this should use number
-(defvar original-date)
+(defun diary-list-entries-2 (date mark globattr list-only
-;; FIXME use for list-diary-entries.
+&optional months symbol)
+"Internal subroutine of `diary-list-entries'.
+Find diary entries applying to DATE, by searching from point-min for
+each element of `diary-date-forms'.  MARK indicates an entry is non-marking.
+GLOBATTR is the list of global file attributes.  If LIST-ONLY is
+non-nil, don't change the buffer, only return a list of entries.
+Optional array MONTHS replaces `calendar-month-name-array', and
+means months cannot be abbreviated.  Optional string SYMBOL marks diary
+entries of the desired type.  Returns non-nil if any entries were found."
+(let* ((month (extract-calendar-month date))
+(day (extract-calendar-day date))
+(year (extract-calendar-year date))
+(dayname (format "%s\\|%s\\.?" (calendar-day-name date)
+(calendar-day-name date 'abbrev)))
+(calendar-month-name-array (or months calendar-month-name-array))
+(monthname (format "\\*\\|%s%s" (calendar-month-name month)
+(if months ""
+(format "\\|%s\\.?"
+(calendar-month-name month 'abbrev)))))
+(month (format "\\*\\|0*%d" month))
+(day (format "\\*\\|0*%d" day))
+(year (format "\\*\\|0*%d%s" year
+(if abbreviated-calendar-year
+;; FIXME was %d in non-greg case.
+(format "\\|%02d" (% year 100))
+"")))
+(case-fold-search t)
+entry-found)
+(dolist (date-form diary-date-forms)
+(let ((backup (when (eq (car date-form) 'backup)
+(setq date-form (cdr date-form))
+t))
+;; date-form uses day etc as set above.
+(regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark)
+(if symbol (regexp-quote symbol) "")
+(mapconcat 'eval date-form "\\)\\(?:")))
+entry-start date-start temp)
+(goto-char (point-min))
+(while (re-search-forward regexp nil t)
+(if backup (re-search-backward "\\<" nil t))
+(if (and (bolp) (not (looking-at "[ \t]")))
+;;  Diary entry that consists only of date.
+(backward-char 1)
+;; Found a nonempty diary entry--make it
+;; visible and add it to the list.
+;; Actual entry starts on the next-line?
+(if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
+(setq entry-found t
+entry-start (point)
+;; If bolp, must have done (forward-line 1).
+;; FIXME Why number > 1?
+date-start (line-end-position (if (and (bolp) (> number 1))
+-1 0)))
+(forward-line 1)
+(while (looking-at "[ \t]") ; continued entry
+(forward-line 1))
+(unless (and (eobp) (not (bolp)))
+(backward-char 1))
+(unless list-only
+(remove-overlays date-start (point) 'invisible 'diary))
+(setq temp (diary-pull-attrs
+(buffer-substring-no-properties
+entry-start (point)) globattr))
+(add-to-diary-list
+date (car temp)
+(buffer-substring-no-properties (1+ date-start) (1- entry-start))
+(copy-marker entry-start) (cadr temp))))))
+entry-found))
+(defvar original-date)                  ; from diary-list-entries
+(defvar file-glob-attrs)
+(defvar list-only)
 (defun diary-list-entries-1 (months symbol absfunc)
 "List diary entries of a certain type.
 MONTHS is an array of month names.  SYMBOL marks diary entries of the type
 in question.  ABSFUNC is a function that converts absolute dates to dates
 of the appropriate type."
-(if (< 0 number)
+(let ((gdate original-date))
-(let ((gdate original-date)
+(dotimes (idummy number)
-(mark (regexp-quote diary-nonmarking-symbol)))
+(diary-list-entries-2
-(dotimes (idummy number)
+(funcall absfunc (calendar-absolute-from-gregorian gdate))
-(let* ((tdate (funcall absfunc
+diary-nonmarking-symbol file-glob-attrs list-only months symbol)
-(calendar-absolute-from-gregorian gdate)))
+(setq gdate
-(month (extract-calendar-month tdate))
+(calendar-gregorian-from-absolute
-(day (extract-calendar-day tdate))
+(1+ (calendar-absolute-from-gregorian gdate))))))
-(year (extract-calendar-year tdate))
+(goto-char (point-min)))
-backup)
-(dolist (date-form diary-date-forms)
-(if (setq backup (eq (car date-form) 'backup))
-(setq date-form (cdr date-form)))
-(let* ((dayname
-(format "%s\\|%s\\.?"
-(calendar-day-name gdate)
-(calendar-day-name gdate 'abbrev)))
-(calendar-month-name-array months)
-(monthname
-(format "\\*\\|%s" (calendar-month-name month)))
-(month (format "\\*\\|0*%s" (int-to-string month)))
-(day (format "\\*\\|0*%s" (int-to-string day)))
-(year
-(format "\\*\\|0*%s%s" (int-to-string year)
-(if abbreviated-calendar-year
-(format "\\|%s"
-(int-to-string (% year 100)))
-"")))
-(regexp
-(format "^%s?%s\\(%s\\)" mark (regexp-quote symbol)
-(mapconcat 'eval date-form "\\)\\(")))
-(case-fold-search t))
-(goto-char (point-min))
-(while (re-search-forward regexp nil t)
-(if backup (re-search-backward "\\<" nil t))
-(if (and (bolp) (not (looking-at "[ \t]")))
-;; Diary entry that consists only of date.
-(backward-char 1)
-;; Found a nonempty diary entry--make it visible and
-;; add it to the list.
-;; Actual entry starts on the next-line?
-(if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
-(let ((entry-start (point))
-;; If bolp, must have done (forward-line 1).
-(date-start (line-end-position (if (bolp) -1 0))))
-(forward-line 1)
-(while (looking-at "[ \t]") ; continued entry
-(forward-line 1))
-(unless (and (eobp) (not (bolp)))
-(backward-char 1))
-(remove-overlays date-start (point) 'invisible 'diary)
-(add-to-diary-list
-gdate
-(buffer-substring-no-properties entry-start (point))
-(buffer-substring-no-properties
-(1+ date-start) (1- entry-start))
-(copy-marker entry-start))))))))
-(setq gdate
-(calendar-gregorian-from-absolute
-(1+ (calendar-absolute-from-gregorian gdate))))))
-(goto-char (point-min))))
 (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
 ;; 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))
-(goto-char (point-min))
+(unless list-only
-(unless list-only
+(let ((ol (make-overlay (point-min) (point-max) nil t nil)))
-(let ((ol (make-overlay (point-min) (point-max) nil t nil)))
+(set (make-local-variable 'diary-selective-display) t)
-(set (make-local-variable 'diary-selective-display) t)
+(overlay-put ol 'invisible 'diary)
-(overlay-put ol 'invisible 'diary)
+(overlay-put ol 'evaporate t)))
-(overlay-put ol 'evaporate t)))
+(dotimes (idummy number)
-(dotimes (idummy number)
+(let ((sexp-found (list-sexp-diary-entries date))
-(let ((month (extract-calendar-month date))
+(entry-found (diary-list-entries-2
-(day (extract-calendar-day date))
+date diary-nonmarking-symbol
-(year (extract-calendar-year date))
+file-glob-attrs list-only)))
-(entry-found (list-sexp-diary-entries date)))
+(if diary-list-include-blanks
-(dolist (date-form diary-date-forms)
+(or sexp-found entry-found
-(let* ((backup (when (eq (car date-form) 'backup)
+(add-to-diary-list date "" "" "" "")))
-(setq date-form (cdr date-form))
+(setq date
-t))
+(calendar-gregorian-from-absolute
-(dayname
+(1+ (calendar-absolute-from-gregorian date)))))))
-(format "%s\\|%s\\.?"
-(calendar-day-name date)
-(calendar-day-name date 'abbrev)))
-(monthname
-(format "\\*\\|%s\\|%s\\.?"
-(calendar-month-name month)
-(calendar-month-name month 'abbrev)))
-(month (concat "\\*\\|0*" (int-to-string month)))
-(day (concat "\\*\\|0*" (int-to-string day)))
-(year
-(concat
-"\\*\\|0*" (int-to-string year)
-(if abbreviated-calendar-year
-(concat "\\|" (format "%02d" (% year 100)))
-"")))
-(regexp
-(concat
-"^" mark "?\\("
-;; This must be let* so that date-form
-;; can use day etc.
-(mapconcat 'eval date-form "\\)\\(?:")
-"\\)"))
-(case-fold-search t))
-(goto-char (point-min))
-(while (re-search-forward regexp nil t)
-(if backup (re-search-backward "\\<" nil t))
-(if (and (bolp) (not (looking-at "[ \t]")))
-;;  Diary entry that consists only of date.
-(backward-char 1)
-;; Found a nonempty diary entry--make it
-;; visible and add it to the list.
-(setq entry-found t)
-(if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
-(let ((entry-start (point))
-(temp)
-(date-start
-(line-end-position
-;; FIXME Why number > 1?
-(if (and (bolp) (> number 1)) -1 0))))
-(forward-line 1)
-(while (looking-at "[ \t]")
-(forward-line 1))
-(unless (and (eobp) (not (bolp)))
-(backward-char 1))
-(unless list-only
-(remove-overlays date-start (point)
-'invisible 'diary))
-(setq temp (diary-pull-attrs
-(buffer-substring entry-start (point))
-file-glob-attrs))
-(add-to-diary-list
-date
-(car temp)
-(buffer-substring
-(1+ date-start) (1- entry-start))
-(copy-marker entry-start) (nth 1 temp)))))))
-(or entry-found
-(not diary-list-include-blanks)
-(add-to-diary-list date "" "" "" ""))
-(setq date
-(calendar-gregorian-from-absolute
-(1+ (calendar-absolute-from-gregorian date))))
-(setq entry-found nil)))))
 (goto-char (point-min))
 (run-hooks 'nongregorian-diary-listing-hook
 'list-diary-entries-hook)
 (unless list-only
 (if diary-display-hook
 end)
 (while
 (progn
 (setq end (next-single-char-property-change
 start 'invisible))
-(if (get-char-property start 'invisible)
+(unless (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))))))
 "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.")
-;; FIXME use for mark-diary-entries.
+;; file-glob-attrs bound in mark-diary-entries.
-(defun diary-mark-entries-1 (months symbol absfunc markfunc)
+(defun diary-mark-entries-1 (markfunc &optional months symbol absfunc)
 "Mark diary entries of a certain type.
-MONTHS is an array of month names.  SYMBOL marks diary entries of the type
+MARKFUNC is a function that marks entries of the appropriate type
-in question.  ABSFUNC is a function that converts absolute dates to dates
+matching a given date pattern.  MONTHS is an array of month names.
-of the appropriate type.  MARKFUNC is a function that marks entries
+SYMBOL marks diary entries of the type in question.  ABSFUNC is a
-of the appropriate type matching a given date pattern."
+function that converts absolute dates to dates of the appropriate type.  "
 (let ((dayname (diary-name-pattern calendar-day-name-array
 calendar-day-abbrev-array))
-(monthname (format "%s\\|\\*" (diary-name-pattern months)))
+(monthname (format "%s\\|\\*"
+(if months
+(diary-name-pattern months)
+(diary-name-pattern calendar-month-name-array
+calendar-month-abbrev-array))))
 (month "[0-9]+\\|\\*")
 (day "[0-9]+\\|\\*")
 (year "[0-9]+\\|\\*")
-(case-fold-search t))
+(case-fold-search t)
+;; FIXME is this the right reason for 1 versus 2?
+;; Should docs of symbols say must be single character?
+(inc (if symbol 2 1))
+marks)
 (dolist (date-form diary-date-forms)
 (if (eq (car date-form) 'backup)  ; ignore 'backup directive
 (setq date-form (cdr date-form)))
 (let* ((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)))
+(d-name-pos (if (/= l d-name-pos) (+ inc d-name-pos)))
 (m-name-pos (- l (length (memq 'monthname date-form))))
-(m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
+(m-name-pos (if (/= l m-name-pos) (+ inc m-name-pos)))
 (d-pos (- l (length (memq 'day date-form))))
-(d-pos (if (/= l d-pos) (+ 2 d-pos)))
+(d-pos (if (/= l d-pos) (+ inc d-pos)))
 (m-pos (- l (length (memq 'month date-form))))
-(m-pos (if (/= l m-pos) (+ 2 m-pos)))
+(m-pos (if (/= l m-pos) (+ inc m-pos)))
 (y-pos (- l (length (memq 'year date-form))))
-(y-pos (if (/= l y-pos) (+ 2 y-pos)))
+(y-pos (if (/= l y-pos) (+ inc y-pos)))
-(regexp (format "^%s\\(%s\\)" (regexp-quote symbol)
+(regexp (format "^%s\\(%s\\)"
+(if symbol (regexp-quote symbol) "")
 (mapconcat 'eval date-form "\\)\\("))))
 (goto-char (point-min))
 (while (re-search-forward regexp nil t)
 (let* ((dd-name
 (if d-name-pos
-(buffer-substring
+(match-string-no-properties d-name-pos)))
-(match-beginning d-name-pos)
-(match-end d-name-pos))))
 (mm-name
 (if m-name-pos
-(buffer-substring
+(match-string-no-properties m-name-pos)))
-(match-beginning m-name-pos)
-(match-end m-name-pos))))
 (mm (string-to-number
 (if m-pos
-(buffer-substring
+(match-string-no-properties m-pos)
-(match-beginning m-pos)
-(match-end m-pos))
 "")))
 (dd (string-to-number
 (if d-pos
-(buffer-substring
+(match-string-no-properties d-pos)
-(match-beginning d-pos)
-(match-end d-pos))
 "")))
 (y-str (if y-pos
-(buffer-substring
+(match-string-no-properties y-pos)))
-(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
-(funcall absfunc
+(if absfunc
-(calendar-absolute-from-gregorian
+(funcall
-(calendar-current-date)))))
+absfunc
+(calendar-absolute-from-gregorian
+(calendar-current-date)))
+(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)))))
+(setq marks (cadr (diary-pull-attrs
+(buffer-substring-no-properties
+(point) (line-end-position))
+file-glob-attrs)))
 (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)))
+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 months) t)))))
+(if months (calendar-make-alist months)
-(funcall markfunc mm dd yy))))))))
+(calendar-make-alist
+calendar-month-name-array
+1 nil calendar-month-abbrev-array)) t)))))
+(funcall markfunc mm dd yy marks))))))))
 ;;;###cal-autoload
 (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
 ;; 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)
-(dayname
+file-glob-attrs)
-(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]+\\|\\*")
-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)
+(diary-mark-entries-1 'mark-calendar-date-pattern)
-(if (eq (car date-form) 'backup)
-(setq date-form (cdr date-form))) ; ignore 'backup directive
-(let* ((l (length date-form))
-(d-name-pos (- l (length (memq 'dayname date-form))))
-(d-name-pos (if (/= l d-name-pos) (1+ d-name-pos)))
-(m-name-pos (- l (length (memq 'monthname date-form))))
-(m-name-pos (if (/= l m-name-pos) (1+ m-name-pos)))
-(d-pos (- l (length (memq 'day date-form))))
-(d-pos (if (/= l d-pos) (1+ d-pos)))
-(m-pos (- l (length (memq 'month date-form))))
-(m-pos (if (/= l m-pos) (1+ m-pos)))
-(y-pos (- l (length (memq 'year date-form))))
-(y-pos (if (/= l y-pos) (1+ y-pos)))
-(regexp
-(concat
-"^\\("
-(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)))))
-(setq marks (nth 1
-(diary-pull-attrs
-(buffer-substring-no-properties
-(point) (line-end-position))
-file-glob-attrs)))
-(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.
 Each entry in the diary file (or included files) visible in the calendar window
 is marked.  See the documentation for the function `list-sexp-diary-entries'."
 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
-(s-entry (concat "^\\("
+(s-entry (format "^\\(%s(\\)\\|\\(%s%s(diary-remind\\)" sexp-mark
-sexp-mark "(\\)\\|\\("
 (regexp-quote diary-nonmarking-symbol)
-sexp-mark "(diary-remind\\)"))
+sexp-mark))
 (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 m displayed-month
-(setq y displayed-year))
+y displayed-year))
 (increment-calendar-month m y -1)
 (setq first-date
 (calendar-absolute-from-gregorian (list m 1 y)))
 (increment-calendar-month m y 2)
 (setq last-date
 (while (looking-at "[ \t]")
 (forward-line 1))
 (if (bolp) (backward-char 1))
 (setq entry (buffer-substring-no-properties entry-start (point))))
 (calendar-for-loop date from first-date to last-date do
-(when (setq mark
+(when (setq mark (diary-sexp-entry
-(diary-sexp-entry
+sexp entry
-sexp entry
+(calendar-gregorian-from-absolute date)))
-(calendar-gregorian-from-absolute
+;; FIXME does this make sense?
-date)))
+(setq marks (diary-pull-attrs entry file-glob-attrs)
-;; FIXME does this make sense?
+marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
-(setq marks (diary-pull-attrs
+(mark-visible-calendar-date
-entry file-glob-attrs)
+(calendar-gregorian-from-absolute date)
-marks (nth 1 (diary-pull-attrs
+(if (< 0 (length marks))
-entry file-glob-attrs)))
+marks
-(mark-visible-calendar-date
+(if (consp mark) (car mark))))))))))
-(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.
 This function is suitable for use as the `mark-diary-entries-hook'; it enables
 you to use shared diary files together with your own.  The files included are
 color)
 (setq day (+ day 7))))))
 (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.
+A value of 0 in any position is a wildcard.  Optional argument COLOR is
-Optional argument COLOR is passed to `mark-visible-calendar-date' as MARK."
+passed to `mark-visible-calendar-date' as MARK."
 (with-current-buffer calendar-buffer
 (let ((m displayed-month)
 (y displayed-year))
 (increment-calendar-month m y -1)
 (dotimes (idummy 3)
 (or (zerop p-year) (= year p-year))))
 (if (zerop p-day)
 (dotimes (i (calendar-last-day-of-month month year))
 (mark-visible-calendar-date (list month (1+ i) year) color))
 (mark-visible-calendar-date (list month p-day year) color))))
+;; Bahai, Hebrew, Islamic.
+(defun calendar-mark-complex (month day year fromabs &optional color)
+"Mark dates in the calendar conforming to MONTH DAY YEAR of some system.
+The function FROMABS converts absolute dates to the appropriate date system.
+Optional argument COLOR is passed to `mark-visible-calendar-date' as MARK."
+;; Not one of the simple cases--check all visible dates for match.
+;; Actually, the following code takes care of ALL of the cases, but
+;; it's much too slow to be used for the simple (common) cases.
+(let ((m displayed-month)
+(y displayed-year)
+first-date last-date)
+(increment-calendar-month m y -1)
+(setq first-date (calendar-absolute-from-gregorian (list m 1 y)))
+(increment-calendar-month m y 2)
+(setq last-date (calendar-absolute-from-gregorian
+(list m (calendar-last-day-of-month m y) y)))
+(calendar-for-loop date from first-date to last-date do
+(let* ((i-date (funcall fromabs date))
+(i-month (extract-calendar-month i-date))
+(i-day (extract-calendar-day i-date))
+(i-year (extract-calendar-year i-date)))
+(and (or (zerop month)
+(= month i-month))
+(or (zerop day)
+(= day i-day))
+(or (zerop year)
+(= year i-year))
+(mark-visible-calendar-date
+(calendar-gregorian-from-absolute date) color))))))
+;; Bahai, Islamic.
+(defun calendar-mark-1 (month day year fromabs toabs &optional color)
+"Mark dates in the calendar conforming to MONTH DAY YEAR of some system.
+The function FROMABS converts absolute dates to the appropriate date system.
+The function TOABDS carries out the inverse operation.  Optional argument
+COLOR is passed to `mark-visible-calendar-date' as MARK."
+(save-excursion
+(set-buffer calendar-buffer)
+(if (and (not (zerop month)) (not (zerop day)))
+(if (not (zerop year))
+;; Fully specified date.
+(let ((date (calendar-gregorian-from-absolute
+(funcall toabs (list month day year)))))
+(if (calendar-date-is-visible-p date)
+(mark-visible-calendar-date date color)))
+;; Month and day in any year--this taken from the holiday stuff.
+(let* ((i-date (funcall fromabs
+(calendar-absolute-from-gregorian
+(list displayed-month 15 displayed-year))))
+(m (extract-calendar-month i-date))
+(y (extract-calendar-year i-date))
+date)
+(unless (< m 1)             ; calendar doesn't apply
+(increment-calendar-month m y (- 10 month))
+(if (> m 7)               ; date might be visible
+(let ((date (calendar-gregorian-from-absolute
+(funcall toabs (list month day y)))))
+(if (calendar-date-is-visible-p date)
+(mark-visible-calendar-date date color)))))))
+(calendar-mark-complex month day year
+'calendar-bahai-from-absolute color))))
 (defun sort-diary-entries ()
 "Sort the list of diary entries by time of day."
 (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
 from Passover to Shavuot.  Note that since there is no text,
 it makes sense only if the fancy diary display is used.
 Marking these entries is *extremely* time consuming, so these entries are
 best if they are nonmarking."
-(let ((s-entry (concat "^"
+(let ((s-entry (format "^%s?%s(" (regexp-quote diary-nonmarking-symbol)
-(regexp-quote diary-nonmarking-symbol)
+(regexp-quote sexp-diary-entry-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)
 (defun diary-font-lock-sexps (limit)
 "Recognize sexp diary entry up to LIMIT for font-locking."
 (if (re-search-forward
-(concat "^" (regexp-quote diary-nonmarking-symbol)
+(format "^%s?\\(%s\\)" (regexp-quote diary-nonmarking-symbol)
-"?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
+(regexp-quote sexp-diary-entry-symbol))
 limit t)
 (condition-case nil
 (save-restriction
 (narrow-to-region (point-min) limit)
 (let ((start (point)))
 (concat "\\)" (eval (car (reverse x))))
 "\\)"))
 '(1 diary-face)))
 diary-date-forms)))
+(defmacro diary-font-lock-keywords-1 (markfunc listfunc feature months symbol)
+"Subroutine of the function `diary-font-lock-keywords'.
+If MARKFUNC is a member of `nongregorian-diary-marking-hook', or
+LISTFUNC of `nongregorian-diary-listing-hook', then require FEATURE
+and return a font-lock pattern matching array of MONTHS and marking SYMBOL."
+`(when (or (memq ',markfunc nongregorian-diary-marking-hook)
+(memq ',listfunc nongregorian-diary-listing-hook))
+(require ',feature)
+(diary-font-lock-date-forms ,months ,symbol)))
 (defvar calendar-hebrew-month-name-array-leap-year)
 (defvar calendar-islamic-month-name-array)
 (defvar calendar-bahai-month-name-array)
 ;;;###cal-autoload
 (defun diary-font-lock-keywords ()
 "Return a value for the variable `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
+(diary-font-lock-keywords-1 mark-hebrew-diary-entries
-nongregorian-diary-marking-hook)
+list-hebrew-diary-entries
-(memq 'list-hebrew-diary-entries
+cal-hebrew
-nongregorian-diary-listing-hook))
+calendar-hebrew-month-name-array-leap-year
-(require 'cal-hebrew)
+hebrew-diary-entry-symbol)
-(diary-font-lock-date-forms
+(diary-font-lock-keywords-1 mark-islamic-diary-entries
-calendar-hebrew-month-name-array-leap-year hebrew-diary-entry-symbol))
+list-islamic-diary-entries
-(when (or (memq 'mark-islamic-diary-entries
+cal-islam
-nongregorian-diary-marking-hook)
+calendar-islamic-month-name-array
-(memq 'list-islamic-diary-entries
+islamic-diary-entry-symbol)
-nongregorian-diary-listing-hook))
+(diary-font-lock-keywords-1 diary-bahai-mark-entries
-(require 'cal-islam)
+diary-bahai-list-entries
-(diary-font-lock-date-forms
+cal-bahai
-calendar-islamic-month-name-array islamic-diary-entry-symbol))
+calendar-bahai-month-name-array
-(when (or (memq 'diary-bahai-mark-entries
+bahai-diary-entry-symbol)
-nongregorian-diary-marking-hook)
-(memq 'diary-bahai-list-entries
-nongregorian-diary-marking-hook))
-(require 'cal-bahai)
-(diary-font-lock-date-forms
-calendar-bahai-month-name-array bahai-diary-entry-symbol))
 (list
 (cons
 (format "^%s.*$" (regexp-quote diary-include-string))
 'font-lock-keyword-face)
 (cons

Mercurial > emacs

comparison lisp/calendar/diary-lib.el @ 92994:deb2f6126df1