/[emacs]/emacs/lisp/calendar/diary-lib.el
ViewVC logotype

Diff of /emacs/lisp/calendar/diary-lib.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.54 by rms, Mon Apr 22 07:51:28 2002 UTC revision 1.54.2.1 by miles, Fri Apr 4 06:20:15 2003 UTC
# Line 88  three-month calendar." Line 88  three-month calendar."
88  (autoload 'check-calendar-holidays "holidays"  (autoload 'check-calendar-holidays "holidays"
89    "Check the list of holidays for any that occur on DATE.    "Check the list of holidays for any that occur on DATE.
90  The value returned is a list of strings of relevant holiday descriptions.  The value returned is a list of strings of relevant holiday descriptions.
91  The holidays are those in the list `calendar-holidays'."  The holidays are those in the list `calendar-holidays'.")
   t)  
92    
93  (autoload 'calendar-holiday-list "holidays"  (autoload 'calendar-holiday-list "holidays"
94    "Form the list of holidays that occur on dates in the calendar window.    "Form the list of holidays that occur on dates in the calendar window.
95  The holidays are those in the list `calendar-holidays'."  The holidays are those in the list `calendar-holidays'.")
   t)  
96    
97  (autoload 'diary-french-date "cal-french"  (autoload 'diary-french-date "cal-french"
98    "French calendar equivalent of date diary entry."    "French calendar equivalent of date diary entry.")
   t)  
99    
100  (autoload 'diary-mayan-date "cal-mayan"  (autoload 'diary-mayan-date "cal-mayan"
101    "Mayan calendar equivalent of date diary entry."    "Mayan calendar equivalent of date diary entry.")
   t)  
102    
103  (autoload 'diary-iso-date "cal-iso"  (autoload 'diary-iso-date "cal-iso"
104    "ISO calendar equivalent of date diary entry."    "ISO calendar equivalent of date diary entry.")
   t)  
105    
106  (autoload 'diary-julian-date "cal-julian"  (autoload 'diary-julian-date "cal-julian"
107    "Julian calendar equivalent of date diary entry."    "Julian calendar equivalent of date diary entry.")
   t)  
108    
109  (autoload 'diary-astro-day-number "cal-julian"  (autoload 'diary-astro-day-number "cal-julian"
110    "Astronomical (Julian) day number diary entry."    "Astronomical (Julian) day number diary entry.")
   t)  
111    
112  (autoload 'diary-chinese-date "cal-china"  (autoload 'diary-chinese-date "cal-china"
113    "Chinese calendar equivalent of date diary entry."    "Chinese calendar equivalent of date diary entry.")
   t)  
114    
115  (autoload 'diary-islamic-date "cal-islam"  (autoload 'diary-islamic-date "cal-islam"
116    "Islamic calendar equivalent of date diary entry."    "Islamic calendar equivalent of date diary entry.")
   t)  
117    
118  (autoload 'list-islamic-diary-entries "cal-islam"  (autoload 'list-islamic-diary-entries "cal-islam"
119    "Add any Islamic date entries from the diary file to `diary-entries-list'."    "Add any Islamic date entries from the diary file to `diary-entries-list'.")
   t)  
120    
121  (autoload 'mark-islamic-diary-entries "cal-islam"  (autoload 'mark-islamic-diary-entries "cal-islam"
122    "Mark days in the calendar window that have Islamic date diary entries."    "Mark days in the calendar window that have Islamic date diary entries.")
   t)  
123    
124  (autoload 'mark-islamic-calendar-date-pattern "cal-islam"  (autoload 'mark-islamic-calendar-date-pattern "cal-islam"
125     "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR."     "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.")
   t)  
126    
127  (autoload 'diary-hebrew-date "cal-hebrew"  (autoload 'diary-hebrew-date "cal-hebrew"
128    "Hebrew calendar equivalent of date diary entry."    "Hebrew calendar equivalent of date diary entry.")
   t)  
129    
130  (autoload 'diary-omer "cal-hebrew"  (autoload 'diary-omer "cal-hebrew"
131    "Omer count diary entry."    "Omer count diary entry.")
   t)  
132    
133  (autoload 'diary-yahrzeit "cal-hebrew"  (autoload 'diary-yahrzeit "cal-hebrew"
134    "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before."    "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.")
   t)  
135    
136  (autoload 'diary-parasha "cal-hebrew"  (autoload 'diary-parasha "cal-hebrew"
137    "Parasha diary entry--entry applies if date is a Saturday."    "Parasha diary entry--entry applies if date is a Saturday.")
   t)  
138    
139  (autoload 'diary-rosh-hodesh "cal-hebrew"  (autoload 'diary-rosh-hodesh "cal-hebrew"
140    "Rosh Hodesh diary entry."    "Rosh Hodesh diary entry.")
   t)  
141    
142  (autoload 'list-hebrew-diary-entries "cal-hebrew"  (autoload 'list-hebrew-diary-entries "cal-hebrew"
143    "Add any Hebrew date entries from the diary file to `diary-entries-list'."    "Add any Hebrew date entries from the diary file to `diary-entries-list'.")
   t)  
144    
145  (autoload 'mark-hebrew-diary-entries "cal-hebrew"  (autoload 'mark-hebrew-diary-entries "cal-hebrew"
146    "Mark days in the calendar window that have Hebrew date diary entries."    "Mark days in the calendar window that have Hebrew date diary entries.")
   t)  
147    
148  (autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew"  (autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew"
149     "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR."     "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.")
   t)  
150    
151  (autoload 'diary-coptic-date "cal-coptic"  (autoload 'diary-coptic-date "cal-coptic"
152    "Coptic calendar equivalent of date diary entry."    "Coptic calendar equivalent of date diary entry.")
   t)  
153    
154  (autoload 'diary-ethiopic-date "cal-coptic"  (autoload 'diary-ethiopic-date "cal-coptic"
155    "Ethiopic calendar equivalent of date diary entry."    "Ethiopic calendar equivalent of date diary entry.")
   t)  
156    
157  (autoload 'diary-persian-date "cal-persia"  (autoload 'diary-persian-date "cal-persia"
158    "Persian calendar equivalent of date diary entry."    "Persian calendar equivalent of date diary entry.")
   t)  
159    
160  (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)  (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry.")
161    
162  (autoload 'diary-sunrise-sunset "solar"  (autoload 'diary-sunrise-sunset "solar"
163    "Local time of sunrise and sunset as a diary entry."    "Local time of sunrise and sunset as a diary entry.")
   t)  
164    
165  (autoload 'diary-sabbath-candles "solar"  (autoload 'diary-sabbath-candles "solar"
166    "Local time of candle lighting diary entry--applies if date is a Friday.    "Local time of candle lighting diary entry--applies if date is a Friday.
167  No diary entry if there is no sunset on that date."  No diary entry if there is no sunset on that date.")
   t)  
168    
169  (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))  (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
170    "The syntax table used when parsing dates in the diary file.    "The syntax table used when parsing dates in the diary file.
# Line 199  syntax of `*' changed to be a word const Line 174  syntax of `*' changed to be a word const
174  (modify-syntax-entry ?* "w" diary-syntax-table)  (modify-syntax-entry ?* "w" diary-syntax-table)
175  (modify-syntax-entry ?: "w" diary-syntax-table)  (modify-syntax-entry ?: "w" diary-syntax-table)
176    
177    (defvar diary-modified)
178    (defvar diary-entries-list)
179    (defvar displayed-year)
180    (defvar displayed-month)
181    (defvar entry)
182    (defvar date)
183    (defvar number)
184    (defvar date-string)
185    (defvar d-file)
186    (defvar original-date)
187    
188    (defun diary-attrtype-convert (attrvalue type)
189      "Convert the attrvalue from a string to the appropriate type for using
190    in a face description"
191      (let (ret)
192        (setq ret (cond ((eq type 'string) attrvalue)
193                        ((eq type 'symbol) (read attrvalue))
194                        ((eq type 'int) (string-to-int attrvalue))
195                        ((eq type 'stringtnil)
196                         (cond ((string= "t" attrvalue) t)
197                               ((string= "nil" attrvalue) nil)
198                               (t attrvalue)))
199                        ((eq type 'tnil)
200                         (cond ((string= "t" attrvalue) t)
201                               ((string= "nil" attrvalue) nil)))))
202    ;    (message "(%s)[%s]=[%s]" (print type) attrvalue ret)
203        ret))
204            
205    
206    (defun diary-pull-attrs (entry fileglobattrs)
207      "Pull the face-related attributes off the entry, merge with the
208    fileglobattrs, and return the (possibly modified) entry and face
209    data in a list of attrname attrvalue values.  
210    The entry will be modified to drop all tags that are used for face matching.
211    If entry is nil, then the fileglobattrs are being searched for,
212    the fileglobattrs variable is ignored, and
213    diary-glob-file-regexp-prefix is prepended to the regexps before each
214    search."
215      (save-excursion
216        (let (regexp regnum attrname attr-list attrname attrvalue type)
217          (if (null entry)
218              (progn
219                (setq ret-attr '()
220                      attr-list diary-face-attrs)
221                (while attr-list
222                  (goto-char (point-min))
223                  (setq attr (car attr-list)
224                        regexp (nth 0 attr)
225                        regnum (nth 1 attr)
226                        attrname (nth 2 attr)
227                        type (nth 3 attr)
228                        regexp (concat diary-glob-file-regexp-prefix regexp))
229                  (setq attrvalue nil)
230                  (if (re-search-forward regexp (point-max) t)
231                      (setq attrvalue (buffer-substring-no-properties
232                                       (match-beginning regnum)
233                                       (match-end regnum))))
234                  (if (and attrvalue
235                           (setq attrvalue (diary-attrtype-convert attrvalue type)))
236                      (setq ret-attr (append ret-attr (list attrname attrvalue))))
237                  (setq attr-list (cdr attr-list)))
238                (setq fileglobattrs ret-attr))
239            (progn
240              (setq ret-attr fileglobattrs
241                    attr-list diary-face-attrs)
242              (while attr-list
243                (goto-char (point-min))
244                (setq attr (car attr-list)
245                      regexp (nth 0 attr)
246                      regnum (nth 1 attr)
247                      attrname (nth 2 attr)
248                      type (nth 3 attr))
249                (setq attrvalue nil)
250                (if (string-match regexp entry)
251                    (progn
252                      (setq attrvalue (substring-no-properties entry
253                                                               (match-beginning regnum)
254                                                               (match-end regnum)))
255                      (setq entry (replace-match "" t t entry))))
256                (if (and attrvalue
257                         (setq attrvalue (diary-attrtype-convert attrvalue type)))
258                    (setq ret-attr (append ret-attr (list attrname attrvalue))))
259                (setq attr-list (cdr attr-list)))))))
260      (list entry ret-attr))
261      
262      
263    
264  (defun list-diary-entries (date number)  (defun list-diary-entries (date number)
265    "Create and display a buffer containing the relevant lines in diary-file.    "Create and display a buffer containing the relevant lines in diary-file.
266  The arguments are DATE and NUMBER; the entries selected are those  The arguments are DATE and NUMBER; the entries selected are those
# Line 235  These hooks have the following distinct Line 297  These hooks have the following distinct
297    
298    (if (< 0 number)    (if (< 0 number)
299        (let* ((original-date date);; save for possible use in the hooks        (let* ((original-date date);; save for possible use in the hooks
300               (old-diary-syntax-table)               old-diary-syntax-table
301               (diary-entries-list)               diary-entries-list
302                 file-glob-attrs
303               (date-string (calendar-date-string date))               (date-string (calendar-date-string date))
304               (d-file (substitute-in-file-name diary-file)))               (d-file (substitute-in-file-name diary-file)))
305          (message "Preparing diary...")          (message "Preparing diary...")
# Line 247  These hooks have the following distinct Line 310  These hooks have the following distinct
310                (set-buffer diary-buffer)                (set-buffer diary-buffer)
311                (or (verify-visited-file-modtime diary-buffer)                (or (verify-visited-file-modtime diary-buffer)
312                    (revert-buffer t t))))                    (revert-buffer t t))))
313              (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
314            (setq selective-display t)            (setq selective-display t)
315            (setq selective-display-ellipses nil)            (setq selective-display-ellipses nil)
316            (setq old-diary-syntax-table (syntax-table))            (setq old-diary-syntax-table (syntax-table))
# Line 322  These hooks have the following distinct Line 386  These hooks have the following distinct
386                               (backward-char 1)                               (backward-char 1)
387                               (subst-char-in-region date-start                               (subst-char-in-region date-start
388                                  (point) ?\^M ?\n t)                                  (point) ?\^M ?\n t)
389                                 (setq entry (buffer-substring entry-start (point))
390                                       temp (diary-pull-attrs entry file-glob-attrs)
391                                       entry (nth 0 temp)
392                                       marks (nth 1 temp))
393                               (add-to-diary-list                               (add-to-diary-list
394                                date                                date
395                                  entry
396                                (buffer-substring                                (buffer-substring
397                                 entry-start (point))                                 (1+ date-start) (1- entry-start))
398                                (buffer-substring                                (copy-marker entry-start) marks)))))
                                (1+ date-start) (1- entry-start)))))))  
399                       (setq d (cdr d)))                       (setq d (cdr d)))
400                     (or entry-found                     (or entry-found
401                         (not diary-list-include-blanks)                         (not diary-list-include-blanks)
402                         (setq diary-entries-list                         (setq diary-entries-list
403                               (append diary-entries-list                               (append diary-entries-list
404                                       (list (list date "" "")))))                                       (list (list date "" "" "" "")))))
405                     (setq date                     (setq date
406                           (calendar-gregorian-from-absolute                           (calendar-gregorian-from-absolute
407                             (1+ (calendar-absolute-from-gregorian date))))                             (1+ (calendar-absolute-from-gregorian date))))
# Line 426  changing the variable `diary-include-str Line 494  changing the variable `diary-include-str
494        (display-buffer (find-buffer-visiting d-file))        (display-buffer (find-buffer-visiting d-file))
495        (message "Preparing diary...done"))))        (message "Preparing diary...done"))))
496    
497    (defface diary-button-face '((((type pc) (class color))
498                       (:foreground "lightblue")))
499      "Default face used for buttons."
500      :version "21.4"
501      :group 'diary)
502    
503    (define-button-type 'diary-entry
504      'action #'diary-goto-entry
505      'face #'diary-button-face)
506    
507    (defun diary-goto-entry (button)
508      (let ((marker (button-get button 'marker)))
509        (when marker
510          (pop-to-buffer (marker-buffer marker))
511          (goto-char (marker-position marker)))))
512    
513  (defun fancy-diary-display ()  (defun fancy-diary-display ()
514    "Prepare a diary buffer with relevant entries in a fancy, noneditable form.    "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
515  This function is provided for optional use as the `diary-display-hook'."  This function is provided for optional use as the `diary-display-hook'."
# Line 510  This function is provided for optional u Line 594  This function is provided for optional u
594                                         date-holiday-list                                         date-holiday-list
595                                         (concat "\n" (make-string l ? ))))                                         (concat "\n" (make-string l ? ))))
596                      (insert ?\n (make-string (+ l longest) ?=) ?\n)))))                      (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
597            (if (< 0 (length (car (cdr (car entry-list)))))  
598                (insert (car (cdr (car entry-list))) ?\n))            (setq entry (car (cdr (car entry-list))))
599            (setq entry-list (cdr entry-list))))            (if (< 0 (length entry))
600                  (progn
601                    (if (nth 3 (car entry-list))
602                        (insert-button (concat entry "\n")
603                                       'marker (nth 3 (car entry-list))
604                                       :type 'diary-entry)
605                      (insert entry ?\n))
606                    (save-excursion
607                      (setq marks (nth 4 (car entry-list)))
608                      (setq temp-face (make-symbol (apply 'concat "temp-face-" (mapcar '(lambda (sym) (if (not (stringp sym)) (symbol-name sym) sym)) marks))))
609                      (make-face temp-face)
610                      ;; Remove :face info from the marks, copy the face info into temp-face
611                      (setq faceinfo marks)
612                      (while (setq faceinfo (memq :face faceinfo))
613                        (copy-face (read (nth 1 faceinfo)) temp-face)
614                        (setcar faceinfo nil)
615                        (setcar (cdr faceinfo) nil))
616                      (setq marks (delq nil marks))
617                      ;; Apply the font aspects
618                      (apply 'set-face-attribute temp-face nil marks)
619                      (search-backward entry)
620                      (overlay-put
621                       (make-overlay (match-beginning 0) (match-end 0)) 'face temp-face))
622                    ))
623              (setq entry-list (cdr entry-list))))
624        (set-buffer-modified-p nil)        (set-buffer-modified-p nil)
625        (goto-char (point-min))        (goto-char (point-min))
626        (setq buffer-read-only t)        (setq buffer-read-only t)
627        (display-buffer fancy-diary-buffer)        (display-buffer fancy-diary-buffer)
628          (fancy-diary-display-mode)
629        (message "Preparing diary...done"))))        (message "Preparing diary...done"))))
630    
631  (defun make-fancy-diary-buffer ()  (defun make-fancy-diary-buffer ()
# Line 636  system.  Alternatively, you can specify Line 745  system.  Alternatively, you can specify
745  to run it every morning at 1am."  to run it every morning at 1am."
746    (interactive "P")    (interactive "P")
747    (let* ((diary-display-hook 'fancy-diary-display)    (let* ((diary-display-hook 'fancy-diary-display)
          (diary-list-include-blanks t)  
748           (text (progn (list-diary-entries (calendar-current-date)           (text (progn (list-diary-entries (calendar-current-date)
749                                            (if ndays ndays diary-mail-days))                                            (if ndays ndays diary-mail-days))
750                        (set-buffer fancy-diary-buffer)                        (set-buffer fancy-diary-buffer)
751                        (buffer-substring (point-min) (point-max)))))                        (buffer-substring (point-min) (point-max)))))
752      (mail)      (compose-mail diary-mail-addr
753      (mail-to) (insert diary-mail-addr)                    (if (string-equal text "")
754      (mail-subject) (insert "Diary entries generated "                        "No entries found"
755                             (calendar-date-string (calendar-current-date)))                      (concat "Diary entries generated "
756      (mail-text) (insert text)                              (calendar-date-string (calendar-current-date)))))
757      (mail-send-and-exit nil)))      (insert text)
758        (funcall (get mail-user-agent 'sendfunc))))
759    
760    
761  (defun diary-name-pattern (string-array &optional fullname)  (defun diary-name-pattern (string-array &optional fullname)
762    "Convert an STRING-ARRAY, an array of strings to a pattern.    "Convert a STRING-ARRAY, an array of strings to a pattern.
763  The pattern will match any of the strings, either entirely or abbreviated  The pattern will match any of the strings, either entirely or abbreviated
764  to three characters.  An abbreviated form will match with or without a period;  to three characters.  An abbreviated form will match with or without a period;
765  If the optional FULLNAME is t, abbreviations will not match, just the full  If the optional FULLNAME is t, abbreviations will not match, just the full
# Line 682  After the entries are marked, the hooks Line 791  After the entries are marked, the hooks
791  `mark-diary-entries-hook' are run."  `mark-diary-entries-hook' are run."
792    (interactive)    (interactive)
793    (setq mark-diary-entries-in-calendar t)    (setq mark-diary-entries-in-calendar t)
794    (let ((d-file (substitute-in-file-name diary-file))    (let (file-glob-attrs
795            marks
796            (d-file (substitute-in-file-name diary-file))
797          (marking-diary-entries t))          (marking-diary-entries t))
798      (if (and d-file (file-exists-p d-file))      (if (and d-file (file-exists-p d-file))
799          (if (file-readable-p d-file)          (if (file-readable-p d-file)
800              (save-excursion              (save-excursion
801                (message "Marking diary entries...")                (message "Marking diary entries...")
802                (set-buffer (find-file-noselect d-file t))                (set-buffer (find-file-noselect d-file t))
803                  (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
804                (let ((d diary-date-forms)                (let ((d diary-date-forms)
805                      (old-diary-syntax-table))                      (old-diary-syntax-table))
806                  (setq old-diary-syntax-table (syntax-table))                  (setq old-diary-syntax-table (syntax-table))
# Line 766  After the entries are marked, the hooks Line 878  After the entries are marked, the hooks
878                                             (if (> (- current-y y) 50)                                             (if (> (- current-y y) 50)
879                                                 (+ y 100)                                                 (+ y 100)
880                                               y)))                                               y)))
881                                       (string-to-int y-str)))))                                       (string-to-int y-str))))
882                          (if dd-name                               (save-excursion
883                              (mark-calendar-days-named                                 (setq entry (buffer-substring-no-properties (point) (line-end-position))
884                               (cdr (assoc-ignore-case                                       temp (diary-pull-attrs entry file-glob-attrs)
885                                     (substring dd-name 0 3)                                       entry (nth 0 temp)
886                                     (calendar-make-alist                                       marks (nth 1 temp))))
887                                      calendar-day-name-array                          (if dd-name
888                                      0                              (mark-calendar-days-named
889                                      (lambda (x) (substring x 0 3))))))                               (cdr (assoc-ignore-case
890                            (if mm-name                                     (substring dd-name 0 3)
891                                (if (string-equal mm-name "*")                                     (calendar-make-alist
892                                    (setq mm 0)                                      calendar-day-name-array
893                                  (setq mm                                      0
894                                        (cdr (assoc-ignore-case                                      (lambda (x) (substring x 0 3))))) marks)
895                                              (substring mm-name 0 3)                            (if mm-name
896                                              (calendar-make-alist                                (if (string-equal mm-name "*")
897                                               calendar-month-name-array                                    (setq mm 0)
898                                               1                                  (setq mm
899                                               (lambda (x) (substring x 0 3)))                                        (cdr (assoc-ignore-case
900                                              )))))                                              (substring mm-name 0 3)
901                            (mark-calendar-date-pattern mm dd yy))))                                              (calendar-make-alist
902                                                 calendar-month-name-array
903                                                 1
904                                                 (lambda (x) (substring x 0 3)))
905                                                )))))
906                              (mark-calendar-date-pattern mm dd yy marks))))
907                      (setq d (cdr d))))                      (setq d (cdr d))))
908                  (mark-sexp-diary-entries)                  (mark-sexp-diary-entries)
909                  (run-hooks 'nongregorian-diary-marking-hook                  (run-hooks 'nongregorian-diary-marking-hook
# Line 808  is marked.  See the documentation for th Line 925  is marked.  See the documentation for th
925           (m)           (m)
926           (y)           (y)
927           (first-date)           (first-date)
928           (last-date))           (last-date)
929             (mark)
930             file-glob-attrs)
931        (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
932      (save-excursion      (save-excursion
933        (set-buffer calendar-buffer)        (set-buffer calendar-buffer)
934        (setq m displayed-month)        (setq m displayed-month)
# Line 856  is marked.  See the documentation for th Line 976  is marked.  See the documentation for th
976            (while (string-match "[\^M]" entry)            (while (string-match "[\^M]" entry)
977              (aset entry (match-beginning 0) ?\n )))              (aset entry (match-beginning 0) ?\n )))
978          (calendar-for-loop date from first-date to last-date do          (calendar-for-loop date from first-date to last-date do
979            (if (diary-sexp-entry sexp entry            (if (setq mark (diary-sexp-entry sexp entry
980                                  (calendar-gregorian-from-absolute date))                                  (calendar-gregorian-from-absolute date)))
981                (mark-visible-calendar-date                (progn
982                 (calendar-gregorian-from-absolute date))))))))                  (setq marks (diary-pull-attrs entry file-glob-attrs)
983                          temp (diary-pull-attrs entry file-glob-attrs)
984                          marks (nth 1 temp))
985                    (mark-visible-calendar-date
986                     (calendar-gregorian-from-absolute date)
987                     (if (< 0 (length marks))
988                         marks
989                       (if (consp mark)
990                         (car mark)))))))))))
991    
992  (defun mark-included-diary-files ()  (defun mark-included-diary-files ()
993    "Mark the diary entries from other diary files with those of the diary file.    "Mark the diary entries from other diary files with those of the diary file.
# Line 894  changing the variable `diary-include-str Line 1022  changing the variable `diary-include-str
1022          (sleep-for 2))))          (sleep-for 2))))
1023    (goto-char (point-min)))    (goto-char (point-min)))
1024    
1025  (defun mark-calendar-days-named (dayname)  (defun mark-calendar-days-named (dayname &optional color)
1026    "Mark all dates in the calendar window that are day DAYNAME of the week.    "Mark all dates in the calendar window that are day DAYNAME of the week.
1027  0 means all Sundays, 1 means all Mondays, and so on."  0 means all Sundays, 1 means all Mondays, and so on."
1028    (save-excursion    (save-excursion
# Line 912  changing the variable `diary-include-str Line 1040  changing the variable `diary-include-str
1040        (setq last-day (calendar-absolute-from-gregorian        (setq last-day (calendar-absolute-from-gregorian
1041                   (calendar-nth-named-day -1 dayname succ-month succ-year)))                   (calendar-nth-named-day -1 dayname succ-month succ-year)))
1042        (while (<= day last-day)        (while (<= day last-day)
1043          (mark-visible-calendar-date (calendar-gregorian-from-absolute day))          (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color)
1044          (setq day (+ day 7))))))          (setq day (+ day 7))))))
1045    
1046  (defun mark-calendar-date-pattern (month day year)  (defun mark-calendar-date-pattern (month day year &optional color)
1047    "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.    "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
1048  A value of 0 in any position is a wildcard."  A value of 0 in any position is a wildcard."
1049    (save-excursion    (save-excursion
# Line 924  A value of 0 in any position is a wildca Line 1052  A value of 0 in any position is a wildca
1052            (y displayed-year))            (y displayed-year))
1053        (increment-calendar-month m y -1)        (increment-calendar-month m y -1)
1054        (calendar-for-loop i from 0 to 2 do        (calendar-for-loop i from 0 to 2 do
1055            (mark-calendar-month m y month day year)            (mark-calendar-month m y month day year color)
1056            (increment-calendar-month m y 1)))))            (increment-calendar-month m y 1)))))
1057    
1058  (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)
1059    "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.    "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
1060  A value of 0 in any position of the pattern is a wildcard."  A value of 0 in any position of the pattern is a wildcard."
1061    (if (or (and (= month p-month)    (if (or (and (= month p-month)
# Line 937  A value of 0 in any position of the patt Line 1065  A value of 0 in any position of the patt
1065        (if (= p-day 0)        (if (= p-day 0)
1066            (calendar-for-loop            (calendar-for-loop
1067                i from 1 to (calendar-last-day-of-month month year) do                i from 1 to (calendar-last-day-of-month month year) do
1068              (mark-visible-calendar-date (list month i year)))              (mark-visible-calendar-date (list month i year) color))
1069          (mark-visible-calendar-date (list month p-day year)))))          (mark-visible-calendar-date (list month p-day year) color))))
1070    
1071  (defun sort-diary-entries ()  (defun sort-diary-entries ()
1072    "Sort the list of diary entries by time of day."    "Sort the list of diary entries by time of day."
# Line 965  after those with times." Line 1093  after those with times."
1093    :version "20.3")    :version "20.3")
1094    
1095  (defun diary-entry-time (s)  (defun diary-entry-time (s)
1096    "Time at the beginning of the string S in a military-style integer.  For    "Return time at the beginning of the string S as a military-style integer.
1097  example, returns 1325 for 1:25pm.  Returns `diary-unknown-time' (default value  For example, returns 1325 for 1:25pm.
1098  -9999) if no time is recognized.  The recognized forms are XXXX, X:XX, or  Returns `diary-unknown-time' (default value -9999) if no time is recognized.  The recognized forms are XXXX, X:XX, or
1099  XX:XX (military time), and XXam, XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm,  XX:XX (military time), and XXam, XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm,
1100  or XX:XXPM."  or XX:XXPM."
1101    (let ((case-fold-search nil))    (let ((case-fold-search nil))
# Line 1020  if it is a weekday and the Friday before Line 1148  if it is a weekday and the Friday before
1148    
1149  A number of built-in functions are available for this type of diary entry:  A number of built-in functions are available for this type of diary entry:
1150    
1151        %%(diary-date MONTH DAY YEAR) text        %%(diary-date MONTH DAY YEAR &optional MARK) text
1152                    Entry applies if date is MONTH, DAY, YEAR if                    Entry applies if date is MONTH, DAY, YEAR if
1153                    `european-calendar-style' is nil, and DAY, MONTH, YEAR if                    `european-calendar-style' is nil, and DAY, MONTH, YEAR if
1154                    `european-calendar-style' is t.  DAY, MONTH, and YEAR                    `european-calendar-style' is t.  DAY, MONTH, and YEAR
1155                    can be lists of integers, the constant t, or an integer.                    can be lists of integers, the constant t, or an integer.
1156                    The constant t means all values.                    The constant t means all values.  An optional parameter
1157                      MARK specifies a face or single-character string to use
1158                      when highlighting the day in the calendar.
1159    
1160        %%(diary-float MONTH DAYNAME N &optional DAY) text        %%(diary-float MONTH DAYNAME N &optional DAY MARK) text
1161                    Entry will appear on the Nth DAYNAME of MONTH.                    Entry will appear on the Nth DAYNAME of MONTH.
1162                    (DAYNAME=0 means Sunday, 1 means Monday, and so on;                    (DAYNAME=0 means Sunday, 1 means Monday, and so on;
1163                    if N is negative it counts backward from the end of                    if N is negative it counts backward from the end of
1164                    the month.  MONTH can be a list of months, a single                    the month.  MONTH can be a list of months, a single
1165                    month, or t to specify all months. Optional DAY means                    month, or t to specify all months. Optional DAY means
1166                    Nth DAYNAME of MONTH on or after/before DAY.  DAY defaults                    Nth DAYNAME of MONTH on or after/before DAY.  DAY defaults
1167                    to 1 if N>0 and the last day of the month if N<0.                    to 1 if N>0 and the last day of the month if N<0.  An
1168                      optional parameter MARK specifies a face or single-character
1169                      string to use when highlighting the day in the calendar.
1170    
1171        %%(diary-block M1 D1 Y1 M2 D2 Y2) text        %%(diary-block M1 D1 Y1 M2 D2 Y2 &optional MARK) text
1172                    Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,                    Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
1173                    inclusive.  (If `european-calendar-style' is t, the                    inclusive.  (If `european-calendar-style' is t, the
1174                    order of the parameters should be changed to D1, M1, Y1,                    order of the parameters should be changed to D1, M1, Y1,
1175                    D2, M2, Y2.)                    D2, M2, Y2.)  An optional parameter MARK specifies a face
1176                      or single-character string to use when highlighting the
1177                      day in the calendar.
1178    
1179        %%(diary-anniversary MONTH DAY YEAR) text        %%(diary-anniversary MONTH DAY YEAR &optional MARK) text
1180                    Entry will appear on anniversary dates of MONTH DAY, YEAR.                    Entry will appear on anniversary dates of MONTH DAY, YEAR.
1181                    (If `european-calendar-style' is t, the order of the                    (If `european-calendar-style' is t, the order of the
1182                    parameters should be changed to DAY, MONTH, YEAR.)  Text                    parameters should be changed to DAY, MONTH, YEAR.)  Text
# Line 1050  A number of built-in functions are avail Line 1184  A number of built-in functions are avail
1184                    of years since the MONTH DAY, YEAR and %s will be replaced                    of years since the MONTH DAY, YEAR and %s will be replaced
1185                    by the ordinal ending of that number (that is, `st', `nd',                    by the ordinal ending of that number (that is, `st', `nd',
1186                    `rd' or `th', as appropriate.  The anniversary of February                    `rd' or `th', as appropriate.  The anniversary of February
1187                    29 is considered to be March 1 in a non-leap year.                    29 is considered to be March 1 in a non-leap year.  An
1188                      optional parameter MARK specifies a face or single-character
1189                      string to use when highlighting the day in the calendar.
1190    
1191        %%(diary-cyclic N MONTH DAY YEAR) text        %%(diary-cyclic N MONTH DAY YEAR &optional MARK) text
1192                    Entry will appear every N days, starting MONTH DAY, YEAR.                    Entry will appear every N days, starting MONTH DAY, YEAR.
1193                    (If `european-calendar-style' is t, the order of the                    (If `european-calendar-style' is t, the order of the
1194                    parameters should be changed to N, DAY, MONTH, YEAR.)  Text                    parameters should be changed to N, DAY, MONTH, YEAR.)  Text
1195                    can contain %d or %d%s; %d will be replaced by the number                    can contain %d or %d%s; %d will be replaced by the number
1196                    of repetitions since the MONTH DAY, YEAR and %s will                    of repetitions since the MONTH DAY, YEAR and %s will
1197                    be replaced by the ordinal ending of that number (that is,                    be replaced by the ordinal ending of that number (that is,
1198                    `st', `nd', `rd' or `th', as appropriate.                    `st', `nd', `rd' or `th', as appropriate.  An optional
1199                      parameter MARK specifies a face or single-character string
1200                      to use when highlighting the day in the calendar.
1201    
1202        %%(diary-remind SEXP DAYS &optional MARKING) text        %%(diary-remind SEXP DAYS &optional MARKING) text
1203                    Entry is a reminder for diary sexp SEXP.  DAYS is either a                    Entry is a reminder for diary sexp SEXP.  DAYS is either a
# Line 1149  best if they are nonmarking." Line 1287  best if they are nonmarking."
1287    (let* ((mark (regexp-quote diary-nonmarking-symbol))    (let* ((mark (regexp-quote diary-nonmarking-symbol))
1288           (sexp-mark (regexp-quote sexp-diary-entry-symbol))           (sexp-mark (regexp-quote sexp-diary-entry-symbol))
1289           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
1290           (entry-found))           (entry-found)
1291             (file-glob-attrs)
1292             (marks))
1293      (goto-char (point-min))      (goto-char (point-min))
1294        (save-excursion
1295          (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))
1296      (while (re-search-forward s-entry nil t)      (while (re-search-forward s-entry nil t)
1297        (backward-char 1)        (backward-char 1)
1298        (let ((sexp-start (point))        (let ((sexp-start (point))
# Line 1165  best if they are nonmarking." Line 1307  best if they are nonmarking."
1307            (re-search-backward "\^M\\|\n\\|\\`")            (re-search-backward "\^M\\|\n\\|\\`")
1308            (setq line-start (point)))            (setq line-start (point)))
1309          (setq specifier          (setq specifier
1310                (buffer-substring-no-properties (1+ line-start) (point)))                (buffer-substring-no-properties (1+ line-start) (point))
1311                  entry-start (1+ line-start))
1312          (forward-char 1)          (forward-char 1)
1313          (if (and (or (char-equal (preceding-char) ?\^M)          (if (and (or (char-equal (preceding-char) ?\^M)
1314                       (char-equal (preceding-char) ?\n))                       (char-equal (preceding-char) ?\n))
# Line 1182  best if they are nonmarking." Line 1325  best if they are nonmarking."
1325            (while (string-match "[\^M]" entry)            (while (string-match "[\^M]" entry)
1326              (aset entry (match-beginning 0) ?\n )))              (aset entry (match-beginning 0) ?\n )))
1327          (let ((diary-entry (diary-sexp-entry sexp entry date)))          (let ((diary-entry (diary-sexp-entry sexp entry date)))
1328              (setq entry (if (consp diary-entry)
1329                              (cdr diary-entry)
1330                            diary-entry))
1331            (if diary-entry            (if diary-entry
1332                (subst-char-in-region line-start (point) ?\^M ?\n t))                (progn
1333            (add-to-diary-list date diary-entry specifier)                  (subst-char-in-region line-start (point) ?\^M ?\n t)
1334            (setq entry-found (or entry-found diary-entry)))))                  (if (< 0 (length entry))
1335                        (setq temp (diary-pull-attrs entry file-glob-attrs)
1336                              entry (nth 0 temp)
1337                              marks (nth 1 temp)))))
1338              (add-to-diary-list date
1339                                 entry
1340                                 specifier
1341                                 (if entry-start (copy-marker entry-start)
1342                                   nil)
1343                                 marks)
1344              (setq entry-found (or entry-found diary-entry)))))
1345      entry-found))      entry-found))
1346    
1347  (defun diary-sexp-entry (sexp entry date)  (defun diary-sexp-entry (sexp entry date)
# Line 1208  best if they are nonmarking." Line 1364  best if they are nonmarking."
1364                                      lines)))                                      lines)))
1365                                diary-file sexp)                                diary-file sexp)
1366                       (sleep-for 2))))))                       (sleep-for 2))))))
1367      (if (stringp result)      (cond ((stringp result) result)
1368          result            ((and (consp result)
1369        (if result                  (stringp (cdr result))) result)
1370            entry            (result entry)
1371          nil))))            (t nil))))
1372    
1373  (defun diary-date (month day year)  (defun diary-date (month day year &optional mark)
1374    "Specific date(s) diary entry.    "Specific date(s) diary entry.
1375  Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil,  Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil,
1376  and DAY, MONTH, YEAR if `european-calendar-style' is t.  DAY, MONTH, and YEAR  and DAY, MONTH, YEAR if `european-calendar-style' is t.  DAY, MONTH, and YEAR
1377  can be lists of integers, the constant t, or an integer.  The constant t means  can be lists of integers, the constant t, or an integer.  The constant t means
1378  all values."  all values.
1379    
1380    An optional parameter MARK specifies a face or single-character string to
1381    use when highlighting the day in the calendar."
1382    (let* ((dd (if european-calendar-style    (let* ((dd (if european-calendar-style
1383                  month                  month
1384                day))                day))
# Line 1239  all values." Line 1398  all values."
1398           (or (and (listp year) (memq y year))           (or (and (listp year) (memq y year))
1399               (equal y year)               (equal y year)
1400               (eq year t)))               (eq year t)))
1401          entry)))          (cons mark entry))))
1402    
1403  (defun diary-block (m1 d1 y1 m2 d2 y2)  (defun diary-block (m1 d1 y1 m2 d2 y2 &optional mark)
1404    "Block diary entry.    "Block diary entry.
1405  Entry applies if date is between, or on one of, two dates.  Entry applies if date is between, or on one of, two dates.
1406  The order of the parameters is  The order of the parameters is
1407  M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and  M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and
1408  D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."  D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t.
1409    
1410    An optional parameter MARK specifies a face or single-character string to
1411    use when highlighting the day in the calendar."
1412    
1413    (let ((date1 (calendar-absolute-from-gregorian    (let ((date1 (calendar-absolute-from-gregorian
1414                  (if european-calendar-style                  (if european-calendar-style
1415                      (list d1 m1 y1)                      (list d1 m1 y1)
# Line 1257  D1, M1, Y1, D2, M2, Y2 if `european-cale Line 1420  D1, M1, Y1, D2, M2, Y2 if `european-cale
1420                    (list m2 d2 y2))))                    (list m2 d2 y2))))
1421          (d (calendar-absolute-from-gregorian date)))          (d (calendar-absolute-from-gregorian date)))
1422      (if (and (<= date1 d) (<= d date2))      (if (and (<= date1 d) (<= d date2))
1423          entry)))          (cons mark entry))))
1424    
1425  (defun diary-float (month dayname n &optional day)  (defun diary-float (month dayname n &optional day mark)
1426    "Floating diary entry--entry applies if date is the nth dayname of month.    "Floating diary entry--entry applies if date is the nth dayname of month.
1427  Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant  Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
1428  t, or an integer.  The constant t means all months.  If N is negative, count  t, or an integer.  The constant t means all months.  If N is negative, count
1429  backward from the end of the month.  backward from the end of the month.
1430    
1431  An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY."  An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
1432    Optional MARK specifies a face or single-character string to use when
1433    highlighting the day in the calendar."
1434  ;; This is messy because the diary entry may apply, but the date on which it  ;; This is messy because the diary entry may apply, but the date on which it
1435  ;; is based can be in a different month/year.  For example, asking for the  ;; is based can be in a different month/year.  For example, asking for the
1436  ;; first Monday after December 30.  For large values of |n| the problem is  ;; first Monday after December 30.  For large values of |n| the problem is
# Line 1319  An optional parameter DAY means the Nth Line 1484  An optional parameter DAY means the Nth
1484                                              1                                              1
1485                                            (calendar-last-day-of-month m2 y2)))                                            (calendar-last-day-of-month m2 y2)))
1486                                  d2)))))                                  d2)))))
1487               entry))))               (cons mark entry)))))
1488    
1489    
1490  (defun diary-anniversary (month day year)  (defun diary-anniversary (month day year &optional mark)
1491    "Anniversary diary entry.    "Anniversary diary entry.
1492  Entry applies if date is the anniversary of MONTH, DAY, YEAR if  Entry applies if date is the anniversary of MONTH, DAY, YEAR if
1493  `european-calendar-style' is nil, and DAY, MONTH, YEAR if  `european-calendar-style' is nil, and DAY, MONTH, YEAR if
# Line 1330  Entry applies if date is the anniversary Line 1495  Entry applies if date is the anniversary
1495  %d will be replaced by the number of years since the MONTH DAY, YEAR and the  %d will be replaced by the number of years since the MONTH DAY, YEAR and the
1496  %s will be replaced by the ordinal ending of that number (that is, `st', `nd',  %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
1497  `rd' or `th', as appropriate.  The anniversary of February 29 is considered  `rd' or `th', as appropriate.  The anniversary of February 29 is considered
1498  to be March 1 in non-leap years."  to be March 1 in non-leap years.
1499    
1500    An optional parameter MARK specifies a face or single-character string to
1501    use when highlighting the day in the calendar."
1502    (let* ((d (if european-calendar-style    (let* ((d (if european-calendar-style
1503                  month                  month
1504                day))                day))
# Line 1343  to be March 1 in non-leap years." Line 1511  to be March 1 in non-leap years."
1511          (setq m 3          (setq m 3
1512                d 1))                d 1))
1513      (if (and (> diff 0) (calendar-date-equal (list m d y) date))      (if (and (> diff 0) (calendar-date-equal (list m d y) date))
1514          (format entry diff (diary-ordinal-suffix diff)))))          (cons mark (format entry diff (diary-ordinal-suffix diff))))))
1515    
1516  (defun diary-cyclic (n month day year)  (defun diary-cyclic (n month day year &optional mark)
1517    "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.    "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1518  If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.  If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1519  ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of  ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
1520  repetitions since the MONTH DAY, YEAR and %s will be replaced by the  repetitions since the MONTH DAY, YEAR and %s will be replaced by the
1521  ordinal ending of that number (that is, `st', `nd', `rd' or `th', as  ordinal ending of that number (that is, `st', `nd', `rd' or `th', as
1522  appropriate."  appropriate.
1523    
1524    An optional parameter MARK specifies a face or single-character string to
1525    use when highlighting the day in the calendar."
1526    (let* ((d (if european-calendar-style    (let* ((d (if european-calendar-style
1527                  month                  month
1528                day))                day))
# Line 1363  appropriate." Line 1534  appropriate."
1534                     (list m d year))))                     (list m d year))))
1535           (cycle (/ diff n)))           (cycle (/ diff n)))
1536      (if (and (>= diff 0) (zerop (% diff n)))      (if (and (>= diff 0) (zerop (% diff n)))
1537          (format entry cycle (diary-ordinal-suffix cycle)))))          (cons mark (format entry cycle (diary-ordinal-suffix cycle))))))
1538    
1539  (defun diary-ordinal-suffix (n)  (defun diary-ordinal-suffix (n)
1540    "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"    "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
# Line 1427  marked on the calendar." Line 1598  marked on the calendar."
1598        (or (diary-remind sexp (car days) marking)        (or (diary-remind sexp (car days) marking)
1599            (diary-remind sexp (cdr days) marking))))))            (diary-remind sexp (cdr days) marking))))))
1600    
1601  (defun add-to-diary-list (date string specifier)  (defun add-to-diary-list (date string specifier marker &optional globcolor)
1602    "Add the entry (DATE STRING SPECIFIER) to `diary-entries-list'.    "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'.
1603  Do nothing if DATE or STRING is nil."  Do nothing if DATE or STRING is nil."
1604    (and date string    (and date string
1605           (if (and diary-file-name-prefix
1606                    (setq prefix (concat "[" (funcall diary-file-name-prefix-function (buffer-file-name)) "] "))
1607                    (not (string= prefix "[] ")))
1608               (setq string (concat prefix string))
1609             t)
1610         (setq diary-entries-list         (setq diary-entries-list
1611               (append diary-entries-list (list (list date string specifier))))))               (append diary-entries-list
1612                         (list (list date string specifier marker globcolor))))))
1613    
1614  (defun make-diary-entry (string &optional nonmarking file)  (defun make-diary-entry (string &optional nonmarking file)
1615    "Insert a diary entry STRING which may be NONMARKING in FILE.    "Insert a diary entry STRING which may be NONMARKING in FILE.
1616  If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."  If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
1617    (find-file-other-window    (find-file-other-window
1618     (substitute-in-file-name (if file file diary-file)))     (substitute-in-file-name (if file file diary-file)))
1619      (widen)
1620    (goto-char (point-max))    (goto-char (point-max))
1621      (when (let ((case-fold-search t))
1622              (search-backward "Local Variables:"
1623                               (max (- (point-max) 3000) (point-min))
1624                               t))
1625        (beginning-of-line)
1626        (insert "\n")
1627        (previous-line 1))
1628    (insert    (insert
1629     (if (bolp) "" "\n")     (if (bolp) "" "\n")
1630     (if nonmarking diary-nonmarking-symbol "")     (if nonmarking diary-nonmarking-symbol "")
# Line 1537  Prefix arg will make the entry nonmarkin Line 1722  Prefix arg will make the entry nonmarkin
1722               (calendar-date-string (calendar-cursor-to-date t) nil t))               (calendar-date-string (calendar-cursor-to-date t) nil t))
1723       arg)))       arg)))
1724    
1725    ;;;###autoload
1726    (define-derived-mode diary-mode text-mode
1727      "Diary"
1728      "Major mode for editing the diary file."
1729      (set (make-local-variable 'font-lock-defaults)
1730           '(diary-font-lock-keywords t)))
1731    
1732    (define-derived-mode fancy-diary-display-mode text-mode
1733      "Diary"
1734      "Major mode used while displaying diary entries using Fancy Display."
1735      (set (make-local-variable 'font-lock-defaults)
1736           '(fancy-diary-font-lock-keywords t)))
1737    
1738    
1739    (defvar fancy-diary-font-lock-keywords
1740      (list
1741       (cons
1742        (concat
1743         (let ((dayname
1744                (concat "\\("
1745                        (diary-name-pattern calendar-day-name-array t)
1746                        "\\)"))
1747               (monthname
1748                (concat "\\("
1749                        (diary-name-pattern calendar-month-name-array t)
1750                        "\\)"))
1751               (day "[0-9]+")
1752               (month "[0-9]+")
1753               (year "-?[0-9]+"))
1754           (mapconcat 'eval calendar-date-display-form ""))
1755         "\\(\\(: .*\\)\\|\\(\n +.*\\)\\)*\n=+$")
1756        'diary-face)
1757       '("^.*anniversary.*$" . font-lock-keyword-face)
1758       '("^.*birthday.*$" . font-lock-keyword-face)
1759       '("^.*Yahrzeit.*$" . font-lock-reference-face)
1760       '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
1761       '("^Day.*omer.*$" . font-lock-builtin-face)
1762       '("^Parashat.*$" . font-lock-comment-face)
1763       '("^[ \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\\)?\\)?"
1764         . font-lock-variable-name-face))
1765      "Keywords to highlight in fancy diary display")
1766    
1767    
1768    (defun font-lock-diary-sexps (limit)
1769      "Recognize sexp diary entry for font-locking."
1770      (if (re-search-forward
1771           (concat "^" (regexp-quote diary-nonmarking-symbol)
1772                   "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
1773           limit t)
1774          (condition-case nil
1775              (save-restriction
1776                (narrow-to-region (point-min) limit)
1777                (let ((start (point)))
1778                  (forward-sexp 1)
1779                  (store-match-data (list start (point)))
1780                  t))
1781            (error t))))
1782    
1783    (defun font-lock-diary-date-forms (month-list &optional symbol noabbrev)
1784      "Create a list of font-lock patterns for `diary-date-forms' with MONTH-LIST.
1785    If given, optional SYMBOL must be a prefix to entries.
1786    If optional NOABBREV is t, do not allow abbreviations in names."
1787      (let* ((dayname
1788              (concat "\\(" (diary-name-pattern calendar-day-name-array) "\\)"))
1789             (monthname (concat "\\("
1790                                (diary-name-pattern month-list noabbrev)
1791                                "\\|\\*\\)"))
1792             (month "\\([0-9]+\\|\\*\\)")
1793             (day "\\([0-9]+\\|\\*\\)")
1794             (year "-?\\([0-9]+\\|\\*\\)"))
1795        (mapcar '(lambda (x)
1796                   (cons
1797                    (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
1798                            (if symbol (regexp-quote symbol) "") "\\("
1799                            (mapconcat 'eval
1800                                       ;; If backup, omit first item (backup)
1801                                       ;; and last item (not part of date)
1802                                       (if (equal (car x) 'backup)
1803                                           (reverse (cdr (reverse (cdr x))))
1804                                         x)
1805                                       "")
1806                            ;; With backup, last item is not part of date
1807                            (if (equal (car x) 'backup)
1808                                (concat "\\)" (eval (car (reverse x))))
1809                              "\\)"))
1810                    '(1 diary-face)))
1811                diary-date-forms)))
1812    
1813    (defvar diary-font-lock-keywords
1814          (append
1815           (font-lock-diary-date-forms calendar-month-name-array)
1816           (if (or (memq 'mark-hebrew-diary-entries
1817                         nongregorian-diary-marking-hook)
1818                   (memq 'list-hebrew-diary-entries
1819                         nongregorian-diary-listing-hook))
1820               (progn
1821                 (require 'cal-hebrew)
1822                 (font-lock-diary-date-forms
1823                  calendar-hebrew-month-name-array-leap-year
1824                  hebrew-diary-entry-symbol t)))
1825           (if (or (memq 'mark-islamic-diary-entries
1826                         nongregorian-diary-marking-hook)
1827                   (memq 'list-islamic-diary-entries
1828                         nongregorian-diary-listing-hook))
1829               (progn
1830                 (require 'cal-islamic)
1831                 (font-lock-diary-date-forms
1832                  calendar-islamic-month-name-array-leap-year
1833                  islamic-diary-entry-symbol t)))
1834           (list
1835            (cons
1836             (concat "^" (regexp-quote diary-include-string) ".*$")
1837             'font-lock-keyword-face)
1838            (cons
1839             (concat "^" (regexp-quote diary-nonmarking-symbol)
1840                     "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
1841             '(1 font-lock-reference-face))
1842            (cons
1843             (concat "^" (regexp-quote diary-nonmarking-symbol))
1844             'font-lock-reference-face)
1845            (cons
1846             (concat "^" (regexp-quote diary-nonmarking-symbol)
1847                     "?\\(" (regexp-quote hebrew-diary-entry-symbol) "\\)")
1848             '(1 font-lock-reference-face))
1849            (cons
1850             (concat "^" (regexp-quote diary-nonmarking-symbol)
1851                     "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)")
1852             '(1 font-lock-reference-face))
1853            '(font-lock-diary-sexps . font-lock-keyword-face)
1854            '("[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\(-[0-9]?[0-9]\\(:?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\)?"
1855              . font-lock-function-name-face)))
1856          "Forms to highlight in diary-mode")
1857    
1858    
1859  (provide 'diary-lib)  (provide 'diary-lib)
1860    
1861  ;;; diary-lib.el ends here  ;;; diary-lib.el ends here

Legend:
Removed from v.1.54  
changed lines
  Added in v.1.54.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26