865 |
(let ((marking-diary-entries t) |
(let ((marking-diary-entries t) |
866 |
file-glob-attrs marks) |
file-glob-attrs marks) |
867 |
(with-current-buffer (find-file-noselect (diary-check-diary-file) t) |
(with-current-buffer (find-file-noselect (diary-check-diary-file) t) |
868 |
(setq mark-diary-entries-in-calendar t) |
(save-excursion |
869 |
(message "Marking diary entries...") |
(setq mark-diary-entries-in-calendar t) |
870 |
(setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) |
(message "Marking diary entries...") |
871 |
(let ((d diary-date-forms) |
(setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) |
872 |
(old-diary-syntax-table (syntax-table)) |
(with-syntax-table diary-syntax-table |
873 |
temp) |
(dolist (date-form diary-date-forms) |
874 |
(set-syntax-table diary-syntax-table) |
(if (eq (car date-form) 'backup) |
875 |
(while d |
(setq date-form (cdr date-form))) ;; ignore 'backup directive |
876 |
(let* ((date-form (if (equal (car (car d)) 'backup) |
(let* ((dayname |
877 |
(cdr (car d)) |
(diary-name-pattern calendar-day-name-array |
878 |
(car d)));; ignore 'backup directive |
calendar-day-abbrev-array)) |
879 |
(dayname |
(monthname |
880 |
(diary-name-pattern calendar-day-name-array |
(format "%s\\|\\*" |
881 |
calendar-day-abbrev-array)) |
(diary-name-pattern calendar-month-name-array |
882 |
(monthname |
calendar-month-abbrev-array))) |
883 |
(format "%s\\|\\*" |
(month "[0-9]+\\|\\*") |
884 |
(diary-name-pattern calendar-month-name-array |
(day "[0-9]+\\|\\*") |
885 |
calendar-month-abbrev-array))) |
(year "[0-9]+\\|\\*") |
886 |
(month "[0-9]+\\|\\*") |
(l (length date-form)) |
887 |
(day "[0-9]+\\|\\*") |
(d-name-pos (- l (length (memq 'dayname date-form)))) |
888 |
(year "[0-9]+\\|\\*") |
(d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) |
889 |
(l (length date-form)) |
(m-name-pos (- l (length (memq 'monthname date-form)))) |
890 |
(d-name-pos (- l (length (memq 'dayname date-form)))) |
(m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) |
891 |
(d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) |
(d-pos (- l (length (memq 'day date-form)))) |
892 |
(m-name-pos (- l (length (memq 'monthname date-form)))) |
(d-pos (if (/= l d-pos) (+ 2 d-pos))) |
893 |
(m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) |
(m-pos (- l (length (memq 'month date-form)))) |
894 |
(d-pos (- l (length (memq 'day date-form)))) |
(m-pos (if (/= l m-pos) (+ 2 m-pos))) |
895 |
(d-pos (if (/= l d-pos) (+ 2 d-pos))) |
(y-pos (- l (length (memq 'year date-form)))) |
896 |
(m-pos (- l (length (memq 'month date-form)))) |
(y-pos (if (/= l y-pos) (+ 2 y-pos))) |
897 |
(m-pos (if (/= l m-pos) (+ 2 m-pos))) |
(regexp |
898 |
(y-pos (- l (length (memq 'year date-form)))) |
(concat |
899 |
(y-pos (if (/= l y-pos) (+ 2 y-pos))) |
"\\(\\`\\|\^M\\|\n\\)\\(" |
900 |
(regexp |
(mapconcat 'eval date-form "\\)\\(") |
901 |
(concat |
"\\)")) |
902 |
"\\(\\`\\|\^M\\|\n\\)\\(" |
(case-fold-search t)) |
903 |
(mapconcat 'eval date-form "\\)\\(") |
(goto-char (point-min)) |
904 |
"\\)")) |
(while (re-search-forward regexp nil t) |
905 |
(case-fold-search t)) |
(let* ((dd-name |
906 |
(goto-char (point-min)) |
(if d-name-pos |
907 |
(while (re-search-forward regexp nil t) |
(match-string-no-properties d-name-pos))) |
908 |
(let* ((dd-name |
(mm-name |
909 |
(if d-name-pos |
(if m-name-pos |
910 |
(match-string-no-properties d-name-pos))) |
(match-string-no-properties m-name-pos))) |
911 |
(mm-name |
(mm (string-to-number |
912 |
(if m-name-pos |
(if m-pos |
913 |
(match-string-no-properties m-name-pos))) |
(match-string-no-properties m-pos) |
914 |
(mm (string-to-number |
""))) |
915 |
(if m-pos |
(dd (string-to-number |
916 |
(match-string-no-properties m-pos) |
(if d-pos |
917 |
""))) |
(match-string-no-properties d-pos) |
918 |
(dd (string-to-number |
""))) |
919 |
(if d-pos |
(y-str (if y-pos |
920 |
(match-string-no-properties d-pos) |
(match-string-no-properties y-pos))) |
921 |
""))) |
(yy (if (not y-str) |
922 |
(y-str (if y-pos |
0 |
923 |
(match-string-no-properties y-pos))) |
(if (and (= (length y-str) 2) |
924 |
(yy (if (not y-str) |
abbreviated-calendar-year) |
925 |
0 |
(let* ((current-y |
926 |
(if (and (= (length y-str) 2) |
(extract-calendar-year |
927 |
abbreviated-calendar-year) |
(calendar-current-date))) |
928 |
(let* ((current-y |
(y (+ (string-to-number y-str) |
929 |
(extract-calendar-year |
(* 100 |
930 |
(calendar-current-date))) |
(/ current-y 100))))) |
931 |
(y (+ (string-to-number y-str) |
(if (> (- y current-y) 50) |
932 |
(* 100 |
(- y 100) |
933 |
(/ current-y 100))))) |
(if (> (- current-y y) 50) |
934 |
(if (> (- y current-y) 50) |
(+ y 100) |
935 |
(- y 100) |
y))) |
936 |
(if (> (- current-y y) 50) |
(string-to-number y-str))))) |
937 |
(+ y 100) |
(let ((tmp (diary-pull-attrs (buffer-substring-no-properties |
938 |
y))) |
(point) (line-end-position)) |
939 |
(string-to-number y-str))))) |
file-glob-attrs))) |
940 |
(save-excursion |
(setq entry (nth 0 tmp) |
941 |
(setq entry (buffer-substring-no-properties |
marks (nth 1 tmp))) |
942 |
(point) (line-end-position)) |
(if dd-name |
943 |
temp (diary-pull-attrs entry file-glob-attrs) |
(mark-calendar-days-named |
944 |
entry (nth 0 temp) |
(cdr (assoc-string |
945 |
marks (nth 1 temp))) |
dd-name |
946 |
(if dd-name |
(calendar-make-alist |
947 |
(mark-calendar-days-named |
calendar-day-name-array |
948 |
(cdr (assoc-string |
0 nil calendar-day-abbrev-array) t)) marks) |
949 |
dd-name |
(if mm-name |
950 |
(calendar-make-alist |
(setq mm |
951 |
calendar-day-name-array |
(if (string-equal mm-name "*") 0 |
952 |
0 nil calendar-day-abbrev-array) t)) marks) |
(cdr (assoc-string |
953 |
(if mm-name |
mm-name |
954 |
(setq mm |
(calendar-make-alist |
955 |
(if (string-equal mm-name "*") 0 |
calendar-month-name-array |
956 |
(cdr (assoc-string |
1 nil calendar-month-abbrev-array) t))))) |
957 |
mm-name |
(mark-calendar-date-pattern mm dd yy marks)))))) |
958 |
(calendar-make-alist |
(mark-sexp-diary-entries) |
959 |
calendar-month-name-array |
(run-hooks 'nongregorian-diary-marking-hook |
960 |
1 nil calendar-month-abbrev-array) t))))) |
'mark-diary-entries-hook)) |
|
(mark-calendar-date-pattern mm dd yy marks)))) |
|
|
(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) |
|
961 |
(message "Marking diary entries...done"))))) |
(message "Marking diary entries...done"))))) |
962 |
|
|
963 |
(defun mark-sexp-diary-entries () |
(defun mark-sexp-diary-entries () |