Path: utzoo!utgpu!jarvis.csri.toronto.edu!clyde.concordia.ca!uunet!cs.utexas.edu!usc!brutus.cs.uiuc.edu!ux1.cso.uiuc.edu!ux1.cso.uiuc.edu!m.cs.uiuc.edu!p.cs.uiuc.edu!reingold From: reingold@p.cs.uiuc.edu Newsgroups: comp.emacs Subject: Re: Calendar.el, revised Message-ID: <77000012@p.cs.uiuc.edu> Date: 2 Jan 90 17:39:16 GMT References: <77000010@p.cs.uiuc.edu> Lines: 545 Nf-ID: #R:p.cs.uiuc.edu:77000010:p.cs.uiuc.edu:77000012:000:25859 Nf-From: p.cs.uiuc.edu!reingold Jan 1 15:53:00 1990 ;; Diary functions. ;; Copyright (C) 1989, 1990 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. ;; This collection of functions implements the diary features as described ;; in calendar.el. ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ;; (217) 333-6733 University of Illinois at Urbana-Champaign ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue ;; Urbana, Illinois 61801 (require 'calendar) (provide 'diary) (defun diary (&optional arg) "Generate the diary window for ARG days starting with the current date. If no argument is provided, the number of days of diary entries is governed by the variable `number-of-diary-entries'. This function is suitable for execution in a .emacs file." (interactive "P") (if (and diary-file (file-exists-p diary-file)) (if (file-readable-p diary-file) (let ((date (calendar-current-date))) (list-diary-entries date (cond (arg (prefix-numeric-value arg)) ((vectorp number-of-diary-entries) (aref number-of-diary-entries (calendar-day-of-week date))) (t number-of-diary-entries)))) (error "Your diary file is not readable!")) (error "You don't have a diary file!"))) (defun view-diary-entries (arg) "Prepare and display a buffer with diary entries. Searches the file diary-file for entries that match ARG days starting with the date indicated by the cursor position in the displayed three-month calendar." (interactive "p") (if (and diary-file (file-exists-p diary-file)) (if (file-readable-p diary-file) (list-diary-entries (or (calendar-cursor-to-date) (error "Cursor is not on a date!")) arg) (error "Your diary file is not readable!")) (error "You don't have a diary file!"))) (autoload 'check-calendar-holidays "holidays" "Check the list of holidays for any that occur on DATE. The value returned is a list of strings of relevant holiday descriptions. The holidays are those in the list calendar-holidays.") (defvar diary-syntax-table (standard-syntax-table) "The syntax table used when parsing dates in the diary file. It is the standard syntax table used in Fundamental mode, but with the syntax of `*' changed to be a word constituent.") (modify-syntax-entry ?* "w" diary-syntax-table) (defun list-diary-entries (date number &optional nomessage) "Create and display a buffer containing the relevant lines in diary-file. All lines that apply to DATE and the next NUMBER-1 days are included. If the optional NOMESSAGE is t, the diary is generated silently. Returns a list of all relevant diary entries found, if any, in order by date. The list entries have the form ((month day year) string). If the variable `diary-list-include-blanks' is t, this list will include a dummy diary entry (consisting of the empty string) for a date with no diary entries. Also prepared is a list of holidays for DATE, if `holidays-in-diary-buffer' is t. After the lists is prepared, the hooks `list-diary-entries-hook' are run." (if (< 0 number) (progn (or nomessage (message "Preparing diary...")) (let* ((original-date date);; save for possible use in the hooks (old-diary-syntax-table) (diary-entries-list) (date-string (calendar-date-string date))) (save-excursion (let ((diary-buffer (get-file-buffer diary-file))) (set-buffer (if diary-buffer diary-buffer (find-file-noselect diary-file t)))) (setq selective-display t) (setq selective-display-ellipses nil) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) (let ((buffer-read-only nil) (diary-modified (buffer-modified-p)) (mark (regexp-quote diary-nonmarking-symbol))) (goto-char (1- (point-max))) (if (not (looking-at "\^M\\|\n")) (progn (forward-char 1) (insert-string "\^M"))) (goto-char (point-min)) (if (not (looking-at "\^M\\|\n")) (insert-string "\^M")) (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) (calendar-for-loop i from 1 to number do (let ((d diary-date-forms) (month (extract-calendar-month date)) (day (extract-calendar-day date)) (year (extract-calendar-year date)) (entry-found)) (while d (let* ((date-form (if (equal (car (car d)) 'backup) (cdr (car d)) (car d))) (backup (equal (car (car d)) 'backup)) (dayname (concat (calendar-day-name date) "\\|" (substring (calendar-day-name date) 0 3) ".?")) (monthname (concat "\\*\\|" (calendar-month-name month) "\\|" (substring (calendar-month-name month) 0 3) ".?")) (month (concat "\\*\\|0*" (int-to-string month))) (day (concat "\\*\\|0*" (int-to-string day))) (year (concat "\\*\\|0*" (int-to-string year) (if abbreviated-calendar-year (concat "\\|" (int-to-string (mod year 100))) ""))) (regexp (concat "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" (mapconcat 'eval date-form "\\)\\(") "\\)")) (case-fold-search t)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (if backup (re-search-backward "\\<" nil t)) (if (and (or (char-equal (preceding-char) ?\^M) (char-equal (preceding-char) ?\n)) (not (looking-at " \\|\^I"))) nil;; Empty diary entry that consists only of date. ;; Found a nonempty diary entry--make it visible and ;; add it to the list. (setq entry-found t) (let ((entry-start (point)) (date-start)) (re-search-backward "\^M\\|\n\\|\\`") (setq date-start (point)) (re-search-forward "\^M\\|\n" nil t 2) (while (looking-at " \\|\^I") (re-search-forward "\^M\\|\n" nil t)) (backward-char 1) (subst-char-in-region date-start (point) ?\^M ?\n t) (setq diary-entries-list (append diary-entries-list (list (list date (buffer-substring entry-start (point)))))))))) (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 month (extract-calendar-month date)) (setq day (extract-calendar-day date)) (setq year (extract-calendar-year date)) (setq entry-found nil))) (set-buffer-modified-p diary-modified)) (goto-char (point-min)) (run-hooks 'list-diary-entries-hook) (set-syntax-table old-diary-syntax-table) diary-entries-list))))) (defun include-other-diary-files () "Include the diary entries from other diary files with those of diary-file. This function is suitable for use just before prepare-fancy-diary-buffer as the list-dairy-entries-hook; it enables you to use shared diary files together with your own. The files included are specified in the diary-file by lines of the form #include \"filename\" This is recursive; that is, #include directives in diary files thus included are obeyed. You can change the \"#include\" to some other string by changing the variable `diary-include-string'." (goto-char (point-min)) (while (re-search-forward (concat "\\(\\`\\|\^M\\|\n\\)" (regexp-quote diary-include-string) " \"\\([^\"]*\\)\"") nil t) (let ((diary-file (buffer-substring (match-beginning 2) (match-end 2))) (diary-list-include-blanks nil) (list-diary-entries-hook 'include-other-diary-files)) (if (file-exists-p diary-file) (if (file-readable-p diary-file) (progn (setq diary-entries-list (append diary-entries-list (list-diary-entries original-date number t))) (kill-buffer (get-file-buffer diary-file))) (beep) (message "Can't read included diary file %s" diary-file) (sleep-for 2)) (beep) (message "Can't find included diary file %s" diary-file) (sleep-for 2)))) (goto-char (point-min))) (defun prepare-fancy-diary-buffer () "Prepare a diary buffer with relevant entries in a fancy, noneditable form. This function is provided for optional use as the `list-diary-entries-hook'." (if (or (not diary-entries-list) (and (not (cdr diary-entries-list)) (string-equal (car (cdr (car diary-entries-list))) ""))) (let ((holiday-list (if holidays-in-diary-buffer (check-calendar-holidays original-date)))) (message "No diary entries for %s %s" (concat date-string (if holiday-list ":" "")) (mapconcat 'identity holiday-list "; "))) (save-excursion;; Turn off selective-display in the diary file's buffer. (set-buffer (get-file-buffer diary-file)) (let ((diary-modified (buffer-modified-p))) (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) (setq selective-display nil) (kill-local-variable 'mode-line-format) (set-buffer-modified-p diary-modified))) (save-excursion;; Prepare the fancy diary buffer. (set-buffer (get-buffer-create fancy-diary-buffer)) (setq buffer-read-only nil) (make-local-variable 'mode-line-format) (setq mode-line-format "---------------------------Diary Entries%-") (erase-buffer) (let ((entry-list diary-entries-list) (date (list 0 0 0))) (while entry-list (if (not (calendar-date-equal date (car (car entry-list)))) (progn (setq date (car (car entry-list))) (let* ((date-string (calendar-date-string date)) (holiday-list (if holidays-in-diary-buffer (check-calendar-holidays date)))) (insert (if (= (point) (point-min)) "" ?\n) date-string) (if holiday-list (insert ": ")) (let ((l (current-column))) (insert (mapconcat 'identity holiday-list (concat "\n" (make-string l ? ))))) (let ((l (current-column))) (insert ?\n (make-string l ?=) ?\n))))) (if (< 0 (length (car (cdr (car entry-list))))) (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) (message "Preparing diary...done")))) (defun print-diary-entries () "Print a hard copy of the entries visible in the diary window. The hooks given by the variable `print-diary-entries-hook' are called after the temporary buffer of visible diary entries is prepared; it is the hooks that do the actual printing and kill the buffer." (interactive) (let ((diary-buffer (get-file-buffer diary-file))) (if diary-buffer (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))) (save-excursion (set-buffer diary-buffer) (copy-to-buffer temp-buffer (point-min) (point-max)) (set-buffer temp-buffer) (while (re-search-forward "\^M.*$" nil t) (replace-match "")) (run-hooks 'print-diary-entries-hook))) (error "You don't have a diary buffer!")))) (defun add-diary-heading () "Add a heading to the diary entries for printing. The heading is formed from the mode line of the diary buffer. This function is used in the default value of the variable `print-diary-entry-hooks'." (save-excursion (let ((heading)) (set-buffer diary-buffer) (setq heading mode-line-format) (string-match "%\\*-*\\([^-].*\\)%-$" heading) (setq heading (substring heading (match-beginning 1) (match-end 1))) (set-buffer temp-buffer) (goto-char (point-min)) (insert heading "\n" (make-string (length heading) ?=) "\n")))) (defun show-all-diary-entries () "Show all of the diary entries in the diary-file. This function gets rid of the selective display of the diary-file so that all entries, not just some, are visible. If there is no diary buffer, one is created." (interactive) (if (and diary-file (file-exists-p diary-file)) (if (file-readable-p diary-file) (save-excursion (let ((diary-buffer (get-file-buffer diary-file))) (set-buffer (if diary-buffer diary-buffer (find-file-noselect diary-file t))) (let ((buffer-read-only nil) (diary-modified (buffer-modified-p))) (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) (setq selective-display nil) (make-local-variable 'mode-line-format) (setq mode-line-format (concat "%*---------------------------All Diary Entries%-")) (display-buffer (current-buffer)) (set-buffer-modified-p diary-modified)))) (error "Your diary file is not readable!")) (error "You don't have a diary file!"))) (defun diary-name-pattern (string-array) "Convert an array of strings to a pattern. The pattern will match any of the strings, either entirely or abbreviated to three characters. An abbreviated form will match with or without a period." (let ((pattern "")) (calendar-for-loop i from 0 to (1- (length string-array)) do (setq pattern (concat pattern (if (string-equal pattern "") "" "\\|") (aref string-array i) "\\|" (substring (aref string-array i) 0 3) ".?"))) pattern)) (defun mark-diary-entries () "Mark days in the calendar window that have diary entries. Each entry in diary-file visible in the calendar window is marked. After the entries are marked, the hooks `mark-diary-entries-hook' are run." (interactive) (setq mark-diary-entries-in-calendar t) (if (and diary-file (file-exists-p diary-file)) (if (file-readable-p diary-file) (save-excursion (message "Marking diary entries...") (set-buffer (find-file-noselect diary-file t)) (let ((d diary-date-forms) (old-diary-syntax-table)) (setq old-diary-syntax-table (syntax-table)) (set-syntax-table diary-syntax-table) (while d (let* ((date-form (if (equal (car (car d)) 'backup) (cdr (car d)) (car d)));; ignore 'backup directive (dayname (diary-name-pattern calendar-day-name-array)) (monthname (concat (diary-name-pattern calendar-month-name-array) "\\|\\*")) (month "[0-9]+\\|\\*") (day "[0-9]+\\|\\*") (year "[0-9]+\\|\\*") (l (length date-form)) (d-name-pos (- l (length (memq 'dayname date-form)))) (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) (m-name-pos (- l (length (memq 'monthname date-form)))) (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) (d-pos (- l (length (memq 'day date-form)))) (d-pos (if (/= l d-pos) (+ 2 d-pos))) (m-pos (- l (length (memq 'month date-form)))) (m-pos (if (/= l m-pos) (+ 2 m-pos))) (y-pos (- l (length (memq 'year date-form)))) (y-pos (if (/= l y-pos) (+ 2 y-pos))) (regexp (concat "\\(\\`\\|\^M\\|\n\\)\\(" (mapconcat 'eval date-form "\\)\\(") "\\)")) (case-fold-search t)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (let* ((dd-name (if d-name-pos (buffer-substring (match-beginning d-name-pos) (match-end d-name-pos)))) (mm-name (if m-name-pos (buffer-substring (match-beginning m-name-pos) (match-end m-name-pos)))) (mm (string-to-int (if m-pos (buffer-substring (match-beginning m-pos) (match-end m-pos)) ""))) (dd (string-to-int (if d-pos (buffer-substring (match-beginning d-pos) (match-end d-pos)) ""))) (y-str (if y-pos (buffer-substring (match-beginning y-pos) (match-end y-pos)))) (yy (if (not y-str) 0 (if (and (= (length y-str) 2) abbreviated-calendar-year) (let* ((current-y (extract-calendar-year (calendar-current-date))) (y (+ (string-to-int y-str) (* 100 (/ current-y 100))))) (if (> (- y current-y) 50) (- y 100) (if (> (- current-y y) 50) (+ y 100) y))) (string-to-int y-str))))) (if dd-name (mark-calendar-days-named (cdr (assoc (capitalize (substring dd-name 0 3)) calendar-day-abbrev-list))) (if mm-name (if (string-equal mm-name "*") (setq mm 0) (setq mm (cdr (assoc (capitalize (substring mm-name 0 3)) calendar-month-abbrev-list))))) (mark-calendar-date-pattern mm dd yy)))) (setq d (cdr d)))) (run-hooks 'mark-diary-entries-hook) (set-syntax-table old-diary-syntax-table) (message "Marking diary entries...done"))) (error "Your diary file is not readable!")) (error "You don't have a diary file!"))) (defun mark-included-diary-files () "Mark the diary entries from other diary files with those of diary-file. This function is suitable for use as the mark-dairy-entries-hook; it enables you to use shared diary files together with your own. The files included are specified in the diary-file by lines of the form #include \"filename\" This is recursive; that is, #include directives in diary files thus included are obeyed. You can change the \"#include\" to some other string by changing the variable `diary-include-string'." (goto-char (point-min)) (while (re-search-forward (concat "\\(\\`\\|\^M\\|\n\\)" (regexp-quote diary-include-string) " \"\\([^\"]*\\)\"") nil t) (let ((diary-file (buffer-substring (match-beginning 2) (match-end 2))) (mark-diary-entries-hook 'mark-included-diary-files)) (if (file-exists-p diary-file) (if (file-readable-p diary-file) (progn (mark-diary-entries) (kill-buffer (get-file-buffer diary-file))) (beep) (message "Can't read included diary file %s" diary-file) (sleep-for 2)) (beep) (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) (let ((prev-month displayed-month) (prev-year displayed-year) (succ-month displayed-month) (succ-year displayed-year) (last-day) (day)) (increment-calendar-month succ-month succ-year 1) (increment-calendar-month prev-month prev-year -1) (setq day (calendar-absolute-from-gregorian (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 wild-card." (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 wild-card." (if (or (and (= month p-month) (or (= p-year 0) (= year p-year))) (and (= p-month 0) (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 diary-entry-compare (e1 e2) "Returns t if E1 is earlier than E2." (or (calendar-date-compare e1 e2) (and (calendar-date-equal (car e1) (car e2)) (string-lessp (car (cdr e1)) (car (cdr e2))))))