aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGlenn Morris2003-06-22 01:02:22 +0000
committerGlenn Morris2003-06-22 01:02:22 +0000
commitc87a1f384ef6ba15559fffbce610c78768178a7a (patch)
tree76ccfc0ad965301fff6ef478e8b449b97b1a2e73
parentf4bbb3646abf65aa04d39a814d76367d65958397 (diff)
downloademacs-c87a1f384ef6ba15559fffbce610c78768178a7a.tar.gz
emacs-c87a1f384ef6ba15559fffbce610c78768178a7a.zip
(diary-check-diary-file): New function.
(diary, view-diary-entries, show-all-diary-entries) (mark-diary-entries): Use it. (view-other-diary-entries): Doc fix. Use `prefix-numeric-value'. (diary-syntax-table, diary-attrtype-convert, diary-mail-days): Doc fix. (diary-modified, d-file): No need to defvar (for compiler). (list-diary-entries): No need for `let*' so use `let'. (simple-diary-display): Use `diary-file' directly rather than inheriting `d-file' from `list-diary-entries' caller. (make-fancy-diary-buffer, show-all-diary-entries): `mode-line-format' already buffer-local. (diary-mail-addr): Set to the empty string (rather than nil) if undefined, as per `user-mail-address'. (diary-mail-entries): Doc fix. Error if `diary-mail-address' unset. (mark-sexp-diary-entries): Don't regexp-quote sexp-mark twice. Remove an un-needed `if'. (list-sexp-diary-entries): Remove local vars mark and s-entry, and use `let' rather than `let*'. (diary-date, insert-monthly-diary-entry) (insert-yearly-diary-entry, insert-anniversary-diary-entry) (insert-block-diary-entry, insert-cyclic-diary-entry) (font-lock-diary-date-forms): No need for `let*' so use `let'. (make-diary-entry): Doc fix. Use `or' rather than `if'. (diary-font-lock-keywords): Use `when'. `cal-islam' is required feature, not `cal-islamic'. `calendar-islamic-month-name-array-leap-year' does not exist - use `calendar-islamic-month-name-array'.
-rw-r--r--lisp/calendar/diary-lib.el518
1 files changed, 245 insertions, 273 deletions
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index 75a1fc16ac7..83f35c279b5 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -1,7 +1,7 @@
1;;; diary-lib.el --- diary functions 1;;; diary-lib.el --- diary functions
2 2
3;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software 3;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2003
4;; Foundation, Inc. 4;; Free Software Foundation, Inc.
5 5
6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> 6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7;; Keywords: calendar 7;; Keywords: calendar
@@ -38,6 +38,16 @@
38 38
39(require 'calendar) 39(require 'calendar)
40 40
41(defun diary-check-diary-file ()
42 "Check that the file specified by `diary-file' exists and is readable.
43If 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
41;;;###autoload 51;;;###autoload
42(defun diary (&optional arg) 52(defun diary (&optional arg)
43 "Generate the diary window for ARG days starting with the current date. 53 "Generate the diary window for ARG days starting with the current date.
@@ -45,19 +55,14 @@ If no argument is provided, the number of days of diary entries is governed
45by the variable `number-of-diary-entries'. This function is suitable for 55by the variable `number-of-diary-entries'. This function is suitable for
46execution in a `.emacs' file." 56execution in a `.emacs' file."
47 (interactive "P") 57 (interactive "P")
48 (let ((d-file (substitute-in-file-name diary-file)) 58 (diary-check-diary-file)
49 (date (calendar-current-date))) 59 (let ((date (calendar-current-date)))
50 (if (and d-file (file-exists-p d-file)) 60 (list-diary-entries
51 (if (file-readable-p d-file) 61 date
52 (list-diary-entries 62 (cond (arg (prefix-numeric-value arg))
53 date 63 ((vectorp number-of-diary-entries)
54 (cond 64 (aref number-of-diary-entries (calendar-day-of-week date)))
55 (arg (prefix-numeric-value arg)) 65 (t number-of-diary-entries)))))
56 ((vectorp number-of-diary-entries)
57 (aref number-of-diary-entries (calendar-day-of-week date)))
58 (t number-of-diary-entries)))
59 (error "Your diary file is not readable!"))
60 (error "You don't have a diary file!"))))
61 66
62(defun view-diary-entries (arg) 67(defun view-diary-entries (arg)
63 "Prepare and display a buffer with diary entries. 68 "Prepare and display a buffer with diary entries.
@@ -65,22 +70,16 @@ Searches the file named in `diary-file' for entries that
65match ARG days starting with the date indicated by the cursor position 70match ARG days starting with the date indicated by the cursor position
66in the displayed three-month calendar." 71in the displayed three-month calendar."
67 (interactive "p") 72 (interactive "p")
68 (let ((d-file (substitute-in-file-name diary-file))) 73 (diary-check-diary-file)
69 (if (and d-file (file-exists-p d-file)) 74 (list-diary-entries (calendar-cursor-to-date t) arg))
70 (if (file-readable-p d-file)
71 (list-diary-entries (calendar-cursor-to-date t) arg)
72 (error "Diary file is not readable!"))
73 (error "You don't have a diary file!"))))
74 75
75(defun view-other-diary-entries (arg d-file) 76(defun view-other-diary-entries (arg d-file)
76 "Prepare and display buffer of diary entries from an alternative diary file. 77 "Prepare and display buffer of diary entries from an alternative diary file.
77Prompts for a file name and searches that file for entries that match ARG 78Searches for entries that match ARG days, starting with the date indicated
78days starting with the date indicated by the cursor position in the displayed 79by the cursor position in the displayed three-month calendar.
79three-month calendar." 80D-FILE specifies the file to use as the diary file."
80 (interactive 81 (interactive
81 (list (cond ((null current-prefix-arg) 1) 82 (list (if arg (prefix-numeric-value arg) 1)
82 ((listp current-prefix-arg) (car current-prefix-arg))
83 (t current-prefix-arg))
84 (read-file-name "Enter diary file name: " default-directory nil t))) 83 (read-file-name "Enter diary file name: " default-directory nil t)))
85 (let ((diary-file d-file)) 84 (let ((diary-file d-file))
86 (view-diary-entries arg))) 85 (view-diary-entries arg)))
@@ -169,12 +168,11 @@ No diary entry if there is no sunset on that date.")
169(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) 168(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
170 "The syntax table used when parsing dates in the diary file. 169 "The syntax table used when parsing dates in the diary file.
171It is the standard syntax table used in Fundamental mode, but with the 170It is the standard syntax table used in Fundamental mode, but with the
172syntax of `*' changed to be a word constituent.") 171syntax of `*' and `:' changed to be word constituents.")
173 172
174(modify-syntax-entry ?* "w" diary-syntax-table) 173(modify-syntax-entry ?* "w" diary-syntax-table)
175(modify-syntax-entry ?: "w" diary-syntax-table) 174(modify-syntax-entry ?: "w" diary-syntax-table)
176 175
177(defvar diary-modified)
178(defvar diary-entries-list) 176(defvar diary-entries-list)
179(defvar displayed-year) 177(defvar displayed-year)
180(defvar displayed-month) 178(defvar displayed-month)
@@ -182,12 +180,11 @@ syntax of `*' changed to be a word constituent.")
182(defvar date) 180(defvar date)
183(defvar number) 181(defvar number)
184(defvar date-string) 182(defvar date-string)
185(defvar d-file)
186(defvar original-date) 183(defvar original-date)
187 184
188(defun diary-attrtype-convert (attrvalue type) 185(defun diary-attrtype-convert (attrvalue type)
189 "Convert the attrvalue from a string to the appropriate type for using 186 "Convert string ATTRVALUE to TYPE appropriate for a face description.
190in a face description" 187Valid TYPEs are: string, symbol, int, stringtnil, tnil."
191 (let (ret) 188 (let (ret)
192 (setq ret (cond ((eq type 'string) attrvalue) 189 (setq ret (cond ((eq type 'string) attrvalue)
193 ((eq type 'symbol) (read attrvalue)) 190 ((eq type 'symbol) (read attrvalue))
@@ -297,12 +294,12 @@ These hooks have the following distinct roles:
297 notification function." 294 notification function."
298 295
299 (if (< 0 number) 296 (if (< 0 number)
300 (let* ((original-date date);; save for possible use in the hooks 297 (let ((original-date date);; save for possible use in the hooks
301 old-diary-syntax-table 298 old-diary-syntax-table
302 diary-entries-list 299 diary-entries-list
303 file-glob-attrs 300 file-glob-attrs
304 (date-string (calendar-date-string date)) 301 (date-string (calendar-date-string date))
305 (d-file (substitute-in-file-name diary-file))) 302 (d-file (substitute-in-file-name diary-file)))
306 (message "Preparing diary...") 303 (message "Preparing diary...")
307 (save-excursion 304 (save-excursion
308 (let ((diary-buffer (find-buffer-visiting d-file))) 305 (let ((diary-buffer (find-buffer-visiting d-file)))
@@ -491,7 +488,8 @@ changing the variable `diary-include-string'."
491 (setq buffer-read-only t) 488 (setq buffer-read-only t)
492 (display-buffer holiday-buffer) 489 (display-buffer holiday-buffer)
493 (message "No diary entries for %s" date-string)) 490 (message "No diary entries for %s" date-string))
494 (display-buffer (find-buffer-visiting d-file)) 491 (display-buffer (find-buffer-visiting
492 (substitute-in-file-name diary-file)))
495 (message "Preparing diary...done")))) 493 (message "Preparing diary...done"))))
496 494
497(defface diary-button-face '((((type pc) (class color)) 495(defface diary-button-face '((((type pc) (class color))
@@ -641,7 +639,6 @@ This function is provided for optional use as the `diary-display-hook'."
641 (save-excursion 639 (save-excursion
642 (set-buffer (get-buffer-create fancy-diary-buffer)) 640 (set-buffer (get-buffer-create fancy-diary-buffer))
643 (setq buffer-read-only nil) 641 (setq buffer-read-only nil)
644 (make-local-variable 'mode-line-format)
645 (calendar-set-mode-line "Diary Entries") 642 (calendar-set-mode-line "Diary Entries")
646 (erase-buffer) 643 (erase-buffer)
647 (set-buffer-modified-p nil) 644 (set-buffer-modified-p nil)
@@ -694,36 +691,27 @@ This function gets rid of the selective display of the diary file so that
694all entries, not just some, are visible. If there is no diary buffer, one 691all entries, not just some, are visible. If there is no diary buffer, one
695is created." 692is created."
696 (interactive) 693 (interactive)
697 (let ((d-file (substitute-in-file-name diary-file))) 694 (let ((d-file (diary-check-diary-file)))
698 (if (and d-file (file-exists-p d-file)) 695 (save-excursion
699 (if (file-readable-p d-file) 696 (set-buffer (or (find-buffer-visiting d-file)
700 (save-excursion 697 (find-file-noselect d-file t)))
701 (let ((diary-buffer (find-buffer-visiting d-file))) 698 (let ((buffer-read-only nil)
702 (set-buffer (if diary-buffer 699 (diary-modified (buffer-modified-p)))
703 diary-buffer 700 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
704 (find-file-noselect d-file t))) 701 (setq selective-display nil
705 (let ((buffer-read-only nil) 702 mode-line-format default-mode-line-format)
706 (diary-modified (buffer-modified-p))) 703 (display-buffer (current-buffer))
707 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) 704 (set-buffer-modified-p diary-modified)))))
708 (setq selective-display nil)
709 (make-local-variable 'mode-line-format)
710 (setq mode-line-format default-mode-line-format)
711 (display-buffer (current-buffer))
712 (set-buffer-modified-p diary-modified))))
713 (error "Your diary file is not readable!"))
714 (error "You don't have a diary file!"))))
715
716
717 705
718(defcustom diary-mail-addr 706(defcustom diary-mail-addr
719 (if (boundp 'user-mail-address) user-mail-address nil) 707 (if (boundp 'user-mail-address) user-mail-address "")
720 "*Email address that `diary-mail-entries' will send email to." 708 "*Email address that `diary-mail-entries' will send email to."
721 :group 'diary 709 :group 'diary
722 :type '(choice string (const nil)) 710 :type 'string
723 :version "20.3") 711 :version "20.3")
724 712
725(defcustom diary-mail-days 7 713(defcustom diary-mail-days 7
726 "*Number of days for `diary-mail-entries' to check." 714 "*Default number of days for `diary-mail-entries' to check."
727 :group 'diary 715 :group 'diary
728 :type 'integer 716 :type 'integer
729 :version "20.3") 717 :version "20.3")
@@ -732,6 +720,7 @@ is created."
732(defun diary-mail-entries (&optional ndays) 720(defun diary-mail-entries (&optional ndays)
733 "Send a mail message showing diary entries for next NDAYS days. 721 "Send a mail message showing diary entries for next NDAYS days.
734If no prefix argument is given, NDAYS is set to `diary-mail-days'. 722If no prefix argument is given, NDAYS is set to `diary-mail-days'.
723Mail is sent to the address specified by `diary-mail-addr'.
735 724
736You can call `diary-mail-entries' every night using an at/cron job. 725You can call `diary-mail-entries' every night using an at/cron job.
737For example, this script will run the program at 2am daily. Since 726For example, this script will run the program at 2am daily. Since
@@ -742,6 +731,7 @@ all relevant variables are set, as done here.
742# diary-rem.sh -- repeatedly run the Emacs diary-reminder 731# diary-rem.sh -- repeatedly run the Emacs diary-reminder
743emacs -batch \\ 732emacs -batch \\
744-eval \"(setq diary-mail-days 3 \\ 733-eval \"(setq diary-mail-days 3 \\
734 diary-file \\\"/path/to/diary.file\\\" \\
745 european-calendar-style t \\ 735 european-calendar-style t \\
746 diary-mail-addr \\\"user@host.name\\\" )\" \\ 736 diary-mail-addr \\\"user@host.name\\\" )\" \\
747-l diary-lib -f diary-mail-entries 737-l diary-lib -f diary-mail-entries
@@ -752,18 +742,20 @@ system. Alternatively, you can specify a cron entry:
7520 1 * * * diary-rem.sh 7420 1 * * * diary-rem.sh
753to run it every morning at 1am." 743to run it every morning at 1am."
754 (interactive "P") 744 (interactive "P")
755 (let ((diary-display-hook 'fancy-diary-display)) 745 (if (string-equal diary-mail-addr "")
756 (list-diary-entries (calendar-current-date) (or ndays diary-mail-days))) 746 (error "You must set `diary-mail-addr' to use this command")
757 (compose-mail diary-mail-addr 747 (let ((diary-display-hook 'fancy-diary-display))
758 (concat "Diary entries generated " 748 (list-diary-entries (calendar-current-date) (or ndays diary-mail-days)))
759 (calendar-date-string (calendar-current-date)))) 749 (compose-mail diary-mail-addr
760 (insert 750 (concat "Diary entries generated "
761 (if (get-buffer fancy-diary-buffer) 751 (calendar-date-string (calendar-current-date))))
762 (save-excursion 752 (insert
763 (set-buffer fancy-diary-buffer) 753 (if (get-buffer fancy-diary-buffer)
764 (buffer-substring (point-min) (point-max))) 754 (save-excursion
765 "No entries found")) 755 (set-buffer fancy-diary-buffer)
766 (call-interactively (get mail-user-agent 'sendfunc))) 756 (buffer-substring (point-min) (point-max)))
757 "No entries found"))
758 (call-interactively (get mail-user-agent 'sendfunc))))
767 759
768 760
769(defun diary-name-pattern (string-array &optional fullname) 761(defun diary-name-pattern (string-array &optional fullname)
@@ -799,127 +791,120 @@ After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
799`mark-diary-entries-hook' are run." 791`mark-diary-entries-hook' are run."
800 (interactive) 792 (interactive)
801 (setq mark-diary-entries-in-calendar t) 793 (setq mark-diary-entries-in-calendar t)
802 (let (file-glob-attrs 794 (let ((marking-diary-entries t)
803 marks 795 file-glob-attrs marks)
804 (d-file (substitute-in-file-name diary-file)) 796 (save-excursion
805 (marking-diary-entries t)) 797 (set-buffer (find-file-noselect (diary-check-diary-file) t))
806 (if (and d-file (file-exists-p d-file)) 798 (message "Marking diary entries...")
807 (if (file-readable-p d-file) 799 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
808 (save-excursion 800 (let ((d diary-date-forms)
809 (message "Marking diary entries...") 801 (old-diary-syntax-table (syntax-table))
810 (set-buffer (find-file-noselect d-file t)) 802 temp)
811 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) 803 (set-syntax-table diary-syntax-table)
812 (let ((d diary-date-forms) 804 (while d
813 (old-diary-syntax-table (syntax-table)) 805 (let* ((date-form (if (equal (car (car d)) 'backup)
814 temp) 806 (cdr (car d))
815 (set-syntax-table diary-syntax-table) 807 (car d)));; ignore 'backup directive
816 (while d 808 (dayname (diary-name-pattern calendar-day-name-array))
817 (let* 809 (monthname
818 ((date-form (if (equal (car (car d)) 'backup) 810 (concat
819 (cdr (car d)) 811 (diary-name-pattern calendar-month-name-array)
820 (car d)));; ignore 'backup directive 812 "\\|\\*"))
821 (dayname (diary-name-pattern calendar-day-name-array)) 813 (month "[0-9]+\\|\\*")
822 (monthname 814 (day "[0-9]+\\|\\*")
823 (concat 815 (year "[0-9]+\\|\\*")
824 (diary-name-pattern calendar-month-name-array) 816 (l (length date-form))
825 "\\|\\*")) 817 (d-name-pos (- l (length (memq 'dayname date-form))))
826 (month "[0-9]+\\|\\*") 818 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
827 (day "[0-9]+\\|\\*") 819 (m-name-pos (- l (length (memq 'monthname date-form))))
828 (year "[0-9]+\\|\\*") 820 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
829 (l (length date-form)) 821 (d-pos (- l (length (memq 'day date-form))))
830 (d-name-pos (- l (length (memq 'dayname date-form)))) 822 (d-pos (if (/= l d-pos) (+ 2 d-pos)))
831 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) 823 (m-pos (- l (length (memq 'month date-form))))
832 (m-name-pos (- l (length (memq 'monthname date-form)))) 824 (m-pos (if (/= l m-pos) (+ 2 m-pos)))
833 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) 825 (y-pos (- l (length (memq 'year date-form))))
834 (d-pos (- l (length (memq 'day date-form)))) 826 (y-pos (if (/= l y-pos) (+ 2 y-pos)))
835 (d-pos (if (/= l d-pos) (+ 2 d-pos))) 827 (regexp
836 (m-pos (- l (length (memq 'month date-form)))) 828 (concat
837 (m-pos (if (/= l m-pos) (+ 2 m-pos))) 829 "\\(\\`\\|\^M\\|\n\\)\\("
838 (y-pos (- l (length (memq 'year date-form)))) 830 (mapconcat 'eval date-form "\\)\\(")
839 (y-pos (if (/= l y-pos) (+ 2 y-pos))) 831 "\\)"))
840 (regexp 832 (case-fold-search t))
841 (concat 833 (goto-char (point-min))
842 "\\(\\`\\|\^M\\|\n\\)\\(" 834 (while (re-search-forward regexp nil t)
843 (mapconcat 'eval date-form "\\)\\(") 835 (let* ((dd-name
844 "\\)")) 836 (if d-name-pos
845 (case-fold-search t)) 837 (buffer-substring-no-properties
846 (goto-char (point-min)) 838 (match-beginning d-name-pos)
847 (while (re-search-forward regexp nil t) 839 (match-end d-name-pos))))
848 (let* ((dd-name 840 (mm-name
849 (if d-name-pos 841 (if m-name-pos
850 (buffer-substring-no-properties 842 (buffer-substring-no-properties
851 (match-beginning d-name-pos) 843 (match-beginning m-name-pos)
852 (match-end d-name-pos)))) 844 (match-end m-name-pos))))
853 (mm-name 845 (mm (string-to-int
854 (if m-name-pos 846 (if m-pos
855 (buffer-substring-no-properties 847 (buffer-substring-no-properties
856 (match-beginning m-name-pos) 848 (match-beginning m-pos)
857 (match-end m-name-pos)))) 849 (match-end m-pos))
858 (mm (string-to-int 850 "")))
859 (if m-pos 851 (dd (string-to-int
860 (buffer-substring-no-properties 852 (if d-pos
861 (match-beginning m-pos) 853 (buffer-substring-no-properties
862 (match-end m-pos)) 854 (match-beginning d-pos)
863 ""))) 855 (match-end d-pos))
864 (dd (string-to-int 856 "")))
865 (if d-pos 857 (y-str (if y-pos
866 (buffer-substring-no-properties 858 (buffer-substring-no-properties
867 (match-beginning d-pos) 859 (match-beginning y-pos)
868 (match-end d-pos)) 860 (match-end y-pos))))
869 ""))) 861 (yy (if (not y-str)
870 (y-str (if y-pos 862 0
871 (buffer-substring-no-properties 863 (if (and (= (length y-str) 2)
872 (match-beginning y-pos) 864 abbreviated-calendar-year)
873 (match-end y-pos)))) 865 (let* ((current-y
874 (yy (if (not y-str) 866 (extract-calendar-year
875 0 867 (calendar-current-date)))
876 (if (and (= (length y-str) 2) 868 (y (+ (string-to-int y-str)
877 abbreviated-calendar-year) 869 (* 100
878 (let* ((current-y 870 (/ current-y 100)))))
879 (extract-calendar-year 871 (if (> (- y current-y) 50)
880 (calendar-current-date))) 872 (- y 100)
881 (y (+ (string-to-int y-str) 873 (if (> (- current-y y) 50)
882 (* 100 874 (+ y 100)
883 (/ current-y 100))))) 875 y)))
884 (if (> (- y current-y) 50) 876 (string-to-int y-str))))
885 (- y 100) 877 (save-excursion
886 (if (> (- current-y y) 50) 878 (setq entry (buffer-substring-no-properties
887 (+ y 100) 879 (point) (line-end-position))
888 y))) 880 temp (diary-pull-attrs entry file-glob-attrs)
889 (string-to-int y-str)))) 881 entry (nth 0 temp)
890 (save-excursion 882 marks (nth 1 temp))))
891 (setq entry (buffer-substring-no-properties (point) (line-end-position)) 883 (if dd-name
892 temp (diary-pull-attrs entry file-glob-attrs) 884 (mark-calendar-days-named
893 entry (nth 0 temp) 885 (cdr (assoc-ignore-case
894 marks (nth 1 temp)))) 886 (substring dd-name 0 3)
895 (if dd-name 887 (calendar-make-alist
896 (mark-calendar-days-named 888 calendar-day-name-array
897 (cdr (assoc-ignore-case 889 0
898 (substring dd-name 0 3) 890 (lambda (x) (substring x 0 3))))) marks)
899 (calendar-make-alist 891 (if mm-name
900 calendar-day-name-array 892 (if (string-equal mm-name "*")
901 0 893 (setq mm 0)
902 (lambda (x) (substring x 0 3))))) marks) 894 (setq mm
903 (if mm-name 895 (cdr (assoc-ignore-case
904 (if (string-equal mm-name "*") 896 (substring mm-name 0 3)
905 (setq mm 0) 897 (calendar-make-alist
906 (setq mm 898 calendar-month-name-array
907 (cdr (assoc-ignore-case 899 1
908 (substring mm-name 0 3) 900 (lambda (x) (substring x 0 3))))))))
909 (calendar-make-alist 901 (mark-calendar-date-pattern mm dd yy marks))))
910 calendar-month-name-array 902 (setq d (cdr d))))
911 1 903 (mark-sexp-diary-entries)
912 (lambda (x) (substring x 0 3))) 904 (run-hooks 'nongregorian-diary-marking-hook
913 ))))) 905 'mark-diary-entries-hook)
914 (mark-calendar-date-pattern mm dd yy marks)))) 906 (set-syntax-table old-diary-syntax-table)
915 (setq d (cdr d)))) 907 (message "Marking diary entries...done")))))
916 (mark-sexp-diary-entries)
917 (run-hooks 'nongregorian-diary-marking-hook
918 'mark-diary-entries-hook)
919 (set-syntax-table old-diary-syntax-table)
920 (message "Marking diary entries...done")))
921 (error "Your diary file is not readable!"))
922 (error "You don't have a diary file!"))))
923 908
924(defun mark-sexp-diary-entries () 909(defun mark-sexp-diary-entries ()
925 "Mark days in the calendar window that have sexp diary entries. 910 "Mark days in the calendar window that have sexp diary entries.
@@ -927,16 +912,11 @@ Each entry in the diary file (or included files) visible in the calendar window
927is marked. See the documentation for the function `list-sexp-diary-entries'." 912is marked. See the documentation for the function `list-sexp-diary-entries'."
928 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) 913 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
929 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\(" 914 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("
930 (regexp-quote sexp-mark) "(\\)\\|\\(" 915 sexp-mark "(\\)\\|\\("
931 (regexp-quote diary-nonmarking-symbol) 916 (regexp-quote diary-nonmarking-symbol)
932 (regexp-quote sexp-mark) "(diary-remind\\)")) 917 sexp-mark "(diary-remind\\)"))
933 (m) 918 (file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
934 (y) 919 m y first-date last-date mark file-glob-attrs)
935 (first-date)
936 (last-date)
937 (mark)
938 file-glob-attrs)
939 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
940 (save-excursion 920 (save-excursion
941 (set-buffer calendar-buffer) 921 (set-buffer calendar-buffer)
942 (setq m displayed-month) 922 (setq m displayed-month)
@@ -950,9 +930,7 @@ is marked. See the documentation for the function `list-sexp-diary-entries'."
950 (list m (calendar-last-day-of-month m y) y))) 930 (list m (calendar-last-day-of-month m y) y)))
951 (goto-char (point-min)) 931 (goto-char (point-min))
952 (while (re-search-forward s-entry nil t) 932 (while (re-search-forward s-entry nil t)
953 (if (char-equal (preceding-char) ?\() 933 (setq marking-diary-entry (char-equal (preceding-char) ?\())
954 (setq marking-diary-entry t)
955 (setq marking-diary-entry nil))
956 (re-search-backward "(") 934 (re-search-backward "(")
957 (let ((sexp-start (point)) 935 (let ((sexp-start (point))
958 sexp entry entry-start line-start marks) 936 sexp entry entry-start line-start marks)
@@ -1288,21 +1266,19 @@ A number of built-in functions are available for this type of diary entry:
1288 1266
1289Marking these entries is *extremely* time consuming, so these entries are 1267Marking these entries is *extremely* time consuming, so these entries are
1290best if they are nonmarking." 1268best if they are nonmarking."
1291 (let* ((mark (regexp-quote diary-nonmarking-symbol)) 1269 (let ((s-entry (concat "\\(\\`\\|\^M\\|\n\\)"
1292 (sexp-mark (regexp-quote sexp-diary-entry-symbol)) 1270 (regexp-quote diary-nonmarking-symbol)
1293 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) 1271 "?"
1294 entry-found file-glob-attrs marks) 1272 (regexp-quote sexp-diary-entry-symbol)
1273 "("))
1274 entry-found file-glob-attrs marks)
1295 (goto-char (point-min)) 1275 (goto-char (point-min))
1296 (save-excursion 1276 (save-excursion
1297 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))) 1277 (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))))
1298 (while (re-search-forward s-entry nil t) 1278 (while (re-search-forward s-entry nil t)
1299 (backward-char 1) 1279 (backward-char 1)
1300 (let ((sexp-start (point)) 1280 (let ((sexp-start (point))
1301 (sexp) 1281 sexp entry specifier entry-start line-start)
1302 (entry)
1303 (specifier)
1304 (entry-start)
1305 (line-start))
1306 (forward-sexp) 1282 (forward-sexp)
1307 (setq sexp (buffer-substring-no-properties sexp-start (point))) 1283 (setq sexp (buffer-substring-no-properties sexp-start (point)))
1308 (save-excursion 1284 (save-excursion
@@ -1382,15 +1358,15 @@ all values.
1382 1358
1383An optional parameter MARK specifies a face or single-character string to 1359An optional parameter MARK specifies a face or single-character string to
1384use when highlighting the day in the calendar." 1360use when highlighting the day in the calendar."
1385 (let* ((dd (if european-calendar-style 1361 (let ((dd (if european-calendar-style
1386 month 1362 month
1387 day)) 1363 day))
1388 (mm (if european-calendar-style 1364 (mm (if european-calendar-style
1389 day 1365 day
1390 month)) 1366 month))
1391 (m (extract-calendar-month date)) 1367 (m (extract-calendar-month date))
1392 (y (extract-calendar-year date)) 1368 (y (extract-calendar-year date))
1393 (d (extract-calendar-day date))) 1369 (d (extract-calendar-day date)))
1394 (if (and 1370 (if (and
1395 (or (and (listp dd) (memq d dd)) 1371 (or (and (listp dd) (memq d dd))
1396 (equal d dd) 1372 (equal d dd)
@@ -1616,9 +1592,8 @@ Do nothing if DATE or STRING is nil."
1616 1592
1617(defun make-diary-entry (string &optional nonmarking file) 1593(defun make-diary-entry (string &optional nonmarking file)
1618 "Insert a diary entry STRING which may be NONMARKING in FILE. 1594 "Insert a diary entry STRING which may be NONMARKING in FILE.
1619If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." 1595If omitted, NONMARKING defaults to nil and FILE defaults to `diary-file'."
1620 (find-file-other-window 1596 (find-file-other-window (substitute-in-file-name (or file diary-file)))
1621 (substitute-in-file-name (if file file diary-file)))
1622 (widen) 1597 (widen)
1623 (goto-char (point-max)) 1598 (goto-char (point-max))
1624 (when (let ((case-fold-search t)) 1599 (when (let ((case-fold-search t))
@@ -1651,10 +1626,10 @@ Prefix arg will make the entry nonmarking."
1651 "Insert a monthly diary entry for the day of the month indicated by point. 1626 "Insert a monthly diary entry for the day of the month indicated by point.
1652Prefix arg will make the entry nonmarking." 1627Prefix arg will make the entry nonmarking."
1653 (interactive "P") 1628 (interactive "P")
1654 (let* ((calendar-date-display-form 1629 (let ((calendar-date-display-form
1655 (if european-calendar-style 1630 (if european-calendar-style
1656 '(day " * ") 1631 '(day " * ")
1657 '("* " day)))) 1632 '("* " day))))
1658 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) 1633 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1659 arg))) 1634 arg)))
1660 1635
@@ -1662,10 +1637,10 @@ Prefix arg will make the entry nonmarking."
1662 "Insert an annual diary entry for the day of the year indicated by point. 1637 "Insert an annual diary entry for the day of the year indicated by point.
1663Prefix arg will make the entry nonmarking." 1638Prefix arg will make the entry nonmarking."
1664 (interactive "P") 1639 (interactive "P")
1665 (let* ((calendar-date-display-form 1640 (let ((calendar-date-display-form
1666 (if european-calendar-style 1641 (if european-calendar-style
1667 '(day " " monthname) 1642 '(day " " monthname)
1668 '(monthname " " day)))) 1643 '(monthname " " day))))
1669 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) 1644 (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
1670 arg))) 1645 arg)))
1671 1646
@@ -1673,10 +1648,10 @@ Prefix arg will make the entry nonmarking."
1673 "Insert an anniversary diary entry for the date given by point. 1648 "Insert an anniversary diary entry for the date given by point.
1674Prefix arg will make the entry nonmarking." 1649Prefix arg will make the entry nonmarking."
1675 (interactive "P") 1650 (interactive "P")
1676 (let* ((calendar-date-display-form 1651 (let ((calendar-date-display-form
1677 (if european-calendar-style 1652 (if european-calendar-style
1678 '(day " " month " " year) 1653 '(day " " month " " year)
1679 '(month " " day " " year)))) 1654 '(month " " day " " year))))
1680 (make-diary-entry 1655 (make-diary-entry
1681 (format "%s(diary-anniversary %s)" 1656 (format "%s(diary-anniversary %s)"
1682 sexp-diary-entry-symbol 1657 sexp-diary-entry-symbol
@@ -1687,15 +1662,14 @@ Prefix arg will make the entry nonmarking."
1687 "Insert a block diary entry for the days between the point and marked date. 1662 "Insert a block diary entry for the days between the point and marked date.
1688Prefix arg will make the entry nonmarking." 1663Prefix arg will make the entry nonmarking."
1689 (interactive "P") 1664 (interactive "P")
1690 (let* ((calendar-date-display-form 1665 (let ((calendar-date-display-form
1691 (if european-calendar-style 1666 (if european-calendar-style
1692 '(day " " month " " year) 1667 '(day " " month " " year)
1693 '(month " " day " " year))) 1668 '(month " " day " " year)))
1694 (cursor (calendar-cursor-to-date t)) 1669 (cursor (calendar-cursor-to-date t))
1695 (mark (or (car calendar-mark-ring) 1670 (mark (or (car calendar-mark-ring)
1696 (error "No mark set in this buffer"))) 1671 (error "No mark set in this buffer")))
1697 (start) 1672 start end)
1698 (end))
1699 (if (< (calendar-absolute-from-gregorian mark) 1673 (if (< (calendar-absolute-from-gregorian mark)
1700 (calendar-absolute-from-gregorian cursor)) 1674 (calendar-absolute-from-gregorian cursor))
1701 (setq start mark 1675 (setq start mark
@@ -1713,10 +1687,10 @@ Prefix arg will make the entry nonmarking."
1713 "Insert a cyclic diary entry starting at the date given by point. 1687 "Insert a cyclic diary entry starting at the date given by point.
1714Prefix arg will make the entry nonmarking." 1688Prefix arg will make the entry nonmarking."
1715 (interactive "P") 1689 (interactive "P")
1716 (let* ((calendar-date-display-form 1690 (let ((calendar-date-display-form
1717 (if european-calendar-style 1691 (if european-calendar-style
1718 '(day " " month " " year) 1692 '(day " " month " " year)
1719 '(month " " day " " year)))) 1693 '(month " " day " " year))))
1720 (make-diary-entry 1694 (make-diary-entry
1721 (format "%s(diary-cyclic %d %s)" 1695 (format "%s(diary-cyclic %d %s)"
1722 sexp-diary-entry-symbol 1696 sexp-diary-entry-symbol
@@ -1788,14 +1762,14 @@ Prefix arg will make the entry nonmarking."
1788 "Create a list of font-lock patterns for `diary-date-forms' with MONTH-LIST. 1762 "Create a list of font-lock patterns for `diary-date-forms' with MONTH-LIST.
1789If given, optional SYMBOL must be a prefix to entries. 1763If given, optional SYMBOL must be a prefix to entries.
1790If optional NOABBREV is t, do not allow abbreviations in names." 1764If optional NOABBREV is t, do not allow abbreviations in names."
1791 (let* ((dayname 1765 (let ((dayname
1792 (concat "\\(" (diary-name-pattern calendar-day-name-array) "\\)")) 1766 (concat "\\(" (diary-name-pattern calendar-day-name-array) "\\)"))
1793 (monthname (concat "\\(" 1767 (monthname (concat "\\("
1794 (diary-name-pattern month-list noabbrev) 1768 (diary-name-pattern month-list noabbrev)
1795 "\\|\\*\\)")) 1769 "\\|\\*\\)"))
1796 (month "\\([0-9]+\\|\\*\\)") 1770 (month "\\([0-9]+\\|\\*\\)")
1797 (day "\\([0-9]+\\|\\*\\)") 1771 (day "\\([0-9]+\\|\\*\\)")
1798 (year "-?\\([0-9]+\\|\\*\\)")) 1772 (year "-?\\([0-9]+\\|\\*\\)"))
1799 (mapcar '(lambda (x) 1773 (mapcar '(lambda (x)
1800 (cons 1774 (cons
1801 (concat "^" (regexp-quote diary-nonmarking-symbol) "?" 1775 (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
@@ -1817,24 +1791,22 @@ If optional NOABBREV is t, do not allow abbreviations in names."
1817(defvar diary-font-lock-keywords 1791(defvar diary-font-lock-keywords
1818 (append 1792 (append
1819 (font-lock-diary-date-forms calendar-month-name-array) 1793 (font-lock-diary-date-forms calendar-month-name-array)
1820 (if (or (memq 'mark-hebrew-diary-entries 1794 (when (or (memq 'mark-hebrew-diary-entries
1821 nongregorian-diary-marking-hook) 1795 nongregorian-diary-marking-hook)
1822 (memq 'list-hebrew-diary-entries 1796 (memq 'list-hebrew-diary-entries
1823 nongregorian-diary-listing-hook)) 1797 nongregorian-diary-listing-hook))
1824 (progn 1798 (require 'cal-hebrew)
1825 (require 'cal-hebrew) 1799 (font-lock-diary-date-forms
1826 (font-lock-diary-date-forms 1800 calendar-hebrew-month-name-array-leap-year
1827 calendar-hebrew-month-name-array-leap-year 1801 hebrew-diary-entry-symbol t))
1828 hebrew-diary-entry-symbol t))) 1802 (when (or (memq 'mark-islamic-diary-entries
1829 (if (or (memq 'mark-islamic-diary-entries 1803 nongregorian-diary-marking-hook)
1830 nongregorian-diary-marking-hook) 1804 (memq 'list-islamic-diary-entries
1831 (memq 'list-islamic-diary-entries 1805 nongregorian-diary-listing-hook))
1832 nongregorian-diary-listing-hook)) 1806 (require 'cal-islam)
1833 (progn 1807 (font-lock-diary-date-forms
1834 (require 'cal-islamic) 1808 calendar-islamic-month-name-array
1835 (font-lock-diary-date-forms 1809 islamic-diary-entry-symbol t))
1836 calendar-islamic-month-name-array-leap-year
1837 islamic-diary-entry-symbol t)))
1838 (list 1810 (list
1839 (cons 1811 (cons
1840 (concat "^" (regexp-quote diary-include-string) ".*$") 1812 (concat "^" (regexp-quote diary-include-string) ".*$")