/[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.2.1 by miles, Fri Apr 4 06:20:15 2003 UTC revision 1.54.2.2 by miles, Tue Oct 14 23:42:14 2003 UTC
# Line 1  Line 1 
1  ;;; diary-lib.el --- diary functions  ;;; diary-lib.el --- diary functions
2    
3  ;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software  ;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2003
4  ;; Foundation, Inc.  ;;           Free Software Foundation, Inc.
5    
6  ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>  ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7  ;; Keywords: calendar  ;; Keywords: calendar
# Line 38  Line 38 
38    
39  (require 'calendar)  (require 'calendar)
40    
41    (defun diary-check-diary-file ()
42      "Check that the file specified by `diary-file' exists and is readable.
43    If so, return the expanded file name, otherwise signal an error."
44      (let ((d-file (substitute-in-file-name diary-file)))
45        (if (and d-file (file-exists-p d-file))
46            (if (file-readable-p d-file)
47                d-file
48              (error "Diary file `%s' is not readable" diary-file))
49          (error "Diary file `%s' does not exist" diary-file))))
50    
51  ;;;###autoload  ;;;###autoload
52  (defun diary (&optional arg)  (defun diary (&optional arg)
53    "Generate the diary window for ARG days starting with the current date.    "Generate the diary window for ARG days starting with the current date.
# Line 45  If no argument is provided, the number o Line 55  If no argument is provided, the number o
55  by the variable `number-of-diary-entries'.  This function is suitable for  by the variable `number-of-diary-entries'.  This function is suitable for
56  execution in a `.emacs' file."  execution in a `.emacs' file."
57    (interactive "P")    (interactive "P")
58    (let ((d-file (substitute-in-file-name diary-file))    (diary-check-diary-file)
59          (date (calendar-current-date)))    (let ((date (calendar-current-date)))
60      (if (and d-file (file-exists-p d-file))      (list-diary-entries
61          (if (file-readable-p d-file)       date
62              (list-diary-entries       (cond (arg (prefix-numeric-value arg))
63               date             ((vectorp number-of-diary-entries)
64               (cond              (aref number-of-diary-entries (calendar-day-of-week date)))
65                (arg (prefix-numeric-value arg))             (t number-of-diary-entries)))))
               ((vectorp number-of-diary-entries)  
                (aref number-of-diary-entries (calendar-day-of-week date)))  
               (t number-of-diary-entries)))  
         (error "Your diary file is not readable!"))  
       (error "You don't have a diary file!"))))  
66    
67  (defun view-diary-entries (arg)  (defun view-diary-entries (arg)
68    "Prepare and display a buffer with diary entries.    "Prepare and display a buffer with diary entries.
# Line 65  Searches the file named in `diary-file' Line 70  Searches the file named in `diary-file'
70  match ARG days starting with the date indicated by the cursor position  match ARG days starting with the date indicated by the cursor position
71  in the displayed three-month calendar."  in the displayed three-month calendar."
72    (interactive "p")    (interactive "p")
73    (let ((d-file (substitute-in-file-name diary-file)))    (diary-check-diary-file)
74      (if (and d-file (file-exists-p d-file))    (list-diary-entries (calendar-cursor-to-date t) arg))
         (if (file-readable-p d-file)  
             (list-diary-entries (calendar-cursor-to-date t) arg)  
           (error "Diary file is not readable!"))  
       (error "You don't have a diary file!"))))  
75    
76  (defun view-other-diary-entries (arg d-file)  (defun view-other-diary-entries (arg d-file)
77    "Prepare and display buffer of diary entries from an alternative diary file.    "Prepare and display buffer of diary entries from an alternative diary file.
78  Prompts for a file name and searches that file for entries that match ARG  Searches for entries that match ARG days, starting with the date indicated
79  days starting with the date indicated by the cursor position in the displayed  by the cursor position in the displayed three-month calendar.
80  three-month calendar."  D-FILE specifies the file to use as the diary file."
81    (interactive    (interactive
82     (list (cond ((null current-prefix-arg) 1)     (list (if arg (prefix-numeric-value arg) 1)
                ((listp current-prefix-arg) (car current-prefix-arg))  
                (t current-prefix-arg))  
83           (read-file-name "Enter diary file name: " default-directory nil t)))           (read-file-name "Enter diary file name: " default-directory nil t)))
84    (let ((diary-file d-file))    (let ((diary-file d-file))
85      (view-diary-entries arg)))      (view-diary-entries arg)))
# Line 169  No diary entry if there is no sunset on Line 168  No diary entry if there is no sunset on
168  (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))  (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
169    "The syntax table used when parsing dates in the diary file.    "The syntax table used when parsing dates in the diary file.
170  It is the standard syntax table used in Fundamental mode, but with the  It is the standard syntax table used in Fundamental mode, but with the
171  syntax of `*' changed to be a word constituent.")  syntax of `*' and `:' changed to be word constituents.")
172    
173  (modify-syntax-entry ?* "w" diary-syntax-table)  (modify-syntax-entry ?* "w" diary-syntax-table)
174  (modify-syntax-entry ?: "w" diary-syntax-table)  (modify-syntax-entry ?: "w" diary-syntax-table)
175    
 (defvar diary-modified)  
176  (defvar diary-entries-list)  (defvar diary-entries-list)
177  (defvar displayed-year)  (defvar displayed-year)
178  (defvar displayed-month)  (defvar displayed-month)
# Line 182  syntax of `*' changed to be a word const Line 180  syntax of `*' changed to be a word const
180  (defvar date)  (defvar date)
181  (defvar number)  (defvar number)
182  (defvar date-string)  (defvar date-string)
 (defvar d-file)  
183  (defvar original-date)  (defvar original-date)
184    
185  (defun diary-attrtype-convert (attrvalue type)  (defun diary-attrtype-convert (attrvalue type)
186    "Convert the attrvalue from a string to the appropriate type for using    "Convert string ATTRVALUE to TYPE appropriate for a face description.
187  in a face description"  Valid TYPEs are: string, symbol, int, stringtnil, tnil."
188    (let (ret)    (let (ret)
189      (setq ret (cond ((eq type 'string) attrvalue)      (setq ret (cond ((eq type 'string) attrvalue)
190                      ((eq type 'symbol) (read attrvalue))                      ((eq type 'symbol) (read attrvalue))
# Line 201  in a face description" Line 198  in a face description"
198                             ((string= "nil" attrvalue) nil)))))                             ((string= "nil" attrvalue) nil)))))
199  ;    (message "(%s)[%s]=[%s]" (print type) attrvalue ret)  ;    (message "(%s)[%s]=[%s]" (print type) attrvalue ret)
200      ret))      ret))
201            
202    
203  (defun diary-pull-attrs (entry fileglobattrs)  (defun diary-pull-attrs (entry fileglobattrs)
204    "Pull the face-related attributes off the entry, merge with the    "Pull the face-related attributes off the entry, merge with the
205  fileglobattrs, and return the (possibly modified) entry and face  fileglobattrs, and return the (possibly modified) entry and face
206  data in a list of attrname attrvalue values.    data in a list of attrname attrvalue values.
207  The entry will be modified to drop all tags that are used for face matching.  The entry will be modified to drop all tags that are used for face matching.
208  If entry is nil, then the fileglobattrs are being searched for,  If entry is nil, then the fileglobattrs are being searched for,
209  the fileglobattrs variable is ignored, and  the fileglobattrs variable is ignored, and
210  diary-glob-file-regexp-prefix is prepended to the regexps before each  diary-glob-file-regexp-prefix is prepended to the regexps before each
211  search."  search."
212    (save-excursion    (save-excursion
213      (let (regexp regnum attrname attr-list attrname attrvalue type)      (let (regexp regnum attrname attr-list attrname attrvalue type
214                     ret-attr attr)
215        (if (null entry)        (if (null entry)
216            (progn            (progn
217              (setq ret-attr '()              (setq ret-attr '()
# Line 248  search." Line 246  search."
246                    type (nth 3 attr))                    type (nth 3 attr))
247              (setq attrvalue nil)              (setq attrvalue nil)
248              (if (string-match regexp entry)              (if (string-match regexp entry)
249                  (progn                  (progn
250                    (setq attrvalue (substring-no-properties entry                    (setq attrvalue (substring-no-properties entry
251                                                             (match-beginning regnum)                                                             (match-beginning regnum)
252                                                             (match-end regnum)))                                                             (match-end regnum)))
# Line 256  search." Line 254  search."
254              (if (and attrvalue              (if (and attrvalue
255                       (setq attrvalue (diary-attrtype-convert attrvalue type)))                       (setq attrvalue (diary-attrtype-convert attrvalue type)))
256                  (setq ret-attr (append ret-attr (list attrname attrvalue))))                  (setq ret-attr (append ret-attr (list attrname attrvalue))))
257              (setq attr-list (cdr attr-list)))))))              (setq attr-list (cdr attr-list)))))
258    (list entry ret-attr))        (list entry ret-attr))))
259      
260      
261    ;; This can be removed once the kill/yank treatment of invisible text
262    ;; (see etc/TODO) is fixed. -- gm
263    (defcustom diary-header-line-flag t
264      "*If non-nil, `simple-diary-display' will show a header line.
265    The format of the header is specified by `diary-header-line-format'."
266      :group   'diary
267      :type    'boolean
268      :version "21.4")
269    
270    (defcustom diary-header-line-format
271      '(:eval (calendar-string-spread
272               (list (if selective-display
273                         "Selective display active - press \"s\" in calendar \
274    before edit/copy"
275                       "Diary"))
276               ?\ (frame-width)))
277      "*Format of the header line displayed by `simple-diary-display'.
278    Only used if `diary-header-line-flag' is non-nil."
279      :group   'diary
280      :type    'sexp
281      :version "21.4")
282    
283  (defun list-diary-entries (date number)  (defun list-diary-entries (date number)
284    "Create and display a buffer containing the relevant lines in diary-file.    "Create and display a buffer containing the relevant lines in diary-file.
# Line 296  These hooks have the following distinct Line 315  These hooks have the following distinct
315          notification function."          notification function."
316    
317    (if (< 0 number)    (if (< 0 number)
318        (let* ((original-date date);; save for possible use in the hooks        (let ((original-date date);; save for possible use in the hooks
319               old-diary-syntax-table              old-diary-syntax-table
320               diary-entries-list              diary-entries-list
321               file-glob-attrs              file-glob-attrs
322               (date-string (calendar-date-string date))              (date-string (calendar-date-string date))
323               (d-file (substitute-in-file-name diary-file)))              (d-file (substitute-in-file-name diary-file)))
324          (message "Preparing diary...")          (message "Preparing diary...")
325          (save-excursion          (save-excursion
326            (let ((diary-buffer (find-buffer-visiting d-file)))            (let ((diary-buffer (find-buffer-visiting d-file)))
# Line 313  These hooks have the following distinct Line 332  These hooks have the following distinct
332            (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))            (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
333            (setq selective-display t)            (setq selective-display t)
334            (setq selective-display-ellipses nil)            (setq selective-display-ellipses nil)
335              (if diary-header-line-flag
336                  (setq header-line-format diary-header-line-format))
337            (setq old-diary-syntax-table (syntax-table))            (setq old-diary-syntax-table (syntax-table))
338            (set-syntax-table diary-syntax-table)            (set-syntax-table diary-syntax-table)
339            (unwind-protect            (unwind-protect
# Line 343  These hooks have the following distinct Line 364  These hooks have the following distinct
364                                          (car d)))                                          (car d)))
365                            (backup (equal (car (car d)) 'backup))                            (backup (equal (car (car d)) 'backup))
366                            (dayname                            (dayname
367                             (concat                             (format "%s\\|%s\\.?"
368                              (calendar-day-name date) "\\|"                              (calendar-day-name date)
369                              (substring (calendar-day-name date) 0 3) ".?"))                              (calendar-day-name date 'abbrev)))
370                            (monthname                            (monthname
371                             (concat                             (format "\\*\\|%s\\|%s\\.?"
372                              "\\*\\|"                              (calendar-month-name month)
373                              (calendar-month-name month) "\\|"                              (calendar-month-name month 'abbrev)))
                             (substring (calendar-month-name month) 0 3) ".?"))  
374                            (month (concat "\\*\\|0*" (int-to-string month)))                            (month (concat "\\*\\|0*" (int-to-string month)))
375                            (day (concat "\\*\\|0*" (int-to-string day)))                            (day (concat "\\*\\|0*" (int-to-string day)))
376                            (year                            (year
# Line 377  These hooks have the following distinct Line 397  These hooks have the following distinct
397                             ;; add it to the list.                             ;; add it to the list.
398                             (setq entry-found t)                             (setq entry-found t)
399                             (let ((entry-start (point))                             (let ((entry-start (point))
400                                   (date-start))                                   date-start temp)
401                               (re-search-backward "\^M\\|\n\\|\\`")                               (re-search-backward "\^M\\|\n\\|\\`")
402                               (setq date-start (point))                               (setq date-start (point))
403                               (re-search-forward "\^M\\|\n" nil t 2)                               (re-search-forward "\^M\\|\n" nil t 2)
# Line 388  These hooks have the following distinct Line 408  These hooks have the following distinct
408                                  (point) ?\^M ?\n t)                                  (point) ?\^M ?\n t)
409                               (setq entry (buffer-substring entry-start (point))                               (setq entry (buffer-substring entry-start (point))
410                                     temp (diary-pull-attrs entry file-glob-attrs)                                     temp (diary-pull-attrs entry file-glob-attrs)
411                                     entry (nth 0 temp)                                     entry (nth 0 temp))
                                    marks (nth 1 temp))  
412                               (add-to-diary-list                               (add-to-diary-list
413                                date                                date
414                                entry                                entry
415                                (buffer-substring                                (buffer-substring
416                                 (1+ date-start) (1- entry-start))                                 (1+ date-start) (1- entry-start))
417                                (copy-marker entry-start) marks)))))                                (copy-marker entry-start) (nth 1 temp))))))
418                       (setq d (cdr d)))                       (setq d (cdr d)))
419                     (or entry-found                     (or entry-found
420                         (not diary-list-include-blanks)                         (not diary-list-include-blanks)
# Line 469  changing the variable `diary-include-str Line 488  changing the variable `diary-include-str
488    "Display the diary buffer if there are any relevant entries or holidays."    "Display the diary buffer if there are any relevant entries or holidays."
489    (let* ((holiday-list (if holidays-in-diary-buffer    (let* ((holiday-list (if holidays-in-diary-buffer
490                             (check-calendar-holidays original-date)))                             (check-calendar-holidays original-date)))
491           (msg (format "No diary entries for %s %s"           (hol-string (format "%s%s%s"
492                        (concat date-string (if holiday-list ":" ""))                               date-string
493                        (mapconcat 'identity holiday-list "; "))))                               (if holiday-list ": " "")
494      (calendar-set-mode-line                               (mapconcat 'identity holiday-list "; ")))
495       (concat "Diary for " date-string           (msg (format "No diary entries for %s" hol-string))
496               (if holiday-list ": " "")           ;; If selected window is dedicated (to the calendar),
497               (mapconcat 'identity holiday-list "; ")))           ;; need a new one to display the diary.
498             (pop-up-frames (window-dedicated-p (selected-window))))
499        (calendar-set-mode-line (format "Diary for %s" hol-string))
500      (if (or (not diary-entries-list)      (if (or (not diary-entries-list)
501              (and (not (cdr diary-entries-list))              (and (not (cdr diary-entries-list))
502                   (string-equal (car (cdr (car diary-entries-list))) "")))                   (string-equal (car (cdr (car diary-entries-list))) "")))
503          (if (<= (length msg) (frame-width))          (if (< (length msg) (frame-width))
504              (message "%s" msg)              (message "%s" msg)
505            (set-buffer (get-buffer-create holiday-buffer))            (set-buffer (get-buffer-create holiday-buffer))
506            (setq buffer-read-only nil)            (setq buffer-read-only nil)
# Line 491  changing the variable `diary-include-str Line 512  changing the variable `diary-include-str
512            (setq buffer-read-only t)            (setq buffer-read-only t)
513            (display-buffer holiday-buffer)            (display-buffer holiday-buffer)
514            (message  "No diary entries for %s" date-string))            (message  "No diary entries for %s" date-string))
515        (display-buffer (find-buffer-visiting d-file))        (display-buffer (find-buffer-visiting
516                           (substitute-in-file-name diary-file)))
517        (message "Preparing diary...done"))))        (message "Preparing diary...done"))))
518    
519  (defface diary-button-face '((((type pc) (class color))  (defface diary-button-face '((((type pc) (class color))
# Line 604  This function is provided for optional u Line 626  This function is provided for optional u
626                                     :type 'diary-entry)                                     :type 'diary-entry)
627                    (insert entry ?\n))                    (insert entry ?\n))
628                  (save-excursion                  (save-excursion
629                    (setq marks (nth 4 (car entry-list)))                    (let* ((marks (nth 4 (car entry-list)))
630                    (setq temp-face (make-symbol (apply 'concat "temp-face-" (mapcar '(lambda (sym) (if (not (stringp sym)) (symbol-name sym) sym)) marks))))                           (temp-face (make-symbol
631                    (make-face temp-face)                                       (apply
632                    ;; Remove :face info from the marks, copy the face info into temp-face                                        'concat "temp-face-"
633                    (setq faceinfo marks)                                        (mapcar '(lambda (sym)
634                    (while (setq faceinfo (memq :face faceinfo))                                                   (if (stringp sym)
635                      (copy-face (read (nth 1 faceinfo)) temp-face)                                                       sym
636                      (setcar faceinfo nil)                                                     (symbol-name sym)))
637                      (setcar (cdr faceinfo) nil))                                                marks))))
638                    (setq marks (delq nil marks))                           faceinfo)
639                        ;; Remove :face info from the marks,
640                        ;; copy the face info into temp-face
641                        (setq faceinfo marks)
642                        (while (setq faceinfo (memq :face faceinfo))
643                          (copy-face (read (nth 1 faceinfo)) temp-face)
644                          (setcar faceinfo nil)
645                          (setcar (cdr faceinfo) nil))
646                        (setq marks (delq nil marks))
647                    ;; Apply the font aspects                    ;; Apply the font aspects
648                    (apply 'set-face-attribute temp-face nil marks)                      (apply 'set-face-attribute temp-face nil marks)
649                    (search-backward entry)                      (search-backward entry)
650                    (overlay-put                      (overlay-put
651                     (make-overlay (match-beginning 0) (match-end 0)) 'face temp-face))                       (make-overlay (match-beginning 0) (match-end 0))
652                  ))                       'face temp-face)))))
653            (setq entry-list (cdr entry-list))))            (setq entry-list (cdr entry-list))))
654        (set-buffer-modified-p nil)        (set-buffer-modified-p nil)
655        (goto-char (point-min))        (goto-char (point-min))
# Line 633  This function is provided for optional u Line 663  This function is provided for optional u
663    (save-excursion    (save-excursion
664      (set-buffer (get-buffer-create fancy-diary-buffer))      (set-buffer (get-buffer-create fancy-diary-buffer))
665      (setq buffer-read-only nil)      (setq buffer-read-only nil)
     (make-local-variable 'mode-line-format)  
666      (calendar-set-mode-line "Diary Entries")      (calendar-set-mode-line "Diary Entries")
667      (erase-buffer)      (erase-buffer)
668      (set-buffer-modified-p nil)      (set-buffer-modified-p nil)
# Line 686  This function gets rid of the selective Line 715  This function gets rid of the selective
715  all entries, not just some, are visible.  If there is no diary buffer, one  all entries, not just some, are visible.  If there is no diary buffer, one
716  is created."  is created."
717    (interactive)    (interactive)
718    (let ((d-file (substitute-in-file-name diary-file)))    (let ((d-file (diary-check-diary-file)))
719      (if (and d-file (file-exists-p d-file))      (save-excursion
720          (if (file-readable-p d-file)        (set-buffer (or (find-buffer-visiting d-file)
721              (save-excursion                        (find-file-noselect d-file t)))
722                (let ((diary-buffer (find-buffer-visiting d-file)))        (let ((buffer-read-only nil)
723                  (set-buffer (if diary-buffer              (diary-modified (buffer-modified-p)))
724                                  diary-buffer          (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
725                                (find-file-noselect d-file t)))          (setq selective-display nil
726                  (let ((buffer-read-only nil)                mode-line-format default-mode-line-format)
727                        (diary-modified (buffer-modified-p)))          (display-buffer (current-buffer))
728                    (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)          (set-buffer-modified-p diary-modified)))))
                   (setq selective-display nil)  
                   (make-local-variable 'mode-line-format)  
                   (setq mode-line-format default-mode-line-format)  
                   (display-buffer (current-buffer))  
                   (set-buffer-modified-p diary-modified))))  
           (error "Your diary file is not readable!"))  
       (error "You don't have a diary file!"))))  
   
   
729    
730  (defcustom diary-mail-addr  (defcustom diary-mail-addr
731    (if (boundp 'user-mail-address) user-mail-address nil)    (if (boundp 'user-mail-address) user-mail-address "")
732    "*Email address that `diary-mail-entries' will send email to."    "*Email address that `diary-mail-entries' will send email to."
733    :group 'diary    :group 'diary
734    :type '(choice string (const nil))    :type  'string
735    :version "20.3")    :version "20.3")
736    
737  (defcustom diary-mail-days 7  (defcustom diary-mail-days 7
738    "*Number of days for `diary-mail-entries' to check."    "*Default number of days for `diary-mail-entries' to check."
739    :group 'diary    :group 'diary
740    :type 'integer    :type 'integer
741    :version "20.3")    :version "20.3")
# Line 724  is created." Line 744  is created."
744  (defun diary-mail-entries (&optional ndays)  (defun diary-mail-entries (&optional ndays)
745    "Send a mail message showing diary entries for next NDAYS days.    "Send a mail message showing diary entries for next NDAYS days.
746  If no prefix argument is given, NDAYS is set to `diary-mail-days'.  If no prefix argument is given, NDAYS is set to `diary-mail-days'.
747    Mail is sent to the address specified by `diary-mail-addr'.
748    
749  You can call `diary-mail-entries' every night using an at/cron job.  You can call `diary-mail-entries' every night using an at/cron job.
750  For example, this script will run the program at 2am daily.  Since  For example, this script will run the program at 2am daily.  Since
# Line 734  all relevant variables are set, as done Line 755  all relevant variables are set, as done
755  # diary-rem.sh -- repeatedly run the Emacs diary-reminder  # diary-rem.sh -- repeatedly run the Emacs diary-reminder
756  emacs -batch \\  emacs -batch \\
757  -eval \"(setq diary-mail-days 3 \\  -eval \"(setq diary-mail-days 3 \\
758                 diary-file \\\"/path/to/diary.file\\\" \\
759               european-calendar-style t \\               european-calendar-style t \\
760               diary-mail-addr \\\"user@host.name\\\" )\" \\               diary-mail-addr \\\"user@host.name\\\" )\" \\
761  -l diary-lib -f diary-mail-entries  -l diary-lib -f diary-mail-entries
# Line 744  system.  Alternatively, you can specify Line 766  system.  Alternatively, you can specify
766  0 1 * * * diary-rem.sh  0 1 * * * diary-rem.sh
767  to run it every morning at 1am."  to run it every morning at 1am."
768    (interactive "P")    (interactive "P")
769    (let* ((diary-display-hook 'fancy-diary-display)    (if (string-equal diary-mail-addr "")
770           (text (progn (list-diary-entries (calendar-current-date)        (error "You must set `diary-mail-addr' to use this command")
771                                            (if ndays ndays diary-mail-days))      (let ((diary-display-hook 'fancy-diary-display))
772                        (set-buffer fancy-diary-buffer)        (list-diary-entries (calendar-current-date) (or ndays diary-mail-days)))
                       (buffer-substring (point-min) (point-max)))))  
773      (compose-mail diary-mail-addr      (compose-mail diary-mail-addr
774                    (if (string-equal text "")                    (concat "Diary entries generated "
775                        "No entries found"                            (calendar-date-string (calendar-current-date))))
776                      (concat "Diary entries generated "      (insert
777                              (calendar-date-string (calendar-current-date)))))       (if (get-buffer fancy-diary-buffer)
778      (insert text)           (save-excursion
779      (funcall (get mail-user-agent 'sendfunc))))             (set-buffer fancy-diary-buffer)
780               (buffer-substring (point-min) (point-max)))
781           "No entries found"))
782  (defun diary-name-pattern (string-array &optional fullname)      (call-interactively (get mail-user-agent 'sendfunc))))
783    "Convert a STRING-ARRAY, an array of strings to a pattern.  
784  The pattern will match any of the strings, either entirely or abbreviated  (defun diary-name-pattern (string-array &optional abbrev-array paren)
785  to three characters.  An abbreviated form will match with or without a period;    "Return a regexp matching the strings in the array STRING-ARRAY.
786  If the optional FULLNAME is t, abbreviations will not match, just the full  If the optional argument ABBREV-ARRAY is present, then the function
787  name."  `calendar-abbrev-construct' is used to construct abbreviations from the
788    (let ((pattern ""))  two supplied arrays. The returned regexp will then also match these
789      (calendar-for-loop i from 0 to (1- (length string-array)) do  abbreviations, with or without final `.' characters.  If the optional
790        (setq pattern  argument PAREN is non-nil, the regexp is surrounded by parentheses."
791              (concat    (regexp-opt (append string-array
792               pattern                        (if abbrev-array
793               (if (string-equal pattern "") "" "\\|")                            (calendar-abbrev-construct abbrev-array
794               (aref string-array i)                                                       string-array))
795               (if fullname                        (if abbrev-array
796                   ""                            (calendar-abbrev-construct abbrev-array
797                 (concat                                                       string-array
798                  "\\|"                                                       'period))
799                  (substring (aref string-array i) 0 3) ".?")))))                        nil)
800      pattern))                paren))
801    
802  (defvar marking-diary-entries nil  (defvar marking-diary-entries nil
803    "True during the marking of diary entries, nil otherwise.")    "True during the marking of diary entries, nil otherwise.")
# Line 791  After the entries are marked, the hooks Line 812  After the entries are marked, the hooks
812  `mark-diary-entries-hook' are run."  `mark-diary-entries-hook' are run."
813    (interactive)    (interactive)
814    (setq mark-diary-entries-in-calendar t)    (setq mark-diary-entries-in-calendar t)
815    (let (file-glob-attrs    (let ((marking-diary-entries t)
816          marks          file-glob-attrs marks)
817          (d-file (substitute-in-file-name diary-file))      (save-excursion
818          (marking-diary-entries t))        (set-buffer (find-file-noselect (diary-check-diary-file) t))
819      (if (and d-file (file-exists-p d-file))        (message "Marking diary entries...")
820          (if (file-readable-p d-file)        (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
821              (save-excursion        (let ((d diary-date-forms)
822                (message "Marking diary entries...")              (old-diary-syntax-table (syntax-table))
823                (set-buffer (find-file-noselect d-file t))              temp)
824                (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))          (set-syntax-table diary-syntax-table)
825                (let ((d diary-date-forms)          (while d
826                      (old-diary-syntax-table))            (let* ((date-form (if (equal (car (car d)) 'backup)
827                  (setq old-diary-syntax-table (syntax-table))                                  (cdr (car d))
828                  (set-syntax-table diary-syntax-table)                                (car d)));; ignore 'backup directive
829                  (while d                   (dayname
830                    (let*                    (diary-name-pattern calendar-day-name-array
831                        ((date-form (if (equal (car (car d)) 'backup)                                        calendar-day-abbrev-array))
832                                        (cdr (car d))                   (monthname
833                                      (car d)));; ignore 'backup directive                    (format "%s\\|\\*"
834                         (dayname (diary-name-pattern calendar-day-name-array))                     (diary-name-pattern calendar-month-name-array
835                         (monthname                                         calendar-month-abbrev-array)))
836                          (concat                   (month "[0-9]+\\|\\*")
837                           (diary-name-pattern calendar-month-name-array)                   (day "[0-9]+\\|\\*")
838                           "\\|\\*"))                   (year "[0-9]+\\|\\*")
839                         (month "[0-9]+\\|\\*")                   (l (length date-form))
840                         (day "[0-9]+\\|\\*")                   (d-name-pos (- l (length (memq 'dayname date-form))))
841                         (year "[0-9]+\\|\\*")                   (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
842                         (l (length date-form))                   (m-name-pos (- l (length (memq 'monthname date-form))))
843                         (d-name-pos (- l (length (memq 'dayname date-form))))                   (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
844                         (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))                   (d-pos (- l (length (memq 'day date-form))))
845                         (m-name-pos (- l (length (memq 'monthname date-form))))                   (d-pos (if (/= l d-pos) (+ 2 d-pos)))
846                         (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))                   (m-pos (- l (length (memq 'month date-form))))
847                         (d-pos (- l (length (memq 'day date-form))))                   (m-pos (if (/= l m-pos) (+ 2 m-pos)))
848                         (d-pos (if (/= l d-pos) (+ 2 d-pos)))                   (y-pos (- l (length (memq 'year date-form))))
849                         (m-pos (- l (length (memq 'month date-form))))                   (y-pos (if (/= l y-pos) (+ 2 y-pos)))
850                         (m-pos (if (/= l m-pos) (+ 2 m-pos)))                   (regexp
851                         (y-pos (- l (length (memq 'year date-form))))                    (concat
852                         (y-pos (if (/= l y-pos) (+ 2 y-pos)))                     "\\(\\`\\|\^M\\|\n\\)\\("
853                         (regexp                     (mapconcat 'eval date-form "\\)\\(")
854                          (concat                     "\\)"))
855                           "\\(\\`\\|\^M\\|\n\\)\\("                   (case-fold-search t))
856                           (mapconcat 'eval date-form "\\)\\(")              (goto-char (point-min))
857                           "\\)"))              (while (re-search-forward regexp nil t)
858                         (case-fold-search t))                (let* ((dd-name
859                      (goto-char (point-min))                        (if d-name-pos
860                      (while (re-search-forward regexp nil t)                            (buffer-substring-no-properties
861                        (let* ((dd-name                             (match-beginning d-name-pos)
862                                (if d-name-pos                             (match-end d-name-pos))))
863                                    (buffer-substring-no-properties                       (mm-name
864                                     (match-beginning d-name-pos)                        (if m-name-pos
865                                     (match-end d-name-pos))))                            (buffer-substring-no-properties
866                               (mm-name                             (match-beginning m-name-pos)
867                                (if m-name-pos                             (match-end m-name-pos))))
868                                    (buffer-substring-no-properties                       (mm (string-to-int
869                                     (match-beginning m-name-pos)                            (if m-pos
870                                     (match-end m-name-pos))))                                (buffer-substring-no-properties
871                               (mm (string-to-int                                 (match-beginning m-pos)
872                                    (if m-pos                                 (match-end m-pos))
873                                        (buffer-substring-no-properties                              "")))
874                                         (match-beginning m-pos)                       (dd (string-to-int
875                                         (match-end m-pos))                            (if d-pos
876                                      "")))                                (buffer-substring-no-properties
877                               (dd (string-to-int                                 (match-beginning d-pos)
878                                    (if d-pos                                 (match-end d-pos))
879                                        (buffer-substring-no-properties                              "")))
880                                         (match-beginning d-pos)                       (y-str (if y-pos
881                                         (match-end d-pos))                                  (buffer-substring-no-properties
882                                      "")))                                   (match-beginning y-pos)
883                               (y-str (if y-pos                                   (match-end y-pos))))
884                                          (buffer-substring-no-properties                       (yy (if (not y-str)
885                                           (match-beginning y-pos)                               0
886                                           (match-end y-pos))))                             (if (and (= (length y-str) 2)
887                               (yy (if (not y-str)                                      abbreviated-calendar-year)
888                                       0                                 (let* ((current-y
889                                     (if (and (= (length y-str) 2)                                         (extract-calendar-year
890                                              abbreviated-calendar-year)                                          (calendar-current-date)))
891                                         (let* ((current-y                                        (y (+ (string-to-int y-str)
892                                                 (extract-calendar-year                                              (* 100
893                                                  (calendar-current-date)))                                                 (/ current-y 100)))))
894                                                (y (+ (string-to-int y-str)                                   (if (> (- y current-y) 50)
895                                                      (* 100                                       (- y 100)
896                                                         (/ current-y 100)))))                                     (if (> (- current-y y) 50)
897                                           (if (> (- y current-y) 50)                                         (+ y 100)
898                                               (- y 100)                                       y)))
899                                             (if (> (- current-y y) 50)                               (string-to-int y-str))))
900                                                 (+ y 100)                       (save-excursion
901                                               y)))                         (setq entry (buffer-substring-no-properties
902                                       (string-to-int y-str))))                                      (point) (line-end-position))
903                               (save-excursion                               temp (diary-pull-attrs entry file-glob-attrs)
904                                 (setq entry (buffer-substring-no-properties (point) (line-end-position))                               entry (nth 0 temp)
905                                       temp (diary-pull-attrs entry file-glob-attrs)                               marks (nth 1 temp))))
906                                       entry (nth 0 temp)                  (if dd-name
907                                       marks (nth 1 temp))))                      (mark-calendar-days-named
908                          (if dd-name                       (cdr (assoc-ignore-case
909                              (mark-calendar-days-named                             dd-name
910                               (cdr (assoc-ignore-case                             (calendar-make-alist
911                                     (substring dd-name 0 3)                              calendar-day-name-array
912                                     (calendar-make-alist                              0 nil calendar-day-abbrev-array))) marks)
913                                      calendar-day-name-array                    (if mm-name
914                                      0                        (setq mm
915                                      (lambda (x) (substring x 0 3))))) marks)                              (if (string-equal mm-name "*") 0
916                            (if mm-name                                (cdr (assoc-ignore-case
917                                (if (string-equal mm-name "*")                                      mm-name
918                                    (setq mm 0)                                      (calendar-make-alist
919                                  (setq mm                                       calendar-month-name-array
920                                        (cdr (assoc-ignore-case                                       1 nil calendar-month-abbrev-array))))))
921                                              (substring mm-name 0 3)                    (mark-calendar-date-pattern mm dd yy marks))))
922                                              (calendar-make-alist              (setq d (cdr d))))
923                                               calendar-month-name-array          (mark-sexp-diary-entries)
924                                               1          (run-hooks 'nongregorian-diary-marking-hook
925                                               (lambda (x) (substring x 0 3)))                     'mark-diary-entries-hook)
926                                              )))))          (set-syntax-table old-diary-syntax-table)
927                            (mark-calendar-date-pattern mm dd yy marks))))          (message "Marking diary entries...done")))))
                     (setq d (cdr d))))  
                 (mark-sexp-diary-entries)  
                 (run-hooks 'nongregorian-diary-marking-hook  
                            'mark-diary-entries-hook)  
                 (set-syntax-table old-diary-syntax-table)  
                 (message "Marking diary entries...done")))  
           (error "Your diary file is not readable!"))  
       (error "You don't have a diary file!"))))  
928    
929  (defun mark-sexp-diary-entries ()  (defun mark-sexp-diary-entries ()
930    "Mark days in the calendar window that have sexp diary entries.    "Mark days in the calendar window that have sexp diary entries.
# Line 919  Each entry in the diary file (or include Line 932  Each entry in the diary file (or include
932  is marked.  See the documentation for the function `list-sexp-diary-entries'."  is marked.  See the documentation for the function `list-sexp-diary-entries'."
933    (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))    (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
934           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("
935                            (regexp-quote sexp-mark) "(\\)\\|\\("                            sexp-mark "(\\)\\|\\("
936                            (regexp-quote diary-nonmarking-symbol)                            (regexp-quote diary-nonmarking-symbol)
937                            (regexp-quote sexp-mark) "(diary-remind\\)"))                            sexp-mark "(diary-remind\\)"))
938           (m)           (file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
939           (y)           m y first-date last-date mark file-glob-attrs)
          (first-date)  
          (last-date)  
          (mark)  
          file-glob-attrs)  
     (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))  
940      (save-excursion      (save-excursion
941        (set-buffer calendar-buffer)        (set-buffer calendar-buffer)
942        (setq m displayed-month)        (setq m displayed-month)
# Line 942  is marked.  See the documentation for th Line 950  is marked.  See the documentation for th
950             (list m (calendar-last-day-of-month m y) y)))             (list m (calendar-last-day-of-month m y) y)))
951      (goto-char (point-min))      (goto-char (point-min))
952      (while (re-search-forward s-entry nil t)      (while (re-search-forward s-entry nil t)
953        (if (char-equal (preceding-char) ?\()        (setq marking-diary-entry (char-equal (preceding-char) ?\())
           (setq marking-diary-entry t)  
         (setq marking-diary-entry nil))  
954        (re-search-backward "(")        (re-search-backward "(")
955        (let ((sexp-start (point))        (let ((sexp-start (point))
956              (sexp)              sexp entry entry-start line-start marks)
             (entry)  
             (entry-start)  
             (line-start))  
957          (forward-sexp)          (forward-sexp)
958          (setq sexp (buffer-substring-no-properties sexp-start (point)))          (setq sexp (buffer-substring-no-properties sexp-start (point)))
959          (save-excursion          (save-excursion
# Line 980  is marked.  See the documentation for th Line 983  is marked.  See the documentation for th
983                                  (calendar-gregorian-from-absolute date)))                                  (calendar-gregorian-from-absolute date)))
984                (progn                (progn
985                  (setq marks (diary-pull-attrs entry file-glob-attrs)                  (setq marks (diary-pull-attrs entry file-glob-attrs)
986                        temp (diary-pull-attrs entry file-glob-attrs)                        marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
                       marks (nth 1 temp))  
987                  (mark-visible-calendar-date                  (mark-visible-calendar-date
988                   (calendar-gregorian-from-absolute date)                   (calendar-gregorian-from-absolute date)
989                   (if (< 0 (length marks))                   (if (< 0 (length marks))
990                       marks                       marks
991                     (if (consp mark)                     (if (consp mark)
# Line 1284  A number of built-in functions are avail Line 1286  A number of built-in functions are avail
1286    
1287  Marking these entries is *extremely* time consuming, so these entries are  Marking these entries is *extremely* time consuming, so these entries are
1288  best if they are nonmarking."  best if they are nonmarking."
1289    (let* ((mark (regexp-quote diary-nonmarking-symbol))    (let ((s-entry (concat "\\(\\`\\|\^M\\|\n\\)"
1290           (sexp-mark (regexp-quote sexp-diary-entry-symbol))                           (regexp-quote diary-nonmarking-symbol)
1291           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))                           "?"
1292           (entry-found)                           (regexp-quote sexp-diary-entry-symbol)
1293           (file-glob-attrs)                           "("))
1294           (marks))          entry-found file-glob-attrs marks)
1295      (goto-char (point-min))      (goto-char (point-min))
1296      (save-excursion      (save-excursion
1297        (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))        (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))
1298      (while (re-search-forward s-entry nil t)      (while (re-search-forward s-entry nil t)
1299        (backward-char 1)        (backward-char 1)
1300        (let ((sexp-start (point))        (let ((sexp-start (point))
1301              (sexp)              sexp entry specifier entry-start line-start)
             (entry)  
             (specifier)  
             (entry-start)  
             (line-start))  
1302          (forward-sexp)          (forward-sexp)
1303          (setq sexp (buffer-substring-no-properties sexp-start (point)))          (setq sexp (buffer-substring-no-properties sexp-start (point)))
1304          (save-excursion          (save-excursion
# Line 1324  best if they are nonmarking." Line 1322  best if they are nonmarking."
1322            (setq entry (buffer-substring-no-properties entry-start (point)))            (setq entry (buffer-substring-no-properties entry-start (point)))
1323            (while (string-match "[\^M]" entry)            (while (string-match "[\^M]" entry)
1324              (aset entry (match-beginning 0) ?\n )))              (aset entry (match-beginning 0) ?\n )))
1325          (let ((diary-entry (diary-sexp-entry sexp entry date)))          (let ((diary-entry (diary-sexp-entry sexp entry date))
1326                  temp)
1327            (setq entry (if (consp diary-entry)            (setq entry (if (consp diary-entry)
1328                            (cdr diary-entry)                            (cdr diary-entry)
1329                          diary-entry))                          diary-entry))
# Line 1339  best if they are nonmarking." Line 1338  best if they are nonmarking."
1338                               entry                               entry
1339                               specifier                               specifier
1340                               (if entry-start (copy-marker entry-start)                               (if entry-start (copy-marker entry-start)
1341                                 nil)                                 nil)
1342                               marks)                               marks)
1343            (setq entry-found (or entry-found diary-entry)))))            (setq entry-found (or entry-found diary-entry)))))
1344      entry-found))      entry-found))
# Line 1379  all values. Line 1378  all values.
1378    
1379  An optional parameter MARK specifies a face or single-character string to  An optional parameter MARK specifies a face or single-character string to
1380  use when highlighting the day in the calendar."  use when highlighting the day in the calendar."
1381    (let* ((dd (if european-calendar-style    (let ((dd (if european-calendar-style
1382                  month                  month
1383                day))                day))
1384           (mm (if european-calendar-style          (mm (if european-calendar-style
1385                  day                  day
1386                month))                month))
1387           (m (extract-calendar-month date))          (m (extract-calendar-month date))
1388           (y (extract-calendar-year date))          (y (extract-calendar-year date))
1389           (d (extract-calendar-day date)))          (d (extract-calendar-day date)))
1390      (if (and      (if (and
1391           (or (and (listp dd) (memq d dd))           (or (and (listp dd) (memq d dd))
1392               (equal d dd)               (equal d dd)
# Line 1601  marked on the calendar." Line 1600  marked on the calendar."
1600  (defun add-to-diary-list (date string specifier marker &optional globcolor)  (defun add-to-diary-list (date string specifier marker &optional globcolor)
1601    "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'.    "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'.
1602  Do nothing if DATE or STRING is nil."  Do nothing if DATE or STRING is nil."
1603    (and date string    (when (and date string)
1604         (if (and diary-file-name-prefix      (if diary-file-name-prefix
1605                  (setq prefix (concat "[" (funcall diary-file-name-prefix-function (buffer-file-name)) "] "))          (let ((prefix (funcall diary-file-name-prefix-function
1606                  (not (string= prefix "[] ")))                                 (buffer-file-name))))
1607             (setq string (concat prefix string))            (or (string= prefix "")
1608           t)                (setq string (format "[%s] %s" prefix string)))))
1609         (setq diary-entries-list      (setq diary-entries-list
1610               (append diary-entries-list            (append diary-entries-list
1611                       (list (list date string specifier marker globcolor))))))                    (list (list date string specifier marker globcolor))))))
1612    
1613  (defun make-diary-entry (string &optional nonmarking file)  (defun make-diary-entry (string &optional nonmarking file)
1614    "Insert a diary entry STRING which may be NONMARKING in FILE.    "Insert a diary entry STRING which may be NONMARKING in FILE.
1615  If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."  If omitted, NONMARKING defaults to nil and FILE defaults to `diary-file'."
1616    (find-file-other-window    (let ((pop-up-frames (window-dedicated-p (selected-window))))
1617     (substitute-in-file-name (if file file diary-file)))      (find-file-other-window (substitute-in-file-name (or file diary-file))))
1618    (widen)    (widen)
1619    (goto-char (point-max))    (goto-char (point-max))
1620    (when (let ((case-fold-search t))    (when (let ((case-fold-search t))
# Line 1648  Prefix arg will make the entry nonmarkin Line 1647  Prefix arg will make the entry nonmarkin
1647    "Insert a monthly diary entry for the day of the month indicated by point.    "Insert a monthly diary entry for the day of the month indicated by point.
1648  Prefix arg will make the entry nonmarking."  Prefix arg will make the entry nonmarking."
1649    (interactive "P")    (interactive "P")
1650    (let* ((calendar-date-display-form    (let ((calendar-date-display-form
1651            (if european-calendar-style           (if european-calendar-style
1652                '(day " * ")               '(day " * ")
1653              '("* " day))))             '("* " day))))
1654      (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)      (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1655                        arg)))                        arg)))
1656    
# Line 1659  Prefix arg will make the entry nonmarkin Line 1658  Prefix arg will make the entry nonmarkin
1658    "Insert an annual diary entry for the day of the year indicated by point.    "Insert an annual diary entry for the day of the year indicated by point.
1659  Prefix arg will make the entry nonmarking."  Prefix arg will make the entry nonmarking."
1660    (interactive "P")    (interactive "P")
1661    (let* ((calendar-date-display-form    (let ((calendar-date-display-form
1662            (if european-calendar-style           (if european-calendar-style
1663                '(day " " monthname)               '(day " " monthname)
1664              '(monthname " " day))))             '(monthname " " day))))
1665      (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)      (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1666                        arg)))                        arg)))
1667    
# Line 1670  Prefix arg will make the entry nonmarkin Line 1669  Prefix arg will make the entry nonmarkin
1669    "Insert an anniversary diary entry for the date given by point.    "Insert an anniversary diary entry for the date given by point.
1670  Prefix arg will make the entry nonmarking."  Prefix arg will make the entry nonmarking."
1671    (interactive "P")    (interactive "P")
1672    (let* ((calendar-date-display-form    (let ((calendar-date-display-form
1673            (if european-calendar-style           (if european-calendar-style
1674                '(day " " month " " year)               '(day " " month " " year)
1675              '(month " " day " " year))))             '(month " " day " " year))))
1676      (make-diary-entry      (make-diary-entry
1677       (format "%s(diary-anniversary %s)"       (format "%s(diary-anniversary %s)"
1678               sexp-diary-entry-symbol               sexp-diary-entry-symbol
# Line 1684  Prefix arg will make the entry nonmarkin Line 1683  Prefix arg will make the entry nonmarkin
1683    "Insert a block diary entry for the days between the point and marked date.    "Insert a block diary entry for the days between the point and marked date.
1684  Prefix arg will make the entry nonmarking."  Prefix arg will make the entry nonmarking."
1685    (interactive "P")    (interactive "P")
1686    (let* ((calendar-date-display-form    (let ((calendar-date-display-form
1687            (if european-calendar-style           (if european-calendar-style
1688                '(day " " month " " year)               '(day " " month " " year)
1689              '(month " " day " " year)))             '(month " " day " " year)))
1690           (cursor (calendar-cursor-to-date t))           (cursor (calendar-cursor-to-date t))
1691           (mark (or (car calendar-mark-ring)           (mark (or (car calendar-mark-ring)
1692                     (error "No mark set in this buffer")))                     (error "No mark set in this buffer")))
1693           (start)           start end)
          (end))  
1694      (if (< (calendar-absolute-from-gregorian mark)      (if (< (calendar-absolute-from-gregorian mark)
1695             (calendar-absolute-from-gregorian cursor))             (calendar-absolute-from-gregorian cursor))
1696          (setq start mark          (setq start mark
# Line 1710  Prefix arg will make the entry nonmarkin Line 1708  Prefix arg will make the entry nonmarkin
1708    "Insert a cyclic diary entry starting at the date given by point.    "Insert a cyclic diary entry starting at the date given by point.
1709  Prefix arg will make the entry nonmarking."  Prefix arg will make the entry nonmarking."
1710    (interactive "P")    (interactive "P")
1711    (let* ((calendar-date-display-form    (let ((calendar-date-display-form
1712            (if european-calendar-style           (if european-calendar-style
1713                '(day " " month " " year)               '(day " " month " " year)
1714              '(month " " day " " year))))             '(month " " day " " year))))
1715      (make-diary-entry      (make-diary-entry
1716       (format "%s(diary-cyclic %d %s)"       (format "%s(diary-cyclic %d %s)"
1717               sexp-diary-entry-symbol               sexp-diary-entry-symbol
# Line 1733  Prefix arg will make the entry nonmarkin Line 1731  Prefix arg will make the entry nonmarkin
1731    "Diary"    "Diary"
1732    "Major mode used while displaying diary entries using Fancy Display."    "Major mode used while displaying diary entries using Fancy Display."
1733    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
1734         '(fancy-diary-font-lock-keywords t)))         '(fancy-diary-font-lock-keywords t))
1735      (define-key (current-local-map) "q" 'quit-window))
1736    
1737    
1738  (defvar fancy-diary-font-lock-keywords  (defvar fancy-diary-font-lock-keywords
1739    (list    (list
1740     (cons     (cons
1741      (concat      (concat
1742       (let ((dayname       (let ((dayname (diary-name-pattern calendar-day-name-array nil t))
1743              (concat "\\("             (monthname (diary-name-pattern calendar-month-name-array nil t))
                     (diary-name-pattern calendar-day-name-array t)  
                     "\\)"))  
            (monthname  
             (concat "\\("  
                     (diary-name-pattern calendar-month-name-array t)  
                     "\\)"))  
1744             (day "[0-9]+")             (day "[0-9]+")
1745             (month "[0-9]+")             (month "[0-9]+")
1746             (year "-?[0-9]+"))             (year "-?[0-9]+"))
# Line 1780  Prefix arg will make the entry nonmarkin Line 1773  Prefix arg will make the entry nonmarkin
1773                t))                t))
1774          (error t))))          (error t))))
1775    
1776  (defun font-lock-diary-date-forms (month-list &optional symbol noabbrev)  (defun font-lock-diary-date-forms (month-array &optional symbol abbrev-array)
1777    "Create a list of font-lock patterns for `diary-date-forms' with MONTH-LIST.    "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY.
1778  If given, optional SYMBOL must be a prefix to entries.  If given, optional SYMBOL must be a prefix to entries.
1779  If optional NOABBREV is t, do not allow abbreviations in names."  If optional ABBREV-ARRAY is present, the abbreviations constructed
1780    (let* ((dayname  from this array by the function `calendar-abbrev-construct' are
1781            (concat "\\(" (diary-name-pattern calendar-day-name-array) "\\)"))  matched (with or without a final `.'), in addition to the full month
1782           (monthname (concat "\\("  names."
1783                              (diary-name-pattern month-list noabbrev)    (let ((dayname (diary-name-pattern calendar-day-name-array
1784                              "\\|\\*\\)"))                                       calendar-day-abbrev-array t))
1785           (month "\\([0-9]+\\|\\*\\)")          (monthname (format "\\(%s\\|\\*\\)"
1786           (day "\\([0-9]+\\|\\*\\)")                             (diary-name-pattern month-array abbrev-array)))
1787           (year "-?\\([0-9]+\\|\\*\\)"))          (month "\\([0-9]+\\|\\*\\)")
1788            (day "\\([0-9]+\\|\\*\\)")
1789            (year "-?\\([0-9]+\\|\\*\\)"))
1790      (mapcar '(lambda (x)      (mapcar '(lambda (x)
1791                 (cons                 (cons
1792                  (concat "^" (regexp-quote diary-nonmarking-symbol) "?"                  (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
# Line 1810  If optional NOABBREV is t, do not allow Line 1805  If optional NOABBREV is t, do not allow
1805                  '(1 diary-face)))                  '(1 diary-face)))
1806              diary-date-forms)))              diary-date-forms)))
1807    
1808    (eval-when-compile (require 'cal-hebrew)
1809                       (require 'cal-islam))
1810    
1811  (defvar diary-font-lock-keywords  (defvar diary-font-lock-keywords
1812        (append        (append
1813         (font-lock-diary-date-forms calendar-month-name-array)         (font-lock-diary-date-forms calendar-month-name-array
1814         (if (or (memq 'mark-hebrew-diary-entries                                     nil calendar-month-abbrev-array)
1815                       nongregorian-diary-marking-hook)         (when (or (memq 'mark-hebrew-diary-entries
1816                 (memq 'list-hebrew-diary-entries                         nongregorian-diary-marking-hook)
1817                       nongregorian-diary-listing-hook))                   (memq 'list-hebrew-diary-entries
1818             (progn                         nongregorian-diary-listing-hook))
1819               (require 'cal-hebrew)           (require 'cal-hebrew)
1820               (font-lock-diary-date-forms           (font-lock-diary-date-forms
1821                calendar-hebrew-month-name-array-leap-year            calendar-hebrew-month-name-array-leap-year
1822                hebrew-diary-entry-symbol t)))            hebrew-diary-entry-symbol))
1823         (if (or (memq 'mark-islamic-diary-entries         (when (or (memq 'mark-islamic-diary-entries
1824                       nongregorian-diary-marking-hook)                         nongregorian-diary-marking-hook)
1825                 (memq 'list-islamic-diary-entries                   (memq 'list-islamic-diary-entries
1826                       nongregorian-diary-listing-hook))                         nongregorian-diary-listing-hook))
1827             (progn           (require 'cal-islam)
1828               (require 'cal-islamic)           (font-lock-diary-date-forms
1829               (font-lock-diary-date-forms            calendar-islamic-month-name-array
1830                calendar-islamic-month-name-array-leap-year            islamic-diary-entry-symbol))
               islamic-diary-entry-symbol t)))  
1831         (list         (list
1832          (cons          (cons
1833           (concat "^" (regexp-quote diary-include-string) ".*$")           (concat "^" (regexp-quote diary-include-string) ".*$")
# Line 1858  If optional NOABBREV is t, do not allow Line 1855  If optional NOABBREV is t, do not allow
1855    
1856  (provide 'diary-lib)  (provide 'diary-lib)
1857    
1858    ;;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
1859  ;;; diary-lib.el ends here  ;;; diary-lib.el ends here

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

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