/[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.103 by monnier, Wed Sep 14 15:22:25 2005 UTC revision 1.104 by monnier, Fri Sep 16 16:04:27 2005 UTC
# Line 865  diary entries." Line 865  diary entries."
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 ()

Legend:
Removed from v.1.103  
changed lines
  Added in v.1.104

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