*** /home/fischman/cvs/emacs/lisp/calendar/diary-lib.el 2002-11-18 01:05:22.000000000 -0800 --- diary-lib.el 2002-12-12 09:58:25.000000000 -0800 *************** *** 232,239 **** --- 232,247 ---- (set-buffer (find-file-noselect d-file t)) (set-buffer diary-buffer) (or (verify-visited-file-modtime diary-buffer) (revert-buffer t t)))) + ;; AMI -- Figure out the file-glob-color + (setq file-glob-color "") + (save-excursion + (goto-char (point-min)) + (if (re-search-forward diary-glob-file-color-regexp (point-max) t) + (setq file-glob-color (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))) (setq selective-display t) (setq selective-display-ellipses nil) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) *************** *** 307,327 **** (re-search-forward "\^M\\|\n" nil t)) (backward-char 1) (subst-char-in-region date-start (point) ?\^M ?\n t) (add-to-diary-list date ! (buffer-substring ! entry-start (point)) (buffer-substring (1+ date-start) (1- entry-start)) ! (copy-marker entry-start)))))) (setq d (cdr d))) (or entry-found (not diary-list-include-blanks) (setq diary-entries-list (append diary-entries-list ! (list (list date "" ""))))) (setq date (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian date)))) (setq entry-found nil))) --- 315,341 ---- (re-search-forward "\^M\\|\n" nil t)) (backward-char 1) (subst-char-in-region date-start (point) ?\^M ?\n t) + (setq color file-glob-color) + (setq entry (buffer-substring entry-start (point))) + (save-excursion + (if (string-match diary-color-regexp entry) + (setq color (substring-no-properties entry + (match-beginning 1) + (match-end 1))))) (add-to-diary-list date ! entry (buffer-substring (1+ date-start) (1- entry-start)) ! (copy-marker entry-start) color))))) (setq d (cdr d))) (or entry-found (not diary-list-include-blanks) (setq diary-entries-list (append diary-entries-list ! (list (list date "" "" "" ""))))) (setq date (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian date)))) (setq entry-found nil))) *************** *** 512,526 **** x) date-holiday-list (concat "\n" (make-string l ? )))) (insert ?\n (make-string (+ l longest) ?=) ?\n))))) ! (if (< 0 (length (car (cdr (car entry-list))))) ! (if (nth 3 (car entry-list)) ! (insert-button (concat (car (cdr (car entry-list))) "\n") ! 'marker (nth 3 (car entry-list)) ! :type 'diary-entry) ! (insert (car (cdr (car entry-list))) ?\n))) ! (setq entry-list (cdr entry-list)))) (set-buffer-modified-p nil) (goto-char (point-min)) (setq buffer-read-only t) (display-buffer fancy-diary-buffer) --- 526,558 ---- x) date-holiday-list (concat "\n" (make-string l ? )))) (insert ?\n (make-string (+ l longest) ?=) ?\n))))) ! ! (setq entry (car (cdr (car entry-list)))) ! (if (< 0 (length entry)) ! (progn ! (if (nth 3 (car entry-list)) ! (insert-button (concat entry "\n") ! 'marker (nth 3 (car entry-list)) ! :type 'diary-entry) ! (insert entry ?\n)) ! ;; AMI -- pick off the color that was the global file ! ;; color for this entry when it was read in ! ; (setq file-glob-color (fifth (car entry-list))) ! ;; AMI - find color for this diary entry if one is present ! (setq color (fifth (car entry-list))) ! (save-excursion ! (if (not (string= color "")) ! (progn ! (search-backward entry) ! (setq temp-face (make-symbol (concat "cal-col-face-" color))) ! (make-face temp-face) ! (set-face-foreground temp-face color) ! (overlay-put ! (make-overlay (match-beginning 0) (match-end 0)) 'face temp-face))) ! ))) ! (setq entry-list (cdr entry-list)))) (set-buffer-modified-p nil) (goto-char (point-min)) (setq buffer-read-only t) (display-buffer fancy-diary-buffer) *************** *** 696,703 **** --- 728,743 ---- (if (file-readable-p d-file) (save-excursion (message "Marking diary entries...") (set-buffer (find-file-noselect d-file t)) + ;; AMI - find global color for this file + (setq file-glob-color "") + (save-excursion + (goto-char (point-min)) + (if (re-search-forward diary-glob-file-color-regexp (point-max) t) + (setq file-glob-color (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))) (let ((d diary-date-forms) (old-diary-syntax-table)) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) *************** *** 774,789 **** (if (> (- current-y y) 50) (+ y 100) y))) (string-to-int y-str))))) (if dd-name (mark-calendar-days-named (cdr (assoc-ignore-case (substring dd-name 0 3) (calendar-make-alist calendar-day-name-array 0 ! (lambda (x) (substring x 0 3)))))) (if mm-name (if (string-equal mm-name "*") (setq mm 0) (setq mm --- 814,836 ---- (if (> (- current-y y) 50) (+ y 100) y))) (string-to-int y-str))))) + ;; AMI - find color for this diary entry + (setq color file-glob-color) + (save-excursion + (if (re-search-forward diary-color-regexp (line-end-position) t) + (setq color (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))) (if dd-name (mark-calendar-days-named (cdr (assoc-ignore-case (substring dd-name 0 3) (calendar-make-alist calendar-day-name-array 0 ! (lambda (x) (substring x 0 3))))) color) (if mm-name (if (string-equal mm-name "*") (setq mm 0) (setq mm *************** *** 793,801 **** calendar-month-name-array 1 (lambda (x) (substring x 0 3))) ))))) ! (mark-calendar-date-pattern mm dd yy)))) (setq d (cdr d)))) (mark-sexp-diary-entries) (run-hooks 'nongregorian-diary-marking-hook 'mark-diary-entries-hook) --- 840,848 ---- calendar-month-name-array 1 (lambda (x) (substring x 0 3))) ))))) ! (mark-calendar-date-pattern mm dd yy color)))) (setq d (cdr d)))) (mark-sexp-diary-entries) (run-hooks 'nongregorian-diary-marking-hook 'mark-diary-entries-hook) *************** *** 850,858 **** (char-equal (preceding-char) ?\n)) (not (looking-at " \\|\^I"))) (progn;; Diary entry consists only of the sexp (backward-char 1) ! (setq entry "")) (setq entry-start (point)) ;; Find end of entry (re-search-forward "\^M\\|\n" nil t) (while (looking-at " \\|\^I") --- 897,905 ---- (char-equal (preceding-char) ?\n)) (not (looking-at " \\|\^I"))) (progn;; Diary entry consists only of the sexp (backward-char 1) ! (setq entry "" color nil)) (setq entry-start (point)) ;; Find end of entry (re-search-forward "\^M\\|\n" nil t) (while (looking-at " \\|\^I") *************** *** 866,877 **** (aset entry (match-beginning 0) ?\n ))) (calendar-for-loop date from first-date to last-date do (if (setq mark (diary-sexp-entry sexp entry (calendar-gregorian-from-absolute date))) ! (mark-visible-calendar-date ! (calendar-gregorian-from-absolute date) ! (if (consp mark) ! (car mark))))))))) (defun mark-included-diary-files () "Mark the diary entries from other diary files with those of the diary file. This function is suitable for use as the `mark-diary-entries-hook'; it enables --- 913,934 ---- (aset entry (match-beginning 0) ?\n ))) (calendar-for-loop date from first-date to last-date do (if (setq mark (diary-sexp-entry sexp entry (calendar-gregorian-from-absolute date))) ! ;; AMI - find color for this diary entry ! (progn ! (setq color "") ! (save-excursion ! (if (string-match diary-color-regexp entry) ! (setq color (substring-no-properties entry ! (match-beginning 1) ! (match-end 1))))) ! (mark-visible-calendar-date ! (calendar-gregorian-from-absolute date) ! (if (< 0 (length color)) ! color ! (if (consp mark) ! (car mark))))))))))) (defun mark-included-diary-files () "Mark the diary entries from other diary files with those of the diary file. This function is suitable for use as the `mark-diary-entries-hook'; it enables *************** *** 904,912 **** (message "Can't find included diary file %s" diary-file) (sleep-for 2)))) (goto-char (point-min))) ! (defun mark-calendar-days-named (dayname) "Mark all dates in the calendar window that are day DAYNAME of the week. 0 means all Sundays, 1 means all Mondays, and so on." (save-excursion (set-buffer calendar-buffer) --- 961,969 ---- (message "Can't find included diary file %s" diary-file) (sleep-for 2)))) (goto-char (point-min))) ! (defun mark-calendar-days-named (dayname &optional color) "Mark all dates in the calendar window that are day DAYNAME of the week. 0 means all Sundays, 1 means all Mondays, and so on." (save-excursion (set-buffer calendar-buffer) *************** *** 922,945 **** (calendar-nth-named-day 1 dayname prev-month prev-year))) (setq last-day (calendar-absolute-from-gregorian (calendar-nth-named-day -1 dayname succ-month succ-year))) (while (<= day last-day) ! (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) (setq day (+ day 7)))))) ! (defun mark-calendar-date-pattern (month day year) "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. A value of 0 in any position is a wildcard." (save-excursion (set-buffer calendar-buffer) (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y -1) (calendar-for-loop i from 0 to 2 do ! (mark-calendar-month m y month day year) (increment-calendar-month m y 1))))) ! (defun mark-calendar-month (month year p-month p-day p-year) "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. A value of 0 in any position of the pattern is a wildcard." (if (or (and (= month p-month) (or (= p-year 0) (= year p-year))) --- 979,1002 ---- (calendar-nth-named-day 1 dayname prev-month prev-year))) (setq last-day (calendar-absolute-from-gregorian (calendar-nth-named-day -1 dayname succ-month succ-year))) (while (<= day last-day) ! (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color) (setq day (+ day 7)))))) ! (defun mark-calendar-date-pattern (month day year &optional color) "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. A value of 0 in any position is a wildcard." (save-excursion (set-buffer calendar-buffer) (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y -1) (calendar-for-loop i from 0 to 2 do ! (mark-calendar-month m y month day year color) (increment-calendar-month m y 1))))) ! (defun mark-calendar-month (month year p-month p-day p-year &optional color) "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. A value of 0 in any position of the pattern is a wildcard." (if (or (and (= month p-month) (or (= p-year 0) (= year p-year))) *************** *** 947,956 **** (or (= p-year 0) (= year p-year)))) (if (= p-day 0) (calendar-for-loop i from 1 to (calendar-last-day-of-month month year) do ! (mark-visible-calendar-date (list month i year))) ! (mark-visible-calendar-date (list month p-day year))))) (defun sort-diary-entries () "Sort the list of diary entries by time of day." (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) --- 1004,1013 ---- (or (= p-year 0) (= year p-year)))) (if (= p-day 0) (calendar-for-loop i from 1 to (calendar-last-day-of-month month year) do ! (mark-visible-calendar-date (list month i year) color)) ! (mark-visible-calendar-date (list month p-day year) color)))) (defun sort-diary-entries () "Sort the list of diary entries by time of day." (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) *************** *** 1171,1178 **** --- 1228,1240 ---- (sexp-mark (regexp-quote sexp-diary-entry-symbol)) (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) (entry-found)) (goto-char (point-min)) + (save-excursion + (if (re-search-forward diary-glob-file-color-regexp (point-max) t) + (setq file-glob-color (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))) (while (re-search-forward s-entry nil t) (backward-char 1) (let ((sexp-start (point)) (sexp) *************** *** 1203,1219 **** (setq entry (buffer-substring-no-properties entry-start (point))) (while (string-match "[\^M]" entry) (aset entry (match-beginning 0) ?\n ))) (let ((diary-entry (diary-sexp-entry sexp entry date))) (if diary-entry ! (subst-char-in-region line-start (point) ?\^M ?\n t)) ! (add-to-diary-list date ! (if (consp diary-entry) ! (cdr diary-entry) ! diary-entry) specifier (if entry-start (copy-marker entry-start) ! nil)) (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) --- 1265,1291 ---- (setq entry (buffer-substring-no-properties entry-start (point))) (while (string-match "[\^M]" entry) (aset entry (match-beginning 0) ?\n ))) (let ((diary-entry (diary-sexp-entry sexp entry date))) + (setq entry (if (consp diary-entry) + (cdr diary-entry) + diary-entry)) (if diary-entry ! (progn ! (subst-char-in-region line-start (point) ?\^M ?\n t) ! (setq color file-glob-color) ! (if (< 0 (length entry)) ! (save-excursion ! (if (string-match diary-color-regexp entry) ! (setq color (substring-no-properties entry ! (match-beginning 1) ! (match-end 1)))))))) ! (add-to-diary-list date ! entry specifier (if entry-start (copy-marker entry-start) ! nil) ! color) (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) *************** *** 1469,1483 **** ((and (listp days) days) (or (diary-remind sexp (car days) marking) (diary-remind sexp (cdr days) marking)))))) ! (defun add-to-diary-list (date string specifier marker) ! "Add the entry (DATE STRING SPECIFIER) to `diary-entries-list'. Do nothing if DATE or STRING is nil." (and date string (setq diary-entries-list (append diary-entries-list ! (list (list date string specifier marker)))))) (defun make-diary-entry (string &optional nonmarking file) "Insert a diary entry STRING which may be NONMARKING in FILE. If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." --- 1541,1558 ---- ((and (listp days) days) (or (diary-remind sexp (car days) marking) (diary-remind sexp (cdr days) marking)))))) ! (defun add-to-diary-list (date string specifier marker &optional globcolor) ! "Add the entry (DATE STRING SPECIFIER MARKER GLOBCOLOR) to `diary-entries-list'. Do nothing if DATE or STRING is nil." (and date string + (if diary-file-name-prefix + (setq string (concat "[" (buffer-file-name) "] " string)) + t) (setq diary-entries-list (append diary-entries-list ! (list (list date string specifier marker globcolor)))))) (defun make-diary-entry (string &optional nonmarking file) "Insert a diary entry STRING which may be NONMARKING in FILE. If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."