*** /home/fischman/cvs/emacs/lisp/calendar/diary-lib.el 2002-11-18 01:05:22.000000000 -0800 --- diary-lib.el 2002-12-19 09:52:18.000000000 -0800 *************** *** 184,191 **** --- 184,268 ---- (defvar date-string) (defvar d-file) (defvar original-date) + (defun diary-attrtype-convert (attrvalue type) + "Convert the attrvalue from a string to the appropriate type for using + in a face description" + (let (ret) + (setq ret (cond ((eq type 'string) attrvalue) + ((eq type 'symbol) (read attrvalue)) + ((eq type 'int) (string-to-int attrvalue)) + ((eq type 'stringtnil) + (cond ((string= "t" attrvalue) t) + ((string= "nil" attrvalue) nil) + (t attrvalue))) + ((eq type 'tnil) + (cond ((string= "t" attrvalue) t) + ((string= "nil" attrvalue) nil))))) + ; (message "(%s)[%s]=[%s]" (print type) attrvalue ret) + ret)) + + + (defun diary-pull-attrs (entry fileglobattrs) + "Pull the face-related attributes off the entry, merge with the + fileglobattrs, and return the (possibly modified) entry and face + data in a list of attrname attrvalue values. + The entry will be modified to drop all tags that are used for face matching. + If entry is nil, then the fileglobattrs are being searched for, + the fileglobattrs variable is ignored, and + diary-glob-file-regexp-prefix is prepended to the regexps before each + search." + ;; XXX + (save-excursion + (let (regexp regnum attrname attr-list attrname attrvalue type) + (if (null entry) + (progn + (setq ret-attr '() + attr-list diary-face-attrs) + (while attr-list + (goto-char (point-min)) + (setq attr (car attr-list) + regexp (nth 0 attr) + regnum (nth 1 attr) + attrname (nth 2 attr) + type (nth 3 attr) + regexp (concat diary-glob-file-regexp-prefix regexp)) + (setq attrvalue nil) + (if (re-search-forward regexp (point-max) t) + (setq attrvalue (buffer-substring-no-properties + (match-beginning regnum) + (match-end regnum)))) + (if (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type))) + (setq ret-attr (append ret-attr (list attrname attrvalue)))) + (setq attr-list (cdr attr-list))) + (setq fileglobattrs ret-attr)) + (progn + (setq ret-attr fileglobattrs + attr-list diary-face-attrs) + (while attr-list + (goto-char (point-min)) + (setq attr (car attr-list) + regexp (nth 0 attr) + regnum (nth 1 attr) + attrname (nth 2 attr) + type (nth 3 attr)) + (setq attrvalue nil) + (if (string-match regexp entry) + (progn + (setq attrvalue (substring-no-properties entry + (match-beginning regnum) + (match-end regnum))) + (setq entry (replace-match "" t t entry)))) + (if (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type))) + (setq ret-attr (append ret-attr (list attrname attrvalue)))) + (setq attr-list (cdr attr-list))))))) + (list entry ret-attr)) + + + (defun list-diary-entries (date number) "Create and display a buffer containing the relevant lines in diary-file. The arguments are DATE and NUMBER; the entries selected are those for NUMBER days starting with date DATE. The other entries are hidden *************** *** 222,229 **** --- 299,307 ---- (if (< 0 number) (let* ((original-date date);; save for possible use in the hooks old-diary-syntax-table diary-entries-list + file-glob-attrs (date-string (calendar-date-string date)) (d-file (substitute-in-file-name diary-file))) (message "Preparing diary...") (save-excursion *************** *** 232,239 **** --- 310,318 ---- (set-buffer (find-file-noselect d-file t)) (set-buffer diary-buffer) (or (verify-visited-file-modtime diary-buffer) (revert-buffer t t)))) + (setq file-glob-attrs (nth 1 (diary-pull-attrs nil ""))) (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))) --- 386,409 ---- (re-search-forward "\^M\\|\n" nil t)) (backward-char 1) (subst-char-in-region date-start (point) ?\^M ?\n t) + (setq entry (buffer-substring entry-start (point)) + temp (diary-pull-attrs entry file-glob-attrs) + entry (nth 0 temp) + marks (nth 1 temp)) (add-to-diary-list date ! entry (buffer-substring (1+ date-start) (1- entry-start)) ! (copy-marker entry-start) marks))))) (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) --- 594,628 ---- 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)) ! (save-excursion ! (setq marks (fifth (car entry-list))) ! (setq temp-face (make-symbol (apply 'concat "temp-face-" (mapcar '(lambda (sym) (if (not (stringp sym)) (symbol-name sym) sym)) marks)))) ! (make-face temp-face) ! ;; Remove :face info from the marks, copy the face info into temp-face ! (setq faceinfo marks) ! (while (setq faceinfo (memq :face faceinfo)) ! (copy-face (read (nth 1 faceinfo)) temp-face) ! (setcar faceinfo nil) ! (setcar (cdr faceinfo) nil)) ! (setq marks (delq nil marks)) ! ;; Apply the font aspects ! (apply 'set-face-attribute temp-face nil marks) ! (search-backward entry) ! (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) *************** *** 689,703 **** After the entries are marked, the hooks `nongregorian-diary-marking-hook' and `mark-diary-entries-hook' are run." (interactive) (setq mark-diary-entries-in-calendar t) ! (let ((d-file (substitute-in-file-name diary-file)) (marking-diary-entries t)) (if (and d-file (file-exists-p d-file)) (if (file-readable-p d-file) (save-excursion (message "Marking diary entries...") (set-buffer (find-file-noselect d-file t)) (let ((d diary-date-forms) (old-diary-syntax-table)) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) --- 791,807 ---- After the entries are marked, the hooks `nongregorian-diary-marking-hook' and `mark-diary-entries-hook' are run." (interactive) (setq mark-diary-entries-in-calendar t) ! (let (file-glob-attrs ! (d-file (substitute-in-file-name diary-file)) (marking-diary-entries t)) (if (and d-file (file-exists-p d-file)) (if (file-readable-p d-file) (save-excursion (message "Marking diary entries...") (set-buffer (find-file-noselect d-file t)) + (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) (let ((d diary-date-forms) (old-diary-syntax-table)) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) *************** *** 773,801 **** (- y 100) (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 ! (cdr (assoc-ignore-case ! (substring mm-name 0 3) ! (calendar-make-alist ! 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) --- 877,910 ---- (- y 100) (if (> (- current-y y) 50) (+ y 100) y))) ! (string-to-int y-str)))) ! (save-excursion ! (setq entry (buffer-substring-no-properties (point) (line-end-position)) ! temp (diary-pull-attrs entry file-glob-attrs) ! entry (nth 0 temp) ! marks (nth 1 temp)))) ! (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))))) marks) ! (if mm-name ! (if (string-equal mm-name "*") ! (setq mm 0) ! (setq mm ! (cdr (assoc-ignore-case ! (substring mm-name 0 3) ! (calendar-make-alist ! calendar-month-name-array ! 1 ! (lambda (x) (substring x 0 3))) ! ))))) ! (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) *************** *** 816,824 **** (m) (y) (first-date) (last-date) ! (mark)) (save-excursion (set-buffer calendar-buffer) (setq m displayed-month) (setq y displayed-year)) --- 925,935 ---- (m) (y) (first-date) (last-date) ! (mark) ! file-glob-attrs) ! (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) (save-excursion (set-buffer calendar-buffer) (setq m displayed-month) (setq y displayed-year)) *************** *** 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 --- 977,994 ---- (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))) ! (progn ! (setq marks (diary-pull-attrs entry file-glob-attrs) ! temp (diary-pull-attrs entry file-glob-attrs) ! marks (nth 1 temp)) ! (mark-visible-calendar-date ! (calendar-gregorian-from-absolute date) ! (if (< 0 (length marks)) ! marks ! (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) --- 1021,1029 ---- (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))) --- 1039,1062 ---- (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))) --- 1064,1073 ---- (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))) *************** *** 1169,1178 **** best if they are nonmarking." (let* ((mark (regexp-quote diary-nonmarking-symbol)) (sexp-mark (regexp-quote sexp-diary-entry-symbol)) (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) ! (entry-found)) (goto-char (point-min)) (while (re-search-forward s-entry nil t) (backward-char 1) (let ((sexp-start (point)) (sexp) --- 1286,1298 ---- best if they are nonmarking." (let* ((mark (regexp-quote diary-nonmarking-symbol)) (sexp-mark (regexp-quote sexp-diary-entry-symbol)) (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) ! (entry-found) ! (file-glob-attrs)) (goto-char (point-min)) + (save-excursion + (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))) (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) --- 1323,1346 ---- (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) ! (if (< 0 (length entry)) ! (setq temp (diary-pull-attrs entry file-glob-attrs) ! entry (nth 0 temp) ! marks (nth 1 temp))))) ! (add-to-diary-list date ! entry specifier (if entry-start (copy-marker entry-start) ! nil) ! marks) (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." --- 1596,1615 ---- ((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 (and diary-file-name-prefix + (setq prefix (concat "[" (funcall diary-file-name-prefix-function (buffer-file-name)) "] ")) + (not (string= prefix "[] "))) + (setq string (concat prefix 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."