[PATCH] More calendar synces with Emacs CVS

I plan to commit the following in a day or so. ChangeLog addition: 2006-10-20 Jeff Miller <jeff.miller(a)xemacs.org&gt; More Emacs CVS syncs, from the Emacs Changelog: * calendar/diary-lib.el (diary-bahai-date) (list-bahai-diary-entries, mark-bahai-diary-entries) (mark-bahai-calendar-date-pattern): Not interactive. (add-to-diary-list): New optional arg LITERAL. Doc fix. (diary-entries-list): Change format of 4th element in each entry. (diary-list-entries): Use add-to-diary-list. (diary-goto-entry): Handle the case where the buffer visiting the diary has been killed. (fancy-diary-display): Add 'locator to button rather than 'marker. Only generate temp-face when there are marks to apply. (list-sexp-diary-entries): Pass literal to add-to-diary-list. (diary-fancy-date-pattern): New variable. (diary-time-regexp): Doc fix. (diary-anniversary, diary-time): New faces. (fancy-diary-font-lock-keywords): Use diary-fancy-date-pattern and diary-time-regexp. Add font-lock-multiline property where needed. Use new faces diary-anniversary and diary-time. (diary-fancy-font-lock-fontify-region-function): New function, to handle multiline font-lock pattern in fancy diary. (fancy-diary-display-mode): Set font-lock-fontify-region-function. (diary-font-lock-keywords): Tweak time regexp. Use new face diary-time. * calendar/cal-menu.el (calendar-mode-map, calendar-mouse-3-map): * calendar/calendar.el (calendar-mode-map): * calendar/diary-lib.el (include-other-diary-files,diary-mail-entries): * calendar/appt.el (appt-check, appt-make-list): Refer to diary-view-entries, diary-list-entries, diary-show-all-entries rather than obsolete aliases. * calendar/calendar.el (diary-show-all-entries): Do not refer to obsolete alias `show-all-diary-entries'. (make-diary-entry): Not interactive. (cal-tex-cursor-month, cal-tex-cursor-month-landscape) (cal-tex-cursor-day, cal-tex-cursor-week, cal-tex-cursor-week2) (cal-tex-cursor-week-iso, cal-tex-cursor-week-monday) (cal-tex-cursor-filofax-2week, cal-tex-cursor-filofax-week) (cal-tex-cursor-year-landscape, cal-tex-cursor-filofax-year) (cal-tex-cursor-filofax-daily, cal-tex-cursor-year): Interactive. * calendar/calendar.el (calendar-french-date-string) (calendar-mayan-date-string, calendar-chinese-date-string) (calendar-astro-date-string, calendar-iso-date-string) (calendar-islamic-date-string, calendar-bahai-date-string) (calendar-hebrew-date-string, calendar-coptic-date-string) (calendar-ethiopic-date-string, calendar-persian-date-string): These functions are not interactive. * calendar/calendar.el (calendar-basic-setup): Set day to 1 in prefix arg case, to avoid view-diary-entries-initially error. Reported by Stephen Berman <Stephen.Berman at gmx.net>. (calendar-date-is-legal-p): Handle dates with no day part. * calendar/cal-menu.el (calendar-mode-map): Refer to `diary-view-entries' rather than alias `view-diary-entries'. * calendar/diary-lib.el (view-other-diary-entries): Ditto. * calendar/appt.el (appt-add): Check whether an appointment is already present in appt-time-msg-list. Simplify code. * calendar/calendar.el (calendar-holidays): Doc fix. * calendar/holidays.el (list-holidays): Doc fix. * calendar/calendar.el (calendar-holidays): Doc fix. * calendar/appt.el (diary-selective-display): Add defvar. * calendar/icalendar.el (icalendar--get-event-property) (icalendar--get-event-property-attributes): Fix typos in docstrings. * calendar/cal-menu.el: Avoid macros from calendar.el so as to break the nastiest part of the cyclic dependency. (cal-menu-update): Use dotimes and calendar-increment-month. * calendar/calendar.el: Remove unnecessary leading stars in docstrings. (calendar-week-start-day): Add an :initializer. (calendar-mode-map): Use suppress-keymap, and command remapping. (describe-calendar-mode): Setup xref-stack info for the back button. (calendar-star-date): Insert before delete. (calendar-set-mode-line): Add file-modified info if applicable. (calendar-increment-month): New function. * calendar/diary-lib.el (diary-list-entries): Also hide the terminating newline. * calendar/diary-lib.el (diary-list-entries, diary-show-all-entries) (mark-diary-entries, make-diary-entry): Check default-major-mode rather than fundamental-mode to see if the mode was set. * calendar/cal-menu.el (date, event): Don't declare as dynamic-var. (calendar-mouse-holidays, calendar-mouse-view-diary-entries) (calendar-mouse-print-dates): Add optional `event' argument. Update interactive-spec. (calendar-mouse-cal-tex-menu, cal-tex-mouse-filofax): Use `calendar-event-to-date' instead of `event'. * calendar/diary-lib.el (diary-list-entries): Prevent infloop when diary does not end in a newline. Do not assume a blank line at the start of the diary file. * calendar/icalendar.el (icalendar-version): Increase to 0.13. Now a string. (icalendar-import-format): Handle CLASS, STATUS, URL. Rename `subject' to `summary'. (icalendar-import-format-summary): Rename from `icalendar-import-format-subject'. (icalendar-import-format-url, icalendar-import-format-status) (icalendar-import-format-class): New variables. (icalendar--rris): Take variable argument list. (icalendar--datestring-to-isodate): Remove unnecessary calendar-style check when converting dates with explicit month names. (icalendar-export-region): Change return type of conversion subroutines. Bury current buffer unless error occurred. (icalendar--convert-to-ical) (icalendar--parse-summary-and-rest): New functions. (icalendar--convert-ordinary-to-ical) (icalendar--convert-weekly-to-ical) (icalendar--convert-yearly-to-ical) (icalendar--convert-block-to-ical) (icalendar--convert-cyclic-to-ical) (icalendar--convert-anniversary-to-ical): Change return type. Strip trailing blanks from subject. (icalendar--convert-sexp-to-ical): Change return type. Strip trailing blanks from subject. Handle simple sexp entries as generated by icalendar.el. (icalendar--convert-float-to-ical) (icalendar--convert-date-to-ical): Strip trailing blanks from subject. (icalendar-import-file): Doc fix. (icalendar--format-ical-event): Handle CLASS, STATUS, URL. Correct call to icalendar--rris. (icalendar--convert-ical-to-diary): Doc fix. Rename `subject' to `summary'. (icalendar--add-diary-entry): Rename `subject' to `summary'. * calendar/appt.el (appt-check): Use diary-selective-display var. * calendar/cal-menu.el (calendar-mouse-view-diary-entries): Use the new `list-only' arg to diary-list-entries. * calendar/diary-lib.el: Use overlays rather than selective-display. (diary-selective-display): New var. (diary-header-line-format): Use it. (diary-list-entries): Add argument `list-only'. Put the buffer in diary-mode. Don't add \^M at beg and end. Replace \^M by invisible overlays. (diary-unhide-everything): Replace \^M by invisible overlays. (print-diary-entries): Look for overlays rather than \^M. Add a space to the temp buffer name. (diary-show-all-entries, mark-diary-entries, make-diary-entry): Put the buffer in diary-mode. (list-sexp-diary-entries): Replace \^M by invisible overlays. (diary-anniversary): Make the year arg optional. (diary-time-regexp): New const. (diary-font-lock-keywords): Use it to accept a few more time formats. * calendar/appt.el (appt-time-regexp): New var. (appt-add, appt-make-list): Use it. (appt-convert-time): Clean up. * calendar/timeclock.el (timeclock-ask-for-project): Follow convention for reading with the minibuffer. * calendar/calendar.el (mark-visible-calendar-date): Save excursion. Re-indent within 80 columns. Use inhibit-read-only. * calendar/diary-lib.el (mark-diary-entries): Rearrange to wrap with-current-buffer form in save-excursion. * calendar/timeclock.el (timeclock-status-string) (timeclock-workday-remaining-string, timeclock-workday-elapsed-string) (timeclock-when-to-leave-string): * calendar/icalendar.el (icalendar--convert-ical-to-diary): Fix `message' calls to ensure first arg is a format string. * calendar/cal-bahai.el (date, displayed-month, displayed-year) (number, original-date): * calendar/cal-china.el (date): * calendar/cal-coptic.el (date): * calendar/cal-french.el (date): * calendar/cal-hebrew.el (date, entry, number, original-date): * calendar/cal-islam.el (date, number, original-date): * calendar/cal-iso.el (date): * calendar/cal-julian.el (date): * calendar/cal-mayan.el (date): * calendar/cal-menu.el (date, event): * calendar/cal-persia.el (date): * calendar/lunar.el (date): * calendar/solar.el (date): Add defvars. * calendar/diary-lib.el (diary-modify-entry-list-string-function): New hook. (add-to-diary-list): Call `diary-modify-entry-list-string-function' * calendar/calendar.el (calendar-mode-map): Bind < and > usefully. * calendar/calendar.el (calendar-goto-hebrew-date) (calendar-goto-coptic-date, calendar-goto-ethiopic-date) (calendar-goto-persian-date): Delete duplicate duplicate words. * calendar/icalendar.el (icalendar--get-unfolded-buffer): * calendar/diary-lib.el (diary-header-line-format): Change space constants followed by a sexp to "?\s ". * calendar/diary-lib.el (diary-button): Remove "-face" suffix from face name. (diary-button-face): New backward-compatibility alias for renamed face. (diary-entry): Use renamed diary-button face. * calendar/calendar.el (diary, calendar-today, holiday) (mark-visible-calendar-date): Remove "-face" suffix from face names. (diary-face, calendar-today-face, holiday-face): New backward-compatibility aliases for renamed faces. (eval-after-load "facemenu", diary-entry-marker) (calendar-today-marker, calendar-holiday-marker, diary-face): Use renamed calendar faces. * calendar/diary-lib.el (mark-included-diary-files): Only kill included diary buffer if it was not already being visited. Reported by Stephen Berman <Stephen.Berman(a)gmx.net&gt;. * calendar/icalendar.el (top-level): Do not require appt. * calendar/todo-mode.el (todo-mode): Use kill-all-local-variables and run-mode-hooks. * calendar/cal-menu.el (cal-menu-update): Add separator as a string so that tmm doesn't create a completion entry for it. Replace `string-to-int' by `string-to-number'. * calendar/appt.el (appt-convert-time): * calendar/cal-bahai.el (mark-bahai-diary-entries): * calendar/cal-hebrew.el (mark-hebrew-diary-entries): * calendar/cal-islam.el (mark-islamic-diary-entries): * calendar/calendar.el (calendar-cursor-to-date) (calendar-star-date): * calendar/diary-lib.el (diary-attrtype-convert) (mark-diary-entries, diary-entry-time): * calendar/solar.el (solar-get-number): * calendar/solar.el (solar-data-list): Move definition up. * calendar/cal-bahai.el (mark-bahai-diary-entries): * calendar/icalendar.el (icalendar-version): Now at 0.12. (icalendar-duration-correction): Remove. (icalendar--get-event-properties): Split result at commas. (icalendar--decode-isoduration): New optional argument DURATION-CORRECTION. (icalendar--convert-ordinary-to-ical, icalendar--convert-sexp-to-ical) (icalendar--convert-yearly-to-ical, icalendar--convert-weekly-to-ical) (icalendar--convert-block-to-ical, icalendar--convert-float-to-ical) (icalendar--convert-date-to-ical, icalendar--convert-cyclic-to-ical) (icalendar--convert-anniversary-to-ical): New functions, extracted from icalendar-export-region, with bug fixes. (icalendar-export-region): Use the above functions. (icalendar-import-buffer): Check before saving diary file. (icalendar--convert-recurring-to-diary) (icalendar--convert-non-recurring-all-day-to-diary) (icalendar--convert-non-recurring-not-all-day-to-diary): New functions, extracted from icalendar--convert-ical-to-diary, with bug fixes. (icalendar--convert-ical-to-diary): Use the above functions. * calendar/calendar.el (diary-face): Add special case for displays supporting a high number of colors. * calendar/diary-lib.el (add-to-diary-list): MARKER argument made optional, to ensure backward compatibility. * calendar/timeclock.el (timeclock): Doc fix. * calendar/cal-china.el: Update reference to "Calendrical Calculations" book; there's a new edition. * calendar/cal-coptic.el: Likewise. * calendar/cal-french.el: Likewise. * calendar/cal-hebrew.el: Likewise. * calendar/cal-islam.el: Likewise. * calendar/cal-iso.el: Likewise. * calendar/cal-julian.el: Likewise. * calendar/cal-mayan.el: Likewise. * calendar/cal-persia.el: Likewise. * calendar/calendar.el: Likewise. * calendar/holidays.el: Likewise. * calendar/lunar.el: Likewise. * calendar/solar.el: Likewise. * calendar/calendar.el (calendar-day-abbrev-array): Remove trailing white space from doc string. * calendar/cal-x.el (calendar-one-frame-setup) (calendar-only-one-frame-setup, calendar-two-frame-setup): Use t rather than `symbol' for set-window-dedicated-p. * calendar/appt.el (appt-buffer-name): Make it a constant. (appt-add): Doc fix. * calendar/cal-menu.el (top level): Delete local C-down-mouse-3 binding. Suggested by Stephan Stahl <stahl(a)eos.franken.de&gt;. * calendar/cal-move.el (calendar-beginning-of-year): Move the cursor to Jan 1 when needed. (calendar-end-of-year): Fix -/+ typo. Reported by Chong Yidong <cyd(a)stupidchicken.com&gt;. * calendar/calendar.el: Replace `legal' with `valid'. * calendar/diary-lib.el (mark-diary-entries): Use new optional argument REDRAW rather than calendar-redrawing variable. * calendar/calendar.el (calendar-redrawing): Delete. (redraw-calendar): Do not bind calendar-redrawing. * calendar/diary-lib.el (diary-redraw-calendar): Preserve point in diary-file buffer. * calendar/calendar.el (calendar-redrawing): New internal variable. (redraw-calendar): Remove bogus save-excursion from previous change. Bind calendar-redrawing to t for mark-diary-entries. * calendar/diary-lib.el (mark-diary-entries): No need to redraw calendar if that is why we were called. * calendar/calendar.el (redraw-calendar): Preserve point. Reported by Matt Hodges <MPHodges(a)member.fsf.org&gt;. (calendar-week-start-day): Move after definition of redraw-calendar. Delete buffer test, since redraw-calendar has that now. * calendar/diary-lib.el (mark-diary-entries): Only call redraw-calendar in the first of any recursive calls. Reported by Alan Shutko <ats(a)acm.org&gt;. * calendar/icalendar.el (icalendar-version): Increase to 0.11. (icalendar-export-file, icalendar-export-region) (icalendar-import-file, icalendar-import-buffer): Add autoload cookies. (icalendar--convert-ical-to-diary): Fix problem with DURATION. * calendar/calendar.el (redraw-calendar): Work from any buffer, not just the calendar. * calendar/diary-lib.el (mark-diary-entries): Remove any old marks first. (diary-redraw-calendar): New function. (make-diary-entry): Add diary-redraw-calendar to local write-contents-functions. Turn off selective display before inserting in diary. * calendar/diary-lib.el (diary-remind): Discard any mark portion from diary-entry. Reported by Andrew Kemp <ajwk(a)pell.uklinux.net&gt;. * calendar/calendar.el (calendar-buffer): Move above calendar-week-start-day. (calendar-week-start-day): Doc fix. Add :set function. (calendar-minimum-window-height): New variable. (generate-calendar-window): Only resize window if selected-window is displaying the calendar buffer. Use new variable calendar-minimum-window-height. (generate-calendar): Reword error message. (calendar-mode-map): Bind DEL to scroll-other-window-down. * calendar/icalendar.el (icalendar--decode-isodatetime): New optional argument DAY-SHIFT. (icalendar-export-region): Fix coding-system-for-write. (icalendar--convert-ical-to-diary): Shift end-day of all-day events by one. * calendar/appt.el (appt-time-msg-list): 3rd elt of each appointment says it was explicitly made. (appt-add): Set the 3rd element. (appt-make-list): Preserve explicit appointments. * calendar/icalendar.el (icalendar--get-event-property): Doc fix. (icalendar--get-event-property-attributes) (icalendar--get-event-properties) (icalendar--datetime-to-diary-date): New functions. (icalendar--split-value): Doc fix. (icalendar--datetime-to-noneuropean-date) (icalendar--datetime-to-european-date): New optional argument SEPARATOR. Return result as a string instead of a list. (icalendar--get-weekday-number): Check if ABBREVWEEKDAY is nil. (icalendar--convert-string-for-export): Rename arg S to STRING. (icalendar-export-region): Doc fix. Change name of error buffer. Save output buffer. (icalendar-import-file): Add blank at end of prompt. (icalendar-import-buffer): Doc fix. Do not switch to error buffer. Indicate status in return value. (icalendar--convert-ical-to-diary): Doc fix. Change name of error buffer. Save output buffer. Handle exception from recurrence rules (EXDATE, EXRULE). Handle start- and end-date of recurring events. Fix problems with weekly all-day events. * calendar/diary-lib.el (mark-diary-entries): Set mark-diary-entries-in-calendar only after checking for diary-file. * calendar/calendar.el (view-other-diary-entries): Add autoload. * calendar/diary-lib.el (view-other-diary-entries): Use current-prefix-arg in interactive spec. * calendar/holidays.el (holiday-easter-etc): Make arguments optional for backwards compatibility. Doc fix. Remove un-necessary local vars mandatory, output-list. (holiday-advent): Make arguments optional for backwards compatibility. Doc fix. * calendar/diary-lib.el (diary-from-outlook) (diary-from-outlook-gnus, diary-from-outlook-rmail): Do not use interactive-p; but rather new optional argument NOCONFIRM. * calendar/icalendar.el (icalendar-version): Increase to 0.08. (icalendar--split-value): Change name of work buffer. (icalendar--get-weekday-abbrev): Return nil on error. (icalendar--date-to-isodate): New function. (icalendar-convert-diary-to-ical) (icalendar-extract-ical-from-buffer): Use only two args for make-obsolete (XEmacs compatibility). (icalendar-export-file, icalendar-import-file): Blank at end of prompt. (icalendar-export-region): Doc fix. If error, return non-nil and write errors to a buffer. Use correct weekday for weekly recurring events. Check whether date has been parsed for ordinary events. Make weekly events start in the year 2000. DTEND is non-inclusive, shift end date by one day if necessary (not for entries that have date and time). Rename local let variables: oops -> found-error, datestring -> startdatestring. * calendar/icalendar.el (icalendar--weekday-array): New constant. (icalendar-weekdayabbrev-table) (icalendar-monthnumber-table): Delete. (icalendar--get-month-number): Use calendar-month-name-array. (icalendar--get-weekday-number): New function. (icalendar--get-weekday-abbrev) Use calendar-day-name-array. (icalendar-export-region): Handle multi-line entries. (icalendar--convert-ical-to-diary): Use calendar-day-name-array. * calendar/icalendar.el: Set coding to utf-8. (icalendar-version): Increase to 0.07. (icalendar-monthnumber-table): Change March pattern. (icalendar-get-all-event-properties) (icalendar-set-event-property): Delete. (icalendar-all-events): No longer interactive. (icalendar-convert-diary-to-ical) (icalendar-extract-ical-from-buffer): Make obsolete, and alias to their replacements. (icalendar-export-file, icalendar-export-region): New functions; essentially old `icalendar-convert-diary-to-ical' but appending to target rather than overwriting. (icalendar-import-file): Append to target file rather than overwriting. Fourth arg deleted. (icalendar-import-buffer): New name for old `icalendar-extract-ical-from-buffer'. (icalendar--convert-string-for-import): New name for old `icalendar-convert-for-import'. (include-icalendar-files): Delete. Prefix for all internal functions changed from `icalendar-' to `icalendar--'. * calendar/icalendar.el: New file. * calendar/calendar.el (calendar-goto-iso-week): Add autoload. (calendar-mode-map): Add binding for `calendar-goto-iso-week'. * calendar/cal-menu.el (calendar-mode-map): Ditto. * calendar/cal-iso.el (calendar-iso-read-args): New function, for old interactive spec from calendar-goto-iso-date. (calendar-goto-iso-date): Use it. (calendar-goto-iso-week): New function. Suggested by Emilio C. Lopes <eclig(a)gmx.net&gt;. * calendar/diary-lib.el (list-diary-entries): Save diary buffer from diary display excursion. Store diary buffer's point for `simple-diary-display'. (simple-diary-display): Set window point and start when displaying buffer, to preserve point. * calendar/holidays.el (holiday-advent): Report on a specified day offset from advent, not just advent. (holiday-easter-etc): Report on one specified day offset from easter, not all easter holidays. Various Easter holidays moved to `christian-holidays' variable in calendar.el. * calendar/calendar.el (christian-holidays): Adapt for new behavior of `holiday-advent' and `holiday-easter-etc' functions. * calendar/cal-dst.el (calendar-time-from-absolute): Return a list of two integers, instead of a cons. * calendar/appt.el (appt-disp-window): Use `calendar-set-mode-line' for a centered mode-line. * calendar/appt.el (appt-disp-window): Do not split window excessively when `split-height-threshold' is low. * calendar/cal-bahai.el: New file, which adds support for the Baha'i calendar to Emacs. This calendar is based on a solar year of 19 months of 19 days, with 4 intercalary days. Each year begins on March 21, with the calendar starting in 1844. * calendar/cal-menu.el, calendar/calendar.el * calendar/diary-lib.el, calendar/holidays.el: Added support for using cal-bahai.el. * calendar/diary-lib.el (diary-outlook-formats): New variable. (diary-from-outlook-internal, diary-from-outlook) (diary-from-outlook-gnus, diary-from-outlook-rmail): New functions to import diary entries from Outlook-format appointments in mail messages. Use `time-less-p' from calendar/time-date.el instead of defining custom versions of it. * calendar/timeclock.el (timeclock-time-less-p): Remove. (timeclock-generate-report): Use `time-less-p'. * calendar/diary-lib.el (diary-mode, fancy-diary-display-mode): Derive from fundamental-mode rather than text-mode. * calendar/timeclock.el (timeclock-relative) (timeclock-get-project-function, timeclock-get-workday-function) (timeclock-query-out, timeclock-when-to-leave) (timeclock-when-to-leave-string, timeclock-log-data) (timeclock-generate-report, timeclock-in): Doc fixes. * calendar/appt.el (appt-check): Remove superfluous progn. When finished with diary buffer: if it was not being displayed before, kill it; otherwise restore its original state. Suggested by Matthew Mundell <matt(a)mundell.ukfsn.org&gt;. * calendar/calendar.el (calendar-set-mode-line): Use total available mode-line width, rather than frame-width. * calendar/diary-lib.el (fancy-diary-display): Set mode-line after mode change so effect not lost. * calendar/calendar.el (generate-calendar) (calendar-read-date): Prevent display of BC calendars once more - reverts 2003-10-01 change. (generate-calendar-month): Doc fix. * calendar/appt.el (appt-display-format): Change default to 'ignore, for backwards compatibility. (appt-display-message): If appt-display-format is 'ignore, respect old vars appt-msg-window and appt-visible. (appt-activate): Don't depend on return value of cancel-timer. * calendar/calendar.el (calendar-holidays): Doc fix. * calendar/appt.el (appt-check): Restore usage of appt-issue-message deleted in previous change. (top-level): Activate package when loaded (needed for backwards compatibility). * calendar/diary-lib.el (diary-entry-time): Fix typo/bug: Remove spurious left square bracket in XX:XXam regexp. * calendar/appt.el: Update copyright and commentary. (appt-issue-message): Make obsolete. (appt-visible, appt-msg-window): Make obsolete, in favor of appt-display-format. (appt-display-mode-line, appt-display-duration) (appt-display-diary, appt-time-msg-list, appt-mode-string) (appt-prev-comp-time, appt-display-count, appt-timer) (appt-convert-time): Doc change. (appt-disp-window-function, appt-delete-window-function): Use defcustom rather than defvar. (appt-display-format): New variable. (appt-display-message): New function with display code from appt-check. (appt-check): Add optional FORCE argument. Doc change. Add appt-make-list to diary-hook if displaying diary. Remove checking of view-diary-entries-initially. Message display section removed to new function appt-display-message. (appt-display-window): Doc change. Remove unused internal var this-buffer. Do not beep, since appt-display-message does that. (appt-make-list): Doc change. Use caar. (appt-sort-list): Simplify by using builtin sort function. (appt-update-list): New function for updating appts when diary is saved. (appt-activate): New autoloaded function to toggle package functionality. * calendar/cal-x.el: (calendar-one-frame-setup) (calendar-only-one-frame-setup, calendar-two-frame-setup): Doc change. * calendar/calendar.el: Update copyright. (view-diary-entries-initially, european-calendar-style): Doc change. (calendar-setup): Make defcustom rather than defvar. (mark-visible-calendar-date): Initialize temp-face and faceinfo in let binding so local to function. * calendar/diary-lib.el: Update copyright. (diary, diary-entry-time): Doc change. (list-diary-entries): Doc change. Trivial logic change. (fancy-diary-display): Restore make-face command mistakenly deleted 2003-05-08. (show-all-diary-entries): Allow to pop-up frame if needed. * calendar/diary-lib.el (diary-entry-time): Also accept time in the form XX[.XX][am/pm/AM/PM]. (fancy-diary-font-lock-keywords): Likewise. (diary-font-lock-keywords): Likewise. * calendar/appt.el (appt-add): Likewise. (appt-make-list): Likewise. (appt-convert-time): Likewise. * calendar/calendar.el (increment-calendar-month) (calendar-leap-year-p, calendar-absolute-from-gregorian) (generate-calendar, calendar-read-date, calendar-interval) (calendar-day-of-week): Handle years BC. (generate-calendar-month, calendar-gregorian-from-absolute): Doc fix. * calendar/diary-lib.el (diary-header-line-flag) (diary-header-line-format): New variables. (list-diary-entries): Use them to set header line in simple diary. * calendar/diary-lib.el (simple-diary-display, make-diary-entry): Allow the diary to pop up a new frame, if needed. * calendar/calendar.el (calendar-make-alist): Correct off-by-one keeping December out of the alist. * calendar/cal-move.el (calendar-goto-day-of-year): New function. * calendar/calendar.el (calendar-mode-map): Bind it to key. * calendar/cal-menu.el (calendar-mode-map): Add it to menu. (calendar-flatten): New function. (calendar-mouse-view-other-diary-entries) (calendar-mouse-view-diary-entries): Rewritten to put any holidays in the menu title and to show multi-line diary entries correctly in the menu. * calendar/calendar.el (list-diary-entries-hook) (diary-display-hook, nongregorian-diary-listing-hook) (mark-diary-entries-hook, nongregorian-diary-marking-hook): Add some customize options for these hooks. (calendar-abbrev-construct): Don't try to take a substring longer than the original string. * calendar/calendar.el (diary-file, diary-file-name-prefix) (european-calendar-style, diary-date-forms) (calendar-day-name-array, calendar-month-name-array): Doc change. (generate-calendar-month): Adapt for new behavior of `calendar-day-name' function. (calendar-abbrev-length, calendar-day-abbrev-array) (calendar-month-abbrev-array): New variables. (calendar-abbrev-construct): New function. (calendar-day-name, calendar-month-name): Use new abbrev arrays, rather than fixing abbrevs at some width. Calling syntax change. (calendar-make-alist): Use abbrev arrays. Calling syntax change. (calendar-date-string): Adapt for new behaviors of `calendar-day-name' and `calendar-month-name' functions. * calendar/diary-lib.el (list-diary-entries): Adapt for new behavior of `calendar-day-name' and `calendar-month-name' functions. (diary-name-pattern): Use abbrev arrays, rather than fixing abbrevs at three chars. Calling syntax change. (mark-diary-entries): Adapt for new behaviors of `diary-name-pattern' and `calendar-make-alist' functions. (fancy-diary-font-lock-keywords): Adapt for new behavior of `diary-name-pattern' function. (font-lock-diary-date-forms): Use abbrev arrays, rather than fixing abbrevs at three chars. Calling syntax change. (cal-hebrew, cal-islam): Require when compiling. (diary-font-lock-keywords): Adapt for new behavior of `font-lock-diary-date-forms' function. * calendar/cal-hebrew.el: Reposition some code so defined before used. (calendar-hebrew-month-name-array-common-year) (calendar-hebrew-month-name-array-leap-year): Add doc strings. (list-hebrew-diary-entries): Adapt for new behaviors of `calendar-day-name' and `add-to-diary-list' functions. (mark-hebrew-diary-entries): Adapt for new behaviors of `diary-name-pattern' and `calendar-make-alist' functions. * calendar/cal-islam.el (calendar-islamic-month-name-array): Add doc string. (list-islamic-diary-entries): Adapt for new behaviors of `calendar-day-name' and `add-to-diary-list' functions. (mark-islamic-diary-entries): Adapt for new behaviors of `diary-name-pattern' and `calendar-make-alist' functions. * calendar/cal-menu.el (cal-menu-update): Adapt for new behavior of `calendar-month-name' function. * calendar/cal-coptic.el (coptic-name): defvar rather than defconst. * calendar/solar.el (solar-seasons-data): Move definition before use. * calendar/cal-tex.el (cal-tex-day-name-format): Doc fix. (cal-tex-LaTeX-hourbox): Move definition before use. * calendar/cal-china.el, cal-hebrew.el, cal-islam.el * cal-julian.el, cal-menu.el, cal-move.el, holidays.el * lunar.el, solar.el (displayed-month, displayed-year): Define for compiler. * calendar/timeclock.el (timeclock-relative) (timeclock-ask-before-exiting, timeclock-use-display-time): Doc changes. (timeclock-modeline-display): Give a message if `timeclock-use-display-time' is non-nil but `display-time-mode' is not active. * calendar/timeclock.el (timeclock-use-display-time) (timeclock-day-over-hook, timeclock-workday-remaining) (timeclock-status-string, timeclock-when-to-leave) (timeclock-when-to-leave-string, timeclock-log-data) (timeclock-find-discrep, timeclock-day-base) (timeclock-generate-report, timeclock-visit-timelog): Doc fix. (timeclock-modeline-display): Set the variable `timeclock-modeline-display'. (timeclock-update-modeline): Doc fix. Respect value of `timeclock-relative'. * calendar/diary-lib.el (diary-check-diary-file): New function. (diary, view-diary-entries, show-all-diary-entries) (mark-diary-entries): Use it. (view-other-diary-entries): Doc fix. Use `prefix-numeric-value'. (diary-syntax-table, diary-attrtype-convert, diary-mail-days): Doc fix. (diary-modified, d-file): No need to defvar (for compiler). (list-diary-entries): No need for `let*' so use `let'. (simple-diary-display): Use `diary-file' directly rather than inheriting `d-file' from `list-diary-entries' caller. (make-fancy-diary-buffer, show-all-diary-entries): `mode-line-format' already buffer-local. (diary-mail-addr): Set to the empty string (rather than nil) if undefined, as per `user-mail-address'. (diary-mail-entries): Doc fix. Error if `diary-mail-address' unset. (mark-sexp-diary-entries): Don't regexp-quote sexp-mark twice. Remove an un-needed `if'. (list-sexp-diary-entries): Remove local vars mark and s-entry, and use `let' rather than `let*'. (diary-date, insert-monthly-diary-entry) (insert-yearly-diary-entry, insert-anniversary-diary-entry) (insert-block-diary-entry, insert-cyclic-diary-entry) (font-lock-diary-date-forms): No need for `let*' so use `let'. (make-diary-entry): Doc fix. Use `or' rather than `if'. (diary-font-lock-keywords): Use `when'. `cal-islam' is required feature, not `cal-islamic'. `calendar-islamic-month-name-array-leap-year' does not exist - use `calendar-islamic-month-name-array'. * calendar/timeclock.el (display-time-hook) (timeclock-modeline-display): Define for byte-compiler. (timeclock-time-to-date, timeclock-workday-remaining) (timeclock-time-to-seconds, timeclock-seconds-to-time): Move earlier in the file so defined before used. (timeclock-status-string): No need for `let*' so use `let'. (timeclock-query-out): Always return a non-nil value. * calendar/timeclock.el: Update copyright. (timeclock-ask-before-exiting): Put `timeclock-query-out' on `kill-emacs-query-functions' rather than `kill-emacs-hook'. (timeclock-mode-string): Doc fix. (timeclock-modeline-display): Doc fix. Use `global-mode-string' rather than `mode-line-format'. (timeclock-query-out): Doc fix. (timeclock-update-modeline): No need for `let*', so use `let'. Add some help-echo text to `timeclock-mode-string'. (timeclock-mode-string): Give it the risky-local-variable property, so that help-echo text will display. (timeclock-find-discrep): Set `accum' to 0 if `timeclock-discrepancy' is nil. (diary-mail-entries): There is no fancy-diary-buffer if there are no diary entries. Use call-interactively. * calendar/diary-lib.el (diary-pull-attrs): Make `ret-attr', `attr' local. (list-diary-entries): Make `temp' local. (fancy-diary-display): Make `marks', `temp-face', `faceinfo' local. (mark-diary-entries): Make `temp' local. (mark-sexp-diary-entries): Make `marks' local, remove `temp'. (list-sexp-diary-entries): Make `temp' local. (add-to-diary-list): Make `prefix' local. * calendar/diary-lib.el (fancy-diary-display-mode): Bind "q" to `quit-window' in the fancy diary buffer. Face markup of calendar and diary displays: Any entry line that ends with [foo:value] where foo is a face attribute (except :box :stipple) or with [face:blah] tags, will have these values applied to the calendar and fancy diary displays. These attributes "stack" on calendar displays. File-wide attributes can be defined as follows: the first line matching "^# [tag:value]" defines the value for that particular tag. All of the tags' regexps can be customized. * calendar/calendar.el (diary-face-attrs): New custom. (diary-file-name-prefix-function): New custom. (diary-glob-file-regexp-prefix): New custom. (diary-file-name-prefix): New custom. (generate-calendar-window): Check that font-lock-mode is bound before checking value. (mark-visible-calendar-date): Add the ability to pass face attribute/value pairs in the mark argument. Handle the mark. * calendar/diary-lib.el (diary-attrtype-convert): Convert an attribute value string to the desired type. (diary-pull-attrs): New function that pulls the attributes off a diary entry, merges with file-global attributes, and returns the (possibly modified) entry and a list of attribute/values using diary-attrtype-convert. (list-diary-entries, fancy-diary-display, show-all-diary-entries) (mark-diary-entries, mark-sexp-diary-entries) (list-sexp-diary-entries): Add handling of file-global attributes; add handling of entry attributes using diary-pull-attrs. (mark-calendar-days-named, mark-calendar-days-named) (mark-calendar-date-pattern, mark-calendar-month) (add-to-diary-list): Add optional paramater `color' for passing face attribute info through the callchain. Pass this parameter around. * calendar/calendar.el (calendar-only-one-frame-setup): Autoload it. * calendar/calendar.el (calendar-day-name): Move defn down. * calendar/calendar.el (facemenu-unlisted-faces): Only update after facemenu is loaded. (calendar-font-lock-keywords): Accept non-ASCII month names. Use regexp-opt. * calendar/solar.el (solar-atn2): Give correct quadrant for arctan. * calendar/diary-lib.el (fancy-diary-font-lock-keywords): Grok month numbers, too. * calendar/diary-lib.el (list-diary-entries): Pass a marker indicating source of entry to add-to-diary-list. (list-sexp-diary-entries): Pass a marker indicating source of entry to add-to-diary-list. (diary-date): Return mark as well as entry. (add-to-diary-list): Add new marker argument, appended to diary-entries-list. (diary-mode, fancy-diary-display-mode): New derived modes, for diary file and fancy diary buffer respectively. (fancy-diary-font-lock-keywords, diary-font-lock-keywords): New variables. (font-lock-diary-sexps, font-lock-diary-date-forms): New functions, used in diary-font-lock-keywords. * calendar/calendar.el (diary-face): New. (calendar-mode): Set up font-lock mode, using new variable calendar-font-lock-keywords. (generate-calendar-window): Fontify if font-lock-mode is on. (calendar-font-lock-keywords): New variable. * calendar/diary-lib.el (diary-button-face, diary-entry, diary-goto-entry): New, to support click to diary file. (fancy-diary-display): Buttonize diary entries. Use new mode fancy-diary-display-mode. calendar source patch: Diff command: cvs -q diff -uN Files affected: todo-mode.el timeclock.el solar.el lunar.el icalendar.el holidays.el diary-lib.el calendar.el cal-xemacs.el cal-x.el cal-tex.el cal-persia.el cal-move.el cal-mayan.el cal-julian.el cal-japanese.el cal-iso.el cal-islam.el cal-hebrew.el cal-french.el cal-dst.el cal-coptic.el cal-compat.el cal-china.el appt.el Makefile Index: Makefile =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/Makefile,v retrieving revision 1.34 diff -u -u -r1.34 Makefile --- Makefile 2006/08/21 06:06:30 1.34 +++ Makefile 2006/10/20 21:46:43 ＠＠ -31,7 +31,7 ＠＠ cal-xemacs.elc calendar.elc diary-lib.elc holidays.elc cal-tex.elc \ cal-hebrew.elc cal-islam.elc cal-iso.elc cal-move.elc cal-persia.elc\ cal-china.elc cal-coptic.elc cal-julian.elc lunar.elc solar.elc \ - todo-mode.elc timeclock.elc + todo-mode.elc timeclock.elc cal-bahai.elc icalendar.elc cal-compat.elc ifeq ($(BUILD_WITHOUT_MULE),) ELCS += cal-japanese.elc Index: appt.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/appt.el,v retrieving revision 1.11 diff -u -u -r1.11 appt.el --- appt.el 2006/08/04 20:23:50 1.11 +++ appt.el 2006/10/20 21:46:44 ＠＠ -1,12 +1,12 ＠＠ ;;; appt.el --- appointment notification functions -;; Keywords: calendar -;; Copyright (C) 1989, 1990, 1994, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1990, 1994, 1998, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Neil Mager <neilm(a)juliet.ll.mit.edu&gt; -;; Maintainer: FSF +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar - + ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify ＠＠ -21,145 +21,84 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ;; ;; appt.el - visible and/or audible notification of -;; appointments from ~/diary file. +;; appointments from diary file. ;; ;;; -;;; Thanks to Edward M. Reingold for much help and many suggestions, +;;; Thanks to Edward M. Reingold for much help and many suggestions, ;;; And to many others for bug fixes and suggestions. ;;; ;;; -;;; This functions in this file will alert the user of a -;;; pending appointment based on their diary file. +;;; This functions in this file will alert the user of a +;;; pending appointment based on his/her diary file. This package +;;; is documented in the Emacs manual. +;;; +;;; To activate this package, simply use (appt-activate 1). +;;; A `diary-file' with appointments of the format described in the +;;; documentation of the function `appt-check' is required. +;;; Relevant customizable variables are also listed in the +;;; documentation of that function. +;;; +;;; Today's appointment list is initialized from the diary when this +;;; package is activated. Additionally, the appointments list is +;;; recreated automatically at 12:01am for those who do not logout +;;; every day or are programming late. It is also updated when the +;;; `diary-file' is saved. Calling `appt-check' with an argument forces +;;; a re-initialization at any time. ;;; -;;; ******* It is necessary to invoke 'appt-initialize' for this -;;; ******* to work properly. -;;; -;;; A message will be displayed in the mode line of the Emacs buffer -;;; and (if you request) the terminal will beep and display a message -;;; from the diary in the mini-buffer, or you can choose to -;;; have a message displayed in a new buffer. -;;; -;;; Variables of note: -;;; -;;; appt-issue-message If this variable is nil, then the code in this -;;; file does nothing. -;;; appt-msg-countdown-list Specifies how much warning you want before -;;; appointments. -;;; appt-audible Whether to beep when it's notification-time. -;;; appt-display-mode-line Whether to display a countdown to the next -;;; appointment in the mode-line. -;;; appt-announce-method The function used to do the notifications. -;;; 'appt-window-announce do it in a pop-up window. -;;; 'appt-frame-announce do it in a pop-up frame (v19 only) -;;; 'appt-message-announce do it in the echo area. -;;; 'appt-persistent-message-announce do it in the echo area, but make the -;;; messages not go away at the next keystroke. -;;; appt-display-duration If appt-announce-method is set to the function -;;; 'appt-window-announce, this specifies how many -;;; seconds the pop-up window should stick around. -;;; -;;; In order to use this, create a diary file, and add the following to your -;;; .emacs file: -;;; -;;; (require 'appt) -;;; (appt-initialize) -;;; -;;; If you wish to see a list of appointments, or a full calendar, when emacs -;;; starts up, you can add a call to (diary) or (calendar) after this. -;;; -;;; This is an example of what can be in your diary file: -;;; Monday -;;; 9:30am Coffee break -;;; 12:00pm Lunch -;;; -;;; Based upon the above lines in your .emacs and diary files, -;;; the calendar and diary will be displayed when you enter -;;; Emacs and your appointments list will automatically be created. -;;; You will then be reminded at 9:20am about your coffee break -;;; and at 11:50am to go to lunch. -;;; -;;; In order to interactively add or delete items from today's list, use -;;; Meta-x appt-add and Meta-x appt-delete. (This does not modify your -;;; diary file, so these will be forgotten when you exit emacs.) -;;; -;;; Additionally, the appointments list is recreated automatically -;;; at 12:01am for those who do not logout every day or are programming -;;; late. -;;; -;;; You can have special appointments which execute arbitrary code rather than -;;; simply notifying you -- sort of like the unix "cron" facility. The syntax -;;; for this is borrowed from the Calendar's special-date format. If you have -;;; a diary entry like -;;; -;;; Monday -;;; 3:00am %%(save-all-modified-buffers) -;;; -;;; then on monday at 3AM, the function `save-all-modified-buffers' will be -;;; invoked. (Presumably this function is defined in your .emacs file.) -;;; There will be no notification that these "special" appointments are being -;;; triggered, unless the form evaluated produces a notification. -;;; -;;; It is necessary for the entire list after the "%%" to be on one line in -;;; your .diary file -- there may not be embedded newlines in it. This is a -;;; bit of a misfeature. +;;; In order to add or delete items from today's list, without +;;; changing the diary file, use `appt-add' and `appt-delete'. ;;; -;;; This also interacts correctly with Benjamin Pierce's reportmail.el package. -;;; + ;;; Brief internal description - Skip this if you are not interested! ;;; -;;; The function appt-initialize invokes 'diary' to get a list of today's -;;; appointments, and parses the lines beginning with date descriptions. -;;; This list is cached away. 'diary' is invoked in such a way so as to -;;; not pop up a window displaying the diary buffer. -;;; -;;; The function appt-check is run from the 'loadst' process (or the 'wakeup' -;;; process in emacs 18.57 or newer) which is started by invoking display-time. -;;; It checks this cached list, and announces as appropriate. At midnight, -;;; appt-initialize is called again to rebuild this list. -;;; -;;; display-time-filter is modified to invoke appt-check. -;;; -;;; TO DO: -;;; -;;; o multiple adjacent appointments are not handled gracefully. If there -;;; is an appointment at 3:30 and another at 3:35, and you have set things -;;; up so that you get a notification twenty minutes before each appt, -;;; then a notification should come at 3:10 for the first appt, and at -;;; 3:15 for the second. Currently, no notifications are generated for an -;;; appointment until all preceding appointments have completely expired. -;;; -;;; o If there are two appointments at the same time, all but the first are -;;; ignored (not announced.) -;;; -;;; o Appointments which are early enough in the morning that their -;;; announcements should begin before midnight are not announced until -;;; midnight. +;;; The function `appt-make-list' creates the appointments list which +;;; `appt-check' reads. ;;; -;;; o There should be some way to mark certain appointments as "important," -;;; so that you will be harassed about them even after they have expired. +;;; You can change the way the appointment window is created/deleted by +;;; setting the variables +;;; +;;; appt-disp-window-function +;;; and +;;; appt-delete-window-function +;;; +;;; For instance, these variables could be set to functions that display +;;; appointments in pop-up frames, which are lowered or iconified after +;;; `appt-display-interval' minutes. +;;; ;;; Code: ;; Make sure calendar is loaded when we compile this. (require 'calendar) -(provide 'appt) +;; XEmacs - this helps quiet the byte-compiler +(eval-when-compile + (require 'diary-lib)) +(defvar diary-selective-display) + ;;;###autoload (defcustom appt-issue-message t "*Non-nil means check for appointments in the diary buffer. -To be detected, the diary entry must have the time -as the first thing on a line." +To be detected, the diary entry must have the format described in the +documentation of the function `appt-check'." :type 'boolean :group 'appt) +;; XEmacs - only use the 2 arg form. +(make-obsolete-variable 'appt-issue-message + "use the function `appt-activate', and the \ +variable `appt-display-format' instead.") + ;;;###autoload (defcustom appt-message-warning-time 12 "*Time in minutes before an appointment that the warning begins." ＠＠ -171,57 +110,78 ＠＠ "*Non-nil means beep to indicate appointment." :type 'boolean :group 'appt) - + ;;;###autoload (defcustom appt-visible t - "*Non-nil means display appointment message in echo area." + "*Non-nil means display appointment message in echo area. +This variable is only relevant if `appt-msg-window' is nil." :type 'boolean :group 'appt) - + +;; XEmacs - only use the 2 arg form. +(make-obsolete-variable 'appt-visible 'appt-display-format) + ;;;###autoload -(defcustom appt-audible t - "*Controls whether appointment announcements should beep. -Appt uses two sound-types for beeps: `appt' and `appt-final'. -If this is a number, then that many beeps will occur. -If this is a cons, the car is how many beeps, and the cdr is the - delay between them (a float, fraction of a second to sleep.) -See also the variable `appt-msg-countdown-list'" +(defcustom appt-msg-window t + "*Non-nil means display appointment message in another window. +If non-nil, this variable overrides `appt-visible'." :type 'boolean :group 'appt) +;; XEmacs - only use the 2 arg form. +(make-obsolete-variable 'appt-msg-window 'appt-display-format) + + ;;;###autoload +;(defcustom appt-audible t +; "*Controls whether appointment announcements should beep. +;Appt uses two sound-types for beeps: `appt' and `appt-final'. +;If this is a number, then that many beeps will occur. +;If this is a cons, the car is how many beeps, and the cdr is the +; delay between them (a float, fraction of a second to sleep.) +;See also the variable `appt-msg-countdown-list'" +;:type 'boolean +;:group 'appt) + +;; TODO - add popup. +(defcustom appt-display-format 'ignore + "How appointment reminders should be displayed. +The options are: + window - use a separate window + echo - use the echo area + nil - no visible reminder. +See also `appt-audible' and `appt-display-mode-line'. + +The default value is 'ignore, which means to fall back on the value +of the (obsolete) variables `appt-msg-window' and `appt-visible'." +:type '(choice + (const :tag "Separate window" window) + (const :tag "Echo-area" echo) + (const :tag "No visible display" nil) + (const :tag "Backwards compatibility setting - choose another value" + ignore)) +:group 'appt +:version "22.1") + +;;;###autoload (defcustom appt-display-mode-line t - "*Non-nil means display minutes to appointment and time on the mode line." + "*Non-nil means display minutes to appointment and time on the mode line. +This is in addition to any other display of appointment messages." :type 'boolean :group 'appt) ;;;###autoload -(defcustom appt-msg-window t - "*Non-nil means display appointment message in another window." -:type 'boolean -:group 'appt) - -;;;###autoload (defcustom appt-display-duration 10 - "*The number of seconds an appointment message is displayed." + "*The number of seconds an appointment message is displayed. +Only relevant if reminders are to be displayed in their own window." :type 'integer :group 'appt) ;;;###autoload (defcustom appt-display-diary t - "*Non-nil means to display the next days diary on the screen. + "*Non-nil displays the diary when the appointment list is first initialized. This will occur at midnight when the appointment list is updated." -:type 'boolean -:group 'appt) - -(defcustom appt-announce-method 'appt-window-announce - "*The name of the function used to notify the user of an impending -appointment. This is called with two arguments, the number of minutes -until the appointment, and the appointment description list. - -Reasonable values for this variable are 'appt-window-announce, -'appt-message-announce, or 'appt-persistent-message-announce." -:type 'function +:type 'boolean :group 'appt) (defcustom appt-make-list-hook nil ＠＠ -231,110 +191,130 ＠＠ :type 'hook :group 'appt) -(defvar appt-time-msg-list nil - "The list of appointments for today. -Use `appt-add' and `appt-delete' to add and delete appointments from list. -The original list is generated from the today's `diary-entries-list'. -The number before each time/message is the time in minutes from midnight.") -(defconst appt-max-time 1439 - "11:59pm in minutes - number of minutes in a day minus 1.") - - + ;;; Announcement methods -(defun appt-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer." - (message (if (eq min-to-app 0) "App't NOW." - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt)))))) - -(defun appt-persistent-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer, but have those -messages stay around even if you type something (unlike normal messages)." - (let ((str (if (eq min-to-app 0) - (format "App't NOW -- %s" (car (cdr appt))) - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt))))) - (in-echo-area-already (eq (selected-window) (minibuffer-window)))) - (if (not in-echo-area-already) - ;; don't stomp the echo-area-buffer if reading from the minibuffer now. - (save-excursion - (save-window-excursion - (select-window (minibuffer-window)) - (delete-region (point-min) (point-max)) - (insert str)))) - ;; if we're reading from the echo-area, and all we were going to do is - ;; clear the thing, like, don't bother, that's annoying. - (if (and in-echo-area-already (string= "" str)) - nil - (message "%s" str)) - )) +;(defun appt-message-announce (min-to-app appt) +; "Set appt-announce-method to the name of this function to cause appointment +;notifications to be given via messages in the minibuffer." +; (message (if (eq min-to-app 0) "App't NOW." +; (format "App't in %d minute%s -- %s" +; min-to-app +; (if (eq 1 min-to-app) "" "s") +; (car (cdr appt)))))) + +;(defun appt-persistent-message-announce (min-to-app appt) +; "Set appt-announce-method to the name of this function to cause appointment +;notifications to be given via messages in the minibuffer, but have those +;messages stay around even if you type something (unlike normal messages)." +; (let ((str (if (eq min-to-app 0) +; (format "App't NOW -- %s" (car (cdr appt))) +; (format "App't in %d minute%s -- %s" +; min-to-app +; (if (eq 1 min-to-app) "" "s") +; (car (cdr appt))))) +; (in-echo-area-already (eq (selected-window) (minibuffer-window)))) +; (if (not in-echo-area-already) +; ;; don't stomp the echo-area-buffer if reading from the minibuffer now. +; (save-excursion +; (save-window-excursion +; (select-window (minibuffer-window)) +; (delete-region (point-min) (point-max)) +; (insert str)))) +; ;; if we're reading from the echo-area, and all we were going to do is +; ;; clear the thing, like, don't bother, that's annoying. +; (if (and in-echo-area-already (string= "" str)) +; nil +; (message "%s" str)) +; )) (defcustom appt-display-interval 3 "*Number of minutes to wait between checking the appointment list." -:type 'integer -:group 'appt) - -(defvar appt-buffer-name " *appt-buf*" +:type 'integer +:group 'appt) + +(defcustom appt-disp-window-function 'appt-disp-window + "Function called to display appointment window. +Only relevant if reminders are being displayed in a window." +:type '(choice (const appt-disp-window) + function) +:group 'appt) + +(defcustom appt-delete-window-function 'appt-delete-window + "Function called to remove appointment window and buffer. +Only relevant if reminders are being displayed in a window." +:type '(choice (const appt-delete-window) + function) +:group 'appt) + + +;;; Internal variables below this point. + +(defconst appt-buffer-name " *appt-buf*" "Name of the appointments buffer.") -(defun appt-frame-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in a pop-up frame." - (let () - (save-excursion - (set-buffer (get-buffer-create appt-buffer-name)) - (erase-buffer) - ;; set the mode-line of the pop-up window - (setq modeline-format - (concat "-------------------- Appointment " - (if (eq min-to-app 0) - "NOW" - (concat "in " (format "%s" min-to-app) - (if (eq min-to-app 1) " minute" " minutes"))) - ". (" - (let ((h (string-to-int - (substring (current-time-string) 11 13)))) - (concat (if (> h 12) (format "%s" (- h 12)) - (format "%s" h)) ":" - (substring (current-time-string) 14 16) - (if (< h 12) "am" "pm"))) - ") %-")) - (insert (car (cdr appt))) - (let ((height (max 10 (min 20 (+ 2 (count-lines (point-min) - (point-max))))))) - ;; If we already have a frame constructed, use it. If not, or it has - ;; been deleted, then make a new one - (if (and appt-disp-frame (frame-live-p appt-disp-frame)) - (let ((s (selected-frame))) - (select-frame appt-disp-frame) - (make-frame-visible appt-disp-frame) - (set-frame-height appt-disp-frame height) - (sit-for 0) - (select-frame s)) - (progn - (setq appt-disp-frame (make-frame)) - (set-frame-height appt-disp-frame height) - ) - ) - ;; make the buffer visible in the frame - ;; and make the frame visible - (let ((pop-up-windows nil)) - (pop-to-buffer (get-buffer appt-buffer-name) - nil - appt-disp-frame) - (make-frame-visible appt-disp-frame)) - ) - ) - ) - ) +(defvar appt-time-msg-list nil + "The list of appointments for today. +Use `appt-add' and `appt-delete' to add and delete appointments. +The original list is generated from today's `diary-entries-list', and +can be regenerated using the function `appt-check'. +Each element of the generated list has the form (MINUTES STRING [FLAG]); where +MINUTES is the time in minutes of the appointment after midnight, and +STRING is the description of the appointment. +FLAG, if non-nil, says that the element was made with `appt-add' +so calling `appt-make-list' again should preserve it.") + +;(defun appt-frame-announce (min-to-app appt) +; "Set appt-announce-method to the name of this function to cause appointment +;notifications to be given via messages in a pop-up frame." +; (let () +; (save-excursion +; (set-buffer (get-buffer-create appt-buffer-name)) +; (erase-buffer) +; ;; set the mode-line of the pop-up window +; (setq modeline-format +; (concat "-------------------- Appointment " +; (if (eq min-to-app 0) +; "NOW" +; (concat "in " (format "%s" min-to-app) +; (if (eq min-to-app 1) " minute" " minutes"))) +; ". (" +; (let ((h (string-to-int +; (substring (current-time-string) 11 13)))) +; (concat (if (> h 12) (format "%s" (- h 12)) +; (format "%s" h)) ":" +; (substring (current-time-string) 14 16) +; (if (< h 12) "am" "pm"))) +; ") %-")) +; (insert (car (cdr appt))) +; (let ((height (max 10 (min 20 (+ 2 (count-lines (point-min) +; (point-max))))))) +; ;; If we already have a frame constructed, use it. If not, or it has +; ;; been deleted, then make a new one +; (if (and appt-disp-frame (frame-live-p appt-disp-frame)) +; (let ((s (selected-frame))) +; (select-frame appt-disp-frame) +; (make-frame-visible appt-disp-frame) +; (set-frame-height appt-disp-frame height) +; (sit-for 0) +; (select-frame s)) +; (progn +; (setq appt-disp-frame (make-frame)) +; (set-frame-height appt-disp-frame height) +; ) +; ) +; ;; make the buffer visible in the frame +; ;; and make the frame visible +; (let ((pop-up-windows nil)) +; (pop-to-buffer (get-buffer appt-buffer-name) +; nil +; appt-disp-frame) +; (make-frame-visible appt-disp-frame)) +; ) +; ) +; ) +; ) (defalias 'appt-screen-announce 'appt-frame-announce) ;;; To display stuff in the mode line, we use a new variable instead of ＠＠ -346,29 +326,29 ＠＠ :type 'string :group 'appt) -(defun appt-display-mode-line (min-to-app) - "Add an appointment annotation to the mode line." - (setq appt-mode-line-string - (if (and appt-display-mode-line min-to-app) - (if (eq 0 min-to-app) - "App't NOW " - (concat "App't in " (format "%s" min-to-app) - (if (eq 1 min-to-app) " minute " " minutes "))) - "")) - ;; make sure our variable is visible in global-mode-string. - (cond ((not appt-display-mode-line) nil) - ((null global-mode-string) - (setq global-mode-string (list "" 'appt-mode-line-string))) - ((stringp global-mode-string) - (setq global-mode-string - (list global-mode-string 'appt-mode-line-string))) - ((not (memq 'appt-mode-line-string global-mode-string)) - (setq global-mode-string - (append global-mode-string (list 'appt-mode-line-string))))) - ;; force mode line updates - from time.el - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p)) - (sit-for 0)) +;(defun appt-display-mode-line (min-to-app) +; "Add an appointment annotation to the mode line." +; (setq appt-mode-line-string +; (if (and appt-display-mode-line min-to-app) +; (if (eq 0 min-to-app) +; "App't NOW " +; (concat "App't in " (format "%s" min-to-app) +; (if (eq 1 min-to-app) " minute " " minutes "))) +; "")) +; ;; make sure our variable is visible in global-mode-string. +; (cond ((not appt-display-mode-line) nil) +; ((null global-mode-string) +; (setq global-mode-string (list "" 'appt-mode-line-string))) +; ((stringp global-mode-string) +; (setq global-mode-string +; (list global-mode-string 'appt-mode-line-string))) +; ((not (memq 'appt-mode-line-string global-mode-string)) +; (setq global-mode-string +; (append global-mode-string (list 'appt-mode-line-string))))) +; ;; force mode line updates - from time.el +; (save-excursion (set-buffer (other-buffer))) +; (set-buffer-modified-p (buffer-modified-p)) +; (sit-for 0))  ;;; Internal stuff ＠＠ -432,104 +412,127 ＠＠ (sleep-for j) (setq i (1- i))))) (t (beep)))) - -(defvar appt-disp-window-function 'appt-disp-window - "Function called to display appointment window.") -(defvar appt-delete-window-function 'appt-delete-window - "Function called to remove appointment window and buffer.") +(defconst appt-max-time (1- (* 24 60)) + "11:59pm in minutes - number of minutes in a day minus 1.") (defvar appt-mode-string nil "String being displayed in the mode line saying you have an appointment. -The actual string includes the amount of time till the appointment.") +The actual string includes the amount of time till the appointment. +Only used if `appt-display-mode-line' is non-nil.") (defvar appt-prev-comp-time nil - "Time of day (mins since midnight) at which we last checked appointments.") + "Time of day (mins since midnight) at which we last checked appointments. +A nil value forces the diary file to be (re-)checked for appointments.") (defvar appt-now-displayed nil "Non-nil when we have started notifying about a appointment that is near.") + +(defvar appt-display-count nil + "Internal variable used to count number of consecutive reminders.") + +(defvar appt-timer nil + "Timer used for diary appointment notifications (`appt-check'). +If this is non-nil, appointment checking is active.") + + +;;; Functions. + +(defun appt-display-message (string mins) + "Display a reminder about an appointment. +The string STRING describes the appointment, due in integer MINS minutes. +The format of the visible reminder is controlled by `appt-display-format'. +The variable `appt-audible' controls the audible reminder." + ;; let binding for backwards compatability. Remove when obsolete + ;; vars appt-msg-window and appt-visible are dropped. + (let ((appt-display-format + (if (eq appt-display-format 'ignore) + (cond (appt-msg-window 'window) + (appt-visible 'echo)) + appt-display-format))) + (cond ((eq appt-display-format 'window) + (funcall appt-disp-window-function + (number-to-string mins) + ;; TODO - use calendar-month-abbrev-array rather + ;; than %b? + (format-time-string "%a %b %e " (current-time)) + string) + (run-at-time (format "%d sec" appt-display-duration) + nil + appt-delete-window-function)) + ((eq appt-display-format 'echo) + (message "%s" string))) + (if appt-audible (beep 1)))) + + +(defun appt-check (&optional force) + "Check for an appointment and update any reminder display. +If optional argument FORCE is non-nil, reparse the diary file for +appointments. Otherwise the diary file is only parsed once per day, +and when saved. + +Note: the time must be the first thing in the line in the diary +for a warning to be issued. The format of the time can be either +24 hour or am/pm. For example: -(defvar appt-display-count nil) - -(defun appt-check () - "Check for an appointment and update the mode line and minibuffer if - desired. -Note: the time must be the first thing in the line in the diary - for a warning to be issued. - -The format of the time can be either 24 hour or am/pm. -Example: - - 02/23/89 - 18:00 Dinner + 02/23/89 + 18:00 Dinner Thursday 11:45am Lunch meeting. Appointments are checked every `appt-display-interval' minutes. The following variables control appointment notification: - -`appt-issue-message' - If t, the diary buffer is checked for appointments. -`appt-message-warning-time' - Variable used to determine if appointment message - should be displayed. +`appt-display-format' + Controls the format in which reminders are displayed. `appt-audible' - Variable used to determine if appointment is audible. - Default is t. + Variable used to determine if reminder is audible. + Default is t. + +`appt-message-warning-time' + Variable used to determine when appointment message + should first be displayed. -`appt-visible' - Variable used to determine if appointment message should be - displayed in the mini-buffer. Default is t. - -`appt-msg-window' - Variable used to determine if appointment message - should temporarily appear in another window. Mutually exclusive - to `appt-visible'. +`appt-display-mode-line' + If non-nil, a generic message giving the time remaining + is shown in the mode-line when an appointment is due. + +`appt-display-interval' + Interval in minutes at which to check for pending appointments. + +`appt-display-diary' + Display the diary buffer when the appointment list is + initialized for the first time in a day. +The following variables are only relevant if reminders are being +displayed in a window: + `appt-display-duration' - The number of seconds an appointment message - is displayed in another window. + The number of seconds an appointment message is displayed. `appt-disp-window-function' - Function called to display appointment window. You can customize - appt.el by setting this variable to a function different from the - one provided with this package. - + Function called to display appointment window. + `appt-delete-window-function' - Function called to remove appointment window and buffer. You can - customize appt.el by setting this variable to a function different - from the one provided with this package. - - - appt-msg-countdown-list Specifies how much warning you want before - appointments. - appt-display-mode-line Whether to display a countdown to the next - appointment in the mode-line. - appt-announce-method The function used to do the notifications. - 'appt-window-announce to do it in a pop-up - window, 'appt-message-announce or - 'appt-persistent-message-announce to do it - in the echo-area." - - (let* ((min-to-app -1) - (new-time "") - (prev-appt-mode-string appt-mode-string) - (prev-appt-display-count (or appt-display-count 0)) - ;; Non-nil means do a full check for pending appointments - ;; and display in whatever ways the user has selected. - ;; When no appointment is being displayed, - ;; we always do a full check. - (full-check - (or (not appt-now-displayed) - ;; This is true every appt-display-interval minutes. - (= 0 (mod prev-appt-display-count appt-display-interval)))) - ;; Non-nil means only update the interval displayed in the mode line. - (mode-line-only - (and (not full-check) appt-now-displayed))) + Function called to remove appointment window and buffer." + (let* ((min-to-app -1) + (prev-appt-mode-string appt-mode-string) + (prev-appt-display-count (or appt-display-count 0)) + ;; Non-nil means do a full check for pending appointments + ;; and display in whatever ways the user has selected. + ;; When no appointment is being displayed, + ;; we always do a full check. + (full-check + (or (not appt-now-displayed) + ;; This is true every appt-display-interval minutes. + (zerop (mod prev-appt-display-count appt-display-interval)))) + ;; Non-nil means only update the interval displayed in the mode line. + (mode-line-only + (and (not full-check) appt-now-displayed))) + (when (or full-check mode-line-only) (save-excursion ＠＠ -541,100 +544,95 ＠＠ (cur-min (nth 1 now)) (cur-comp-time (+ (* cur-hour 60) cur-min))) - ;; At the first check in any given day, update our + ;; At the first check in any given day, update our ;; appointments to today's list. - - (if (or (null appt-prev-comp-time) - (< cur-comp-time appt-prev-comp-time)) - (condition-case nil - (progn - (if (and view-diary-entries-initially appt-display-diary) - (diary) - (let ((diary-display-hook 'appt-make-list)) - (diary)))) - (error nil))) - (setq appt-prev-comp-time cur-comp-time) - (setq appt-mode-string nil) - (setq appt-display-count nil) + (if (or force ; eg initialize, diary save + (null appt-prev-comp-time) ; first check + (< cur-comp-time appt-prev-comp-time)) ; new day + (condition-case nil + (if appt-display-diary + (let ((diary-hook + (if (assoc 'appt-make-list diary-hook) + diary-hook + (cons 'appt-make-list diary-hook)))) + (diary)) + (let* ((diary-display-hook 'appt-make-list) + (d-buff (find-buffer-visiting + (substitute-in-file-name diary-file))) + (selective + (if d-buff ; Diary buffer exists. + (with-current-buffer d-buff + diary-selective-display)))) + (diary) + ;; If the diary buffer existed before this command, + ;; restore its display state. Otherwise, kill it. + (if d-buff + ;; Displays the diary buffer. + (or selective (diary-show-all-entries)) + (and + (setq d-buff (find-buffer-visiting + (substitute-in-file-name diary-file))) + (kill-buffer d-buff))))) + (error nil))) + + (setq appt-prev-comp-time cur-comp-time + appt-mode-string nil + appt-display-count nil) ;; If there are entries in the list, and the ;; user wants a message issued, - ;; get the first time off of the list + ;; get the first time off of the list ;; and calculate the number of minutes until the appointment. (if (and appt-issue-message appt-time-msg-list) (let ((appt-comp-time (car (car (car appt-time-msg-list))))) (setq min-to-app (- appt-comp-time cur-comp-time)) - (while (and appt-time-msg-list + (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) + (setq appt-time-msg-list (cdr appt-time-msg-list)) (if appt-time-msg-list - (setq appt-comp-time + (setq appt-comp-time (car (car (car appt-time-msg-list)))))) - + ;; If we have an appointment between midnight and ;; 'appt-message-warning-time' minutes after midnight, ;; we must begin to issue a message before midnight. ;; Midnight is considered 0 minutes and 11:59pm is ;; 1439 minutes. Therefore we must recalculate the minutes - ;; to appointment variable. It is equal to the number of - ;; minutes before midnight plus the number of + ;; to appointment variable. It is equal to the number of + ;; minutes before midnight plus the number of ;; minutes after midnight our appointment is. - + (if (and (< appt-comp-time appt-message-warning-time) (> (+ cur-comp-time appt-message-warning-time) appt-max-time)) - (setq min-to-app (+ (- (1+ appt-max-time) cur-comp-time)) - appt-comp-time)) - - ;; issue warning if the appointment time is + (setq min-to-app (+ (- (1+ appt-max-time) cur-comp-time) + appt-comp-time))) + + ;; issue warning if the appointment time is ;; within appt-message-warning time (when (and (<= min-to-app appt-message-warning-time) (>= min-to-app 0)) - (setq appt-now-displayed t) - (setq appt-display-count - (1+ prev-appt-display-count)) + (setq appt-now-displayed t + appt-display-count (1+ prev-appt-display-count)) (unless mode-line-only - (if appt-msg-window - (progn - (setq new-time (format-time-string "%a %b %e " - (current-time))) - (funcall - appt-disp-window-function - (number-to-string min-to-app) new-time - (car (cdr (car appt-time-msg-list)))) - - (run-at-time - (format "%d sec" appt-display-duration) - nil - appt-delete-window-function)) - ;;; else - - (if appt-visible - (message "%s" - (car (cdr (car appt-time-msg-list))))) - - (if appt-audible - (beep 1)))) - + (appt-display-message (cadr (car appt-time-msg-list)) + min-to-app)) (when appt-display-mode-line (setq appt-mode-string - (concat " App't in " - (number-to-string min-to-app) - " min. "))) - + (format " App't in %s min." min-to-app))) + ;; When an appointment is reached, ;; delete it from the list. ;; Reset the count to 0 in case we display another ;; appointment on the next cycle. - (if (= min-to-app 0) - (setq appt-time-msg-list - (cdr appt-time-msg-list) + (if (zerop min-to-app) + (setq appt-time-msg-list (cdr appt-time-msg-list) appt-display-count nil))))) - + ;; If we have changed the mode line string, ;; redisplay all mode lines. (and appt-display-mode-line ＠＠ -652,52 +650,51 ＠＠ ;;notifications to be given via messages in a pop-up window. The variable ;;appt-display-duration controls how long this window should be left up." -(defun appt-disp-window (min-to-app new-time appt-msg) - "Display appointment message APPT-MSG in a separate buffer." +(defun appt-disp-window (min-to-app new-time appt-msg) + "Display appointment message APPT-MSG in a separate buffer. +The appointment is due in MIN-TO-APP (a string) minutes. +NEW-TIME is a string giving the date." (require 'electric) - + ;; Make sure we're not in the minibuffer ;; before splitting the window. - + (if (equal (selected-window) (minibuffer-window)) - (if (other-window 1) + (if (other-window 1) (select-window (other-window 1)) (if (display-multi-frame-p) (select-frame (other-frame 1))))) - - (let* ((this-buffer (current-buffer)) - (this-window (selected-window)) - (appt-disp-buf (set-buffer (get-buffer-create appt-buffer-name)))) + + (let ((this-window (selected-window)) + (appt-disp-buf (set-buffer (get-buffer-create appt-buffer-name)))) (if (cdr (assq 'unsplittable (frame-parameters))) ;; In an unsplittable frame, use something somewhere else. (display-buffer appt-disp-buf) - ;; (unless (or (special-display-p (buffer-name appt-disp-buf)) - ;; (same-window-p (buffer-name appt-disp-buf))) + ;; XEmacs, we don't have either of these functions + ;; (unless (or (special-display-p (buffer-name appt-disp-buf)) + ;; (same-window-p (buffer-name appt-disp-buf))) ;; By default, split the bottom window and use the lower part. (appt-select-lowest-window) - (split-window) - ;;) - (pop-to-buffer appt-disp-buf)) - (setq mode-line-format - (concat "-------------------- Appointment in " - min-to-app " minutes. " new-time " %-")) + (select-window (split-window))) + (switch-to-buffer appt-disp-buf) + ;;) + (calendar-set-mode-line + (format " Appointment in %s minutes. %s " min-to-app new-time)) (erase-buffer) (insert appt-msg) (shrink-window-if-larger-than-buffer (get-buffer-window appt-disp-buf t)) (set-buffer-modified-p nil) (raise-frame (selected-frame)) - (select-window this-window) - (if appt-audible - (beep 1)))) - + (select-window this-window))) + (defun appt-delete-window () "Function called to undisplay appointment messages. Usually just deletes the appointment buffer." (let ((window (get-buffer-window appt-buffer-name t))) (and window - (or (eq window (frame-root-window (window-frame window))) - (delete-window window)))) + (or (eq window (frame-root-window (window-frame window))) + (delete-window window)))) (kill-buffer appt-buffer-name) (if appt-audible (beep 1))) ＠＠ -705,44 +702,45 ＠＠ (defun appt-select-lowest-window () "Select the lowest window on the frame." (let ((lowest-window (selected-window)) + ;; XEmacs change, we don't have window-edges (bottom-edge (nth 3 (window-pixel-edges)))) (walk-windows (lambda (w) - (let ((next-bottom-edge (nth 3 (window-pixel-edges w)))) - (when (< bottom-edge next-bottom-edge) - (setq bottom-edge next-bottom-edge - lowest-window w))))) + (let ((next-bottom-edge (nth 3 (window-pixel-edges w)))) + (when (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge + lowest-window w))))) (select-window lowest-window))) +(defconst appt-time-regexp + "[0-9]?[0-9]\\(h\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]\\)\\(am\\|pm\\)?") + ;;;###autoload (defun appt-add (new-appt-time new-appt-msg) - "Add an appointment for the day at NEW-APPT-TIME and issue message NEW-APPT-MSG. + "Add an appointment for today at NEW-APPT-TIME with message NEW-APPT-MSG. The time should be in either 24 hour format or am/pm format." - (interactive "sTime (hh:mm[am/pm]): \nsMessage: ") - (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" new-appt-time) - nil + (unless (string-match appt-time-regexp new-appt-time) (error "Unacceptable time-string")) - - (let* ((appt-time-string (concat new-appt-time " " new-appt-msg)) - (appt-time (list (appt-convert-time new-appt-time))) - (time-msg (cons appt-time (list appt-time-string)))) - (setq appt-time-msg-list (nconc appt-time-msg-list (list time-msg))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)))) + (let ((time-msg (list (list (appt-convert-time new-appt-time)) + (concat new-appt-time " " new-appt-msg) t))) + (unless (member time-msg appt-time-msg-list) + (setq appt-time-msg-list + (appt-sort-list (nconc appt-time-msg-list (list time-msg))))))) ;;;###autoload (defun appt-delete () "Delete an appointment from the list of appointments." (interactive) - (let* ((tmp-msg-list appt-time-msg-list)) + (let ((tmp-msg-list appt-time-msg-list)) (while tmp-msg-list (let* ((element (car tmp-msg-list)) - (prompt-string (concat "Delete " + (prompt-string (concat "Delete " ;; We want to quote any doublequotes ;; in the string, as well as put ;; doublequotes around it. (prin1-to-string (substring-no-properties - (car (cdr element)) 0)) + (car (cdr element)) 0)) " from list? ")) (test-input (y-or-n-p prompt-string))) (setq tmp-msg-list (cdr tmp-msg-list)) ＠＠ -751,217 +749,203 ＠＠ (appt-check) (message ""))) - + (eval-when-compile (defvar number) - (defvar original-date) - (defvar diary-entries-list)) + (defvar original-date) + (defvar diary-entries-list)) ;;;###autoload (defun appt-make-list () - "Create the appointments list from todays diary buffer. + "Update the appointments list from today's diary buffer. The time must be at the beginning of a line for it to be -put in the appointments list. - 02/23/89 - 12:00pm lunch - Wednesday - 10:00am group meeting -We assume that the variables DATE and NUMBER -hold the arguments that `list-diary-entries' received. -They specify the range of dates that the diary is being processed for." - - ;; We have something to do if the range of dates that the diary is - ;; considering includes the current date. - (if (and (not (calendar-date-compare - (list (calendar-current-date)) - (list original-date))) - (calendar-date-compare - (list (calendar-current-date)) - (list (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian original-date) - number))))) - (save-excursion - ;; Clear the appointments list, then fill it in from the diary. - (setq appt-time-msg-list nil) - (if diary-entries-list - - ;; Cycle through the entry-list (diary-entries-list) - ;; looking for entries beginning with a time. If - ;; the entry begins with a time, add it to the - ;; appt-time-msg-list. Then sort the list. - - (let ((entry-list diary-entries-list) - (new-time-string "")) - ;; Skip diary entries for dates before today. - (while (and entry-list - (calendar-date-compare - (car entry-list) (list (calendar-current-date)))) - (setq entry-list (cdr entry-list))) - ;; Parse the entries for today. - (while (and entry-list - (calendar-date-equal - (calendar-current-date) (car (car entry-list)))) - (let ((time-string (cadr (car entry-list)))) - (while (string-match - "\\([0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?\\).*" - time-string) - (let* ((beg (match-beginning 0)) - ;; Get just the time for this appointment. - (only-time (match-string 1 time-string)) - ;; Find the end of this appointment - ;; (the start of the next). - (end (string-match - "^[ \t]*[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" - time-string - (match-end 0))) - ;; Get the whole string for this appointment. - (appt-time-string - (substring time-string beg (if end (1- end))))) - - ;; Add this appointment to appt-time-msg-list. - (let* ((appt-time (list (appt-convert-time only-time))) - (time-msg (list appt-time appt-time-string))) - (setq appt-time-msg-list - (nconc appt-time-msg-list (list time-msg)))) - - ;; Discard this appointment from the string. - (setq time-string - (if end (substring time-string end) ""))))) - (setq entry-list (cdr entry-list))))) - (run-hooks 'appt-make-list-hook) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)) - ;; Get the current time and convert it to minutes - ;; from midnight. ie. 12:01am = 1, midnight = 0, - ;; so that the elements in the list - ;; that are earlier than the present time can - ;; be removed. - (let* ((now (decode-time)) - (cur-hour (nth 2 now)) - (cur-min (nth 1 now)) - (cur-comp-time (+ (* cur-hour 60) cur-min)) - (appt-comp-time (car (car (car appt-time-msg-list))))) +put in the appointments list (see examples in documentation of +the function `appt-check'). We assume that the variables DATE and +NUMBER hold the arguments that `diary-list-entries' received. +They specify the range of dates that the diary is being processed for. + +Any appointments made with `appt-add' are not affected by this +function. + +For backwards compatibility, this function activates the +appointment package (if it is not already active)." + ;; See comments above appt-activate defun. + (if (not appt-timer) + (appt-activate 1) + ;; We have something to do if the range of dates that the diary is + ;; considering includes the current date. + (if (and (not (calendar-date-compare + (list (calendar-current-date)) + (list original-date))) + (calendar-date-compare + (list (calendar-current-date)) + (list (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian original-date) + number))))) + (save-excursion + ;; Clear the appointments list, then fill it in from the diary. + (dolist (elt appt-time-msg-list) + ;; Delete any entries that were not made with appt-add. + (unless (nth 2 elt) + (setq appt-time-msg-list + (delq elt appt-time-msg-list)))) + (if diary-entries-list + + ;; Cycle through the entry-list (diary-entries-list) + ;; looking for entries beginning with a time. If + ;; the entry begins with a time, add it to the + ;; appt-time-msg-list. Then sort the list. + + (let ((entry-list diary-entries-list) + (new-time-string "")) + ;; Skip diary entries for dates before today. + (while (and entry-list + (calendar-date-compare + (car entry-list) (list (calendar-current-date)))) + (setq entry-list (cdr entry-list))) + ;; Parse the entries for today. + (while (and entry-list + (calendar-date-equal + (calendar-current-date) (car (car entry-list)))) + (let ((time-string (cadr (car entry-list)))) + (while (string-match appt-time-regexp time-string) + (let* ((beg (match-beginning 0)) + ;; Get just the time for this appointment. + (only-time (match-string 0 time-string)) + ;; Find the end of this appointment + ;; (the start of the next). + (end (string-match + (concat "\n[ \t]*" appt-time-regexp) + time-string + (match-end 0))) + ;; Get the whole string for this appointment. + (appt-time-string + (substring time-string beg (if end (1- end))))) + + ;; Add this appointment to appt-time-msg-list. + (let* ((appt-time (list (appt-convert-time only-time))) + (time-msg (list appt-time appt-time-string))) + (setq appt-time-msg-list + (nconc appt-time-msg-list (list time-msg)))) + + ;; Discard this appointment from the string. + (setq time-string + (if end (substring time-string end) ""))))) + (setq entry-list (cdr entry-list))))) + ;; XEmacs change + (run-hooks 'appt-make-list-hook) + (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)) + + ;; Get the current time and convert it to minutes + ;; from midnight. ie. 12:01am = 1, midnight = 0, + ;; so that the elements in the list + ;; that are earlier than the present time can + ;; be removed. + + (let* ((now (decode-time)) + (cur-hour (nth 2 now)) + (cur-min (nth 1 now)) + (cur-comp-time (+ (* cur-hour 60) cur-min)) + (appt-comp-time (car (caar appt-time-msg-list)))) + + (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) + (setq appt-time-msg-list (cdr appt-time-msg-list)) + (if appt-time-msg-list + (setq appt-comp-time (car (caar appt-time-msg-list)))))))))) - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list)))))))))) - (defun appt-sort-list (appt-list) - "Simple sort to put the appointments list APPT-LIST in order. -Scan the list for the smallest element left in the list. -Append the smallest element left into the new list, and remove -it from the original list." - (let ((order-list nil)) - (while appt-list - (let* ((element (car appt-list)) - (element-time (car (car element))) - (tmp-list (cdr appt-list))) - (while tmp-list - (if (< element-time (car (car (car tmp-list)))) - nil - (setq element (car tmp-list)) - (setq element-time (car (car element)))) - (setq tmp-list (cdr tmp-list))) - (setq order-list (nconc order-list (list element))) - (setq appt-list (delq element appt-list)))) - order-list)) + "Sort an appointment list, putting earlier items at the front. +APPT-LIST is a list of the same format as `appt-time-msg-list'." +(sort appt-list (lambda (e1 e2) (< (caar e1) (caar e2))))) (defun appt-convert-time (time2conv) - "Convert hour:min[am/pm] format to minutes from midnight." + "Convert hour:min[am/pm] format to minutes from midnight. +A period (.) can be used instead of a colon (:) to separate the +hour and minute parts." + ;; Formats that should be accepted: + ;; 10:00 10.00 10h00 10h 10am 10:00am 10.00am + (let ((min (if (string-match "[h:.]\\([0-9][0-9]\\)" time2conv) + (string-to-number (match-string 1 time2conv)) + 0)) + (hr (if (string-match "[0-9]*[0-9]" time2conv) + (string-to-number (match-string 0 time2conv)) + 0))) - (let ((conv-time 0) - (hr 0) - (min 0)) - - (string-match ":\\([0-9][0-9]\\)" time2conv) - (setq min (string-to-int - (match-string 1 time2conv))) - - (string-match "[0-9]?[0-9]:" time2conv) - (setq hr (string-to-int - (match-string 0 time2conv))) - ;; convert the time appointment time into 24 hour time - (cond ((and (string-match "pm" time2conv) (< hr 12)) (setq hr (+ 12 hr))) ((and (string-match "am" time2conv) (= hr 12)) (setq hr 0))) - - ;; convert the actual time - ;; into minutes for comparison - ;; against the actual time. - - (setq conv-time (+ (* hr 60) min)) - conv-time)) - + ;; convert the actual time into minutes. + (+ (* hr 60) min))) -(defvar display-time-hook-installed nil) - -(defun install-display-time-hook () - (unless display-time-hook-installed ; only do this stuff once! - (unless (boundp 'display-time-hook) ; Need to wrapper it. - (defvar display-time-hook nil - "*List of functions to be called when the time is updated on the mode line.") - (let ((old-fn (if (or (featurep 'reportmail) - ;; old reportmail without a provide statement - (and (fboundp 'display-time-filter-18-55) - (fboundp 'display-time-filter-18-57))) - (if (and (featurep 'itimer) ; XEmacs reportmail.el - (fboundp 'display-time-timer-function)) - 'display-time-timer-function - ;; older reportmail, or no timer.el. - (if (string-match "18\\.5[0-5]" (emacs-version)) - 'display-time-filter-18-55 - 'display-time-filter-18-57)) - ;; othewise, time.el - (if (and (featurep 'itimer) - (fboundp 'display-time-function)) ; XEmacs - 'display-time-function - 'display-time-filter)))) - ;; we're about to redefine it... - (fset 'old-display-time-filter (symbol-function old-fn)) - (fset old-fn - (lambda (&rest args) ;; ...here's the revised definition - "Revised version of the original function: this version calls a hook." - (apply 'old-display-time-filter args) - (run-hooks 'display-time-hook))))) - (setq display-time-hook-installed t) - (if (fboundp 'add-hook) - (add-hook 'display-time-hook 'appt-check) - (setq display-time-hook (cons appt-check display-time-hook))) - )) +(defun appt-update-list () + "If the current buffer is visiting the diary, update appointments. +This function is intended for use with `write-file-functions'." + (and (string-equal buffer-file-name (expand-file-name diary-file)) + appt-timer + (let ((appt-display-diary nil)) + (appt-check t))) + nil) + + +;; In Emacs-21.3, the manual documented the following procedure to +;; activate this package: +;; (display-time) +;; (add-hook 'diary-hook 'appt-make-list) +;; (diary 0) +;; The display-time call was not necessary, AFAICS. +;; What was really needed was to add the hook and load this file. +;; Calling (diary 0) once the hook had been added was in some sense a +;; roundabout way of loading this file. This file used to have code at +;; the top-level that set up the appt-timer and global-mode-string. +;; One way to maintain backwards compatibility would be to call +;; (appt-activate 1) at top-level. However, this goes against the +;; convention that just loading an Emacs package should not activate +;; it. Instead, we make appt-make-list activate the package (after a +;; suggestion from rms). This means that one has to call diary in +;; order to get it to work, but that is in line with the old (weird, +;; IMO) documented behavior for activating the package. +;; Actually, since (diary 0) does not run diary-hook, I don't think +;; the documented behavior in Emacs-21.3 would ever have worked. +;; Oh well, at least with the changes to appt-make-list it will now +;; work as well as it ever did. +;; The new method is just to use (appt-activate 1). +;; -- gmorris + +;;;###autoload +(defun appt-activate (&optional arg) +"Toggle checking of appointments. +With optional numeric argument ARG, turn appointment checking on if +ARG is positive, otherwise off." + (interactive "P") + (let ((appt-active appt-timer)) + (setq appt-active (if arg (> (prefix-numeric-value arg) 0) + (not appt-active))) + ;; XEmacs - we use write-file-hooks + (remove-hook 'write-file-hooks 'appt-update-list) + (or global-mode-string (setq global-mode-string '(""))) + (delq 'appt-mode-string global-mode-string) + (when appt-timer + ;; XEmacs - really uses itimer + (appt-cancel-timer appt-timer) + (setq appt-timer nil)) + (when appt-active + ;; XEmacs - we use write-file-hooks + (add-hook 'write-file-hooks 'appt-update-list) + (setq appt-timer (run-at-time t 60 'appt-check) + global-mode-string + (append global-mode-string '(appt-mode-string))) + (appt-check t)))) + +;; This is needed for backwards compatibility. Feh. +;; Not for XEmacs, we don't activate appt when the package is loaded. +;;(appt-activate 1) -(defvar appt-timer nil - "Timer used for diary appointment notifications (`appt-check').") - -(defun appt-initialize () - "Read your `diary-file' and remember today's appointments. Call this from - your .emacs file, or any time you want your .diary file re-read (this happens - automatically at midnight to notice the next day's appointments). - - The time must be at the beginning of a line for it to be put in the - appointments list. - 02/23/89 - 12:00pm lunch - Wednesday - 10:00am group meeting" - - (unless appt-timer - (setq appt-timer (run-at-time t 60 'appt-check))) - - (or global-mode-string (setq global-mode-string '(""))) - (or (memq 'appt-mode-string global-mode-string) - (setq global-mode-string - (append global-mode-string '(appt-mode-string)))) - - (let ((n (length (appt-diary-entries)))) - (cond ((= n 0) (message "no appointments today.")) - ((= n 1) (message "1 appointment today.")) - (t (message "%d appointments today." n)))) - ) +(defalias 'appt-initialize 'appt-activate) +(provide 'appt) +;; arch-tag: bf5791c4-8921-499e-a26f-772b1788d347 ;;; appt.el ends here - Index: cal-china.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-china.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-china.el --- cal-china.el 2006/07/31 02:15:22 1.4 +++ cal-china.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-china.el --- calendar functions for the Chinese calendar -;; Copyright (C) 1995,1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Chinese calendar, calendar, holidays, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -40,8 +42,8 ＠＠ ;; The date of Chinese New Year is correct from 1644-2051. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -51,6 +53,10 ＠＠ ;;; Code: +(defvar date) +(defvar displayed-month) +(defvar displayed-year) + (require 'lunar) (defvar chinese-calendar-celestial-stem ＠＠ -59,7 +65,7 ＠＠ (defvar chinese-calendar-terrestrial-branch ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]) -(defcustom chinese-calendar-time-zone +(defcustom chinese-calendar-time-zone '(if (< year 1928) (+ 465 (/ 40.0 60.0)) 480) ＠＠ -500,4 +506,5 ＠＠ (provide 'cal-china) +;;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644 ;;; cal-china.el ends here Index: cal-compat.el =================================================================== RCS file: cal-compat.el diff -N cal-compat.el --- /dev/null Fri Oct 20 23:46:17 2006 +++ cal-compat.el Fri Oct 20 23:46:44 2006 ＠＠ -0,0 +1,241 ＠＠ +;;; cal-compat.el --- calendar compatibility functions + +;; Author: Jeff Miller <jmiller(a)xemacs.org&gt; + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Provide functional equivalents to code present only in Emacs or +;; currently only found in XEmacs betas. + +;; XEmacs change +(if (featurep 'xemacs) + (defalias 'appt-cancel-timer 'delete-itimer) + (defalias 'appt-cancel-timer 'cancel-timer)) + +;; XEmacs change +;;;###autoload +(eval-and-compile + (unless (fboundp 'line-beginning-position) + (defalias 'line-beginning-position 'point-at-bol)) + (unless (fboundp 'line-end-position) + (defalias 'line-end-position 'point-at-eol))) + +;; XEmacs change, mimic button.el from Emacs 22 +;;;###autoload +(defun make-button (beg end &rest properties) + "Make a button from BEG to END in the current buffer. +The remaining arguments form a sequence of PROPERTY VALUE pairs, + +This function is included with calendar for compatability with Emacs." + (let ((extent (make-extent beg end)) + (map (make-sparse-keymap))) + + (define-key map [button2] 'diary-goto-entry) + ;; (define-key map [return] 'diary-goto-entry) + (set-extent-keymap extent map) + + (set-extent-mouse-face extent 'highlight) + (set-extent-property extent 'button extent) + (set-extent-face extent 'diary-button) + ;; set the properties from the calling function + (set-extent-properties extent properties ) + + extent )) + +;; XEmacs change, mimic button.el from Emacs 22 +;;;###autoload +(defun insert-button (label &rest properties) + "Insert a button with the label LABEL. +The remaining arguments form a sequence of PROPERTY VALUE pairs. + +This function is included with calendar for compatability with Emacs." + (apply #'make-button (prog1 (point) (insert label)) + (point) + properties)) + +;; XEmacs change, this shows up in XEmacs 21.5 +;;;###autoload +(unless (fboundp 'match-string-no-properties) + (defun match-string-no-properties (num &optional string) + "Return string of text matched by last search, without text properties. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (let ((result + (substring string (match-beginning num) (match-end num)))) + (set-text-properties 0 (length result) nil result) + result) + (buffer-substring-no-properties (match-beginning num) + (match-end num)))))) + +;; XEmacs change, this shows up in XEmacs 21.5 +;;;###autoload +(unless (fboundp 'add-to-invisibility-spec) + (defun add-to-invisibility-spec (arg) + "Add elements to `buffer-invisibility-spec'. +See documentation for `buffer-invisibility-spec' for the kind of elements +that can be added." + (if (eq buffer-invisibility-spec t) + (setq buffer-invisibility-spec (list t))) + (setq buffer-invisibility-spec + (cons arg buffer-invisibility-spec)))) + +;;;###autoload +(if (fboundp 'assoc-string) + (defalias 'cal-assoc-string 'assoc-string) + (defun cal-assoc-string (key list case-fold) + (if case-fold + (assoc-ignore-case key list) + (assoc key list))) + ) + +;; XEmacs change +;; not available until 21.5 + ;;;###autoload +(unless (fboundp 'display-multi-frame-p) + (defun display-multi-frame-p () + (not (null (memq (device-type) '(x mswindows gtk)))) + )) + +;; XEmacs change +;; not available until 21.5 +;;;###autoload +(unless (fboundp 'display-color-p) + (defun display-color-p () + (eq 'color (device-class)) + )) + +;; XEmacs change +;; only available in MULE +(unless (featurep 'mule) + (setq enable-multibyte-characters nil)) + +; propertize appeared in XEmacs subr.el r21-5-7: 1.26 +;;;###autoload +(unless (fboundp 'propertize) + ;; `propertize' is a builtin in GNU Emacs 21. + (defun propertize (string &rest properties) + "Return a copy of STRING with text properties added. +First argument is the string to copy. +Remaining arguments form a sequence of PROPERTY VALUE pairs for text +properties to add to the result." + (let ((str (copy-sequence string))) + (add-text-properties 0 (length str) + properties + str) + str)) + ) + +;; XEmacs change +;; fit-window-to-buffer is only available in Emacs. +;; shamelessly taken from ibuffer +;;;###autoload +(unless (fboundp 'fit-window-to-buffer) + (defun cal-fit-window-to-buffer (&optional owin) + "Make window the right size to display its contents exactly." + (interactive) + (if owin + (delete-other-windows)) + (when (> (length (window-list nil 'nomini)) 1) + (let* ((window (selected-window)) + (buf (window-buffer window)) + (height (window-displayed-height (selected-window))) + (new-height (with-current-buffer buf + (count-lines (point-min) (point-max)))) + (diff (- new-height height))) + (unless (zerop diff) + (enlarge-window diff)) + (let ((end (with-current-buffer buf (point-max)))) + (while (and (> (length (window-list nil 'nomini)) 1) + (not (pos-visible-in-window-p end))) + (enlarge-window 1))))))) + +;; XEmacs change. Mimic remove-overlays from Emacs, but for extents +;;;###autoload +(defun cal-remove-extents (&optional beg end name val) + "Clear BEG and END of overlays whose property NAME has value VAL. +Extents might be moved and or split. " + (interactive) + ;; Stolen from planner as planner-remove-overlays + (if (< end beg) + (setq beg (prog1 end (setq end beg)))) + (save-excursion + (dolist (e (extent-list nil beg end)) + (when (eq (extent-property e name) val) + ;; Either push this overlay outside beg...end + ;; or split it to exclude beg...end + ;; or delete it entirely (if it is contained in beg...end). + (if (< (extent-start-position e) beg) + (if (> (extent-end-position e) end) + (progn + (let ((e1 (copy-extent e)) + (props (extent-properties e))) + (set-extent-endpoints e1 + (extent-start-position e) beg) + (set-extent-endpoints e end (extent-end-position e)) + (while props + (set-extent-property e1 (pop props) (pop props))))) + (set-extent-endpoints e (extent-start-position e) beg)) + (if (> (extent-end-position e) end) + (set-extent-endpoints e end (extent-end-position e)) + (delete-extent e))))))) + +;;;###autoload +(defun cal-tp-ml-conv (string) +"Used to convert a propertized calendar modeline string to the XEmacs modeline format. +If there are any text properties present in the string, it will be split on the text-property +boundaries and extents added to the substrings with text properties." + (let* ((start 0) + (end (length string)) + (next) + (s) + (e) + (plist) + (ml)) + (while (/= start end) + (setq next (next-property-change start string end)) + (setq s (substring string start next)) + (setq plist (text-properties-at start string)) + (if plist (progn + (setq e (make-extent nil nil)) + (set-extent-properties e plist) + (setq ml (append ml (list (cons e s ))))) + (setq ml (append ml (list s)))) + + (setq start next)) + ml)) + +;; Available in Emacs 22 +;;;###autoload +(defun make-mode-line-mouse-map (mouse function) "\ +Return a keymap with single entry for mouse key MOUSE on the mode line. +MOUSE is defined to run function FUNCTION with no args in the buffer +corresponding to the mode line clicked." + (let ((map (make-sparse-keymap))) + (define-key map (vector mouse) function) + map)) + + +(provide 'cal-compat) Index: cal-coptic.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-coptic.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-coptic.el --- cal-coptic.el 2006/07/31 02:15:22 1.4 +++ cal-coptic.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -31,8 +33,8 ＠＠ ;; diary.el that deal with the Coptic and Ethiopic calendars. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -42,6 +44,8 ＠＠ ;;; Code: +(defvar date) + (require 'cal-julian) (defvar coptic-calendar-month-name-array ＠＠ -51,7 +55,7 ＠＠ (defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284)) "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).") -(defconst coptic-name "Coptic") +(defvar coptic-name "Coptic") (defun coptic-calendar-leap-year-p (year) "True if YEAR is a leap year on the Coptic calendar." ＠＠ -79,7 +83,7 ＠＠ (/ year 4) ;; Leap days in prior years (* 30 (1- month)) ;; Days in prior months this year day))) ;; Days so far this month - + (defun calendar-coptic-from-absolute (date) "Compute the Coptic equivalent for absolute date DATE. ＠＠ -153,14 +157,15 ＠＠ (calendar-coptic-from-absolute (calendar-absolute-from-gregorian today)))))) (completion-ignore-case t) - (month (cdr (assoc-ignore-case - (completing-read - (format "%s calendar month name: " coptic-name) - (mapcar 'list - (append coptic-calendar-month-name-array nil)) - nil t) + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-ignore + (completing-read + (format "%s calendar month name: " coptic-name) + (mapcar 'list + (append coptic-calendar-month-name-array nil)) + nil t) (calendar-make-alist coptic-calendar-month-name-array - 1)))) + 1) t))) (last (coptic-calendar-last-day-of-month month year)) (day (calendar-read (format "%s calendar day (1-%d): " coptic-name last) ＠＠ -236,4 +241,5 ＠＠ (provide 'cal-coptic) +;;; arch-tag: 72d49161-25df-4072-9312-b182cdca7627 ;;; cal-coptic.el ends here Index: cal-dst.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-dst.el,v retrieving revision 1.5 diff -u -u -r1.5 cal-dst.el --- cal-dst.el 2006/07/31 02:15:22 1.5 +++ cal-dst.el 2006/10/20 21:46:44 ＠＠ -1,9 +1,11 ＠＠ ;;; cal-dst.el --- calendar functions for daylight savings rules -;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Paul Eggert <eggert(a)twinsun.com&gt; ;; Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: daylight savings time, calendar, diary, holidays ＠＠ -21,10 +23,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -72,14 +74,14 ＠＠ (defun calendar-time-from-absolute (abs-date s) "Time of absolute date ABS-DATE, S seconds after midnight. -Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low +Returns the list (HIGH LOW) where HIGH and LOW are the high and low 16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, ignoring leap seconds, that is the equivalent moment to S seconds after midnight UTC on absolute date ABS-DATE." (let* ((a (- abs-date calendar-system-time-basis)) (u (+ (* 163 (mod a 512)) (floor s 128)))) ;; Overflow is a terrible thing! - (cons + (list ;; floor((60*60*24*a + s) / 2^16) (+ a (* 163 (floor a 512)) (floor u 512)) ;; (60*60*24*a + s) mod 2^16 ＠＠ -156,16 +158,16 ＠＠ (cons (list 'calendar-nth-named-day 1 weekday m 'year j) l))) - l) - ;; 01-01 and 07-01 for this year's Persian calendar. - (if (and (= m 3) (<= 20 d) (<= d 21)) - '((calendar-gregorian-from-absolute - (calendar-absolute-from-persian - (list 1 1 (- year 621)))))) - (if (and (= m 9) (<= 22 d) (<= d 23)) - '((calendar-gregorian-from-absolute - (calendar-absolute-from-persian - (list 7 1 (- year 621)))))))) + l) + ;; 01-01 and 07-01 for this year's Persian calendar. + (if (and (= m 3) (<= 20 d) (<= d 21)) + '((calendar-gregorian-from-absolute + (calendar-absolute-from-persian + (list 1 1 (- year 621)))))) + (if (and (= m 9) (<= 22 d) (<= d 23)) + '((calendar-gregorian-from-absolute + (calendar-absolute-from-persian + (list 7 1 (- year 621)))))))) (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day (year (1+ y))) ;; Scan through the next few years until only one rule remains. ＠＠ -280,7 +282,7 ＠＠ (defvar calendar-daylight-time-offset (or (car (cdr calendar-current-time-zone-cache)) 60) "*Number of minutes difference between daylight savings and standard time. - + If the locale never uses daylight savings time, set this to 0.") (defvar calendar-standard-time-zone-name ＠＠ -292,7 +294,7 ＠＠ (or (car (nthcdr 3 calendar-current-time-zone-cache)) "EDT") "*Abbreviated name of daylight-savings time zone at `calendar-location-name'. For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.") - + ;;;###autoload (put 'calendar-daylight-savings-starts 'risky-local-variable t) (defvar calendar-daylight-savings-starts ＠＠ -333,11 +335,11 ＠＠ '(calendar-nth-named-day -1 0 10 year) If the locale never uses daylight savings time, set this to nil.") - + (defvar calendar-daylight-savings-starts-time (or (car (nthcdr 6 calendar-current-time-zone-cache)) 120) "*Number of minutes after midnight that daylight savings time starts.") - + (defvar calendar-daylight-savings-ends-time (or (car (nthcdr 7 calendar-current-time-zone-cache)) calendar-daylight-savings-starts-time) ＠＠ -383,17 +385,18 ＠＠ `calendar-daylight-savings-offset'." (let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date) - (/ (round (* 60 time)) 60.0 24.0))) + (/ (round (* 60 time)) 60.0 24.0))) (dst (dst-in-effect rounded-abs-date)) - (time-zone (if dst - calendar-daylight-time-zone-name - calendar-standard-time-zone-name)) - (time (+ rounded-abs-date + (time-zone (if dst + calendar-daylight-time-zone-name + calendar-standard-time-zone-name)) + (time (+ rounded-abs-date (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0)))) (list (calendar-gregorian-from-absolute (truncate time)) (* 24.0 (- time (truncate time))) time-zone))) - + (provide 'cal-dst) +;;; arch-tag: a141d204-213c-4ca5-bdc6-f9df3aa92aad ;;; cal-dst.el ends here Index: cal-french.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-french.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-french.el --- cal-french.el 2006/07/31 02:15:22 1.4 +++ cal-french.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-french.el --- calendar functions for the French Revolutionary calendar -;; Copyright (C) 1988, 89, 92, 94, 95, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1988, 1989, 1992, 1994, 1995, 1997, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: French Revolutionary calendar, calendar, diary ＠＠ -20,18 +22,18 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ;; This collection of functions implements the features of calendar.el and ;; diary.el that deal with the French Revolutionary calendar. ;; Technical details of the French Revolutionary calendar can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997), and in +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001), and in ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404. ＠＠ -44,6 +46,8 ＠＠ ;;; Code: +(defvar date) + (require 'calendar) (defun french-calendar-accents () ＠＠ -177,17 +181,17 ＠＠ (cond ((< y 1) "") ((= m 13) (format (if (french-calendar-accents) - "Jour %s de l'Année %d de la Révolution" - "Jour %s de l'Anne'e %d de la Re'volution") - (aref (french-calendar-special-days-array) (1- d)) - y)) - (t (format - (if (french-calendar-accents) + "Jour %s de l'Année %d de la Révolution" + "Jour %s de l'Anne'e %d de la Re'volution") + (aref (french-calendar-special-days-array) (1- d)) + y)) + (t (format + (if (french-calendar-accents) "%d %s an %d de la Révolution" "%d %s an %d de la Re'volution") d (aref (french-calendar-month-name-array) (1- m)) - y))))) + y))))) (defun calendar-print-french-date () "Show the French Revolutionary calendar equivalent of the selected date." ＠＠ -202,48 +206,49 ＠＠ Echo French Revolutionary date unless NOECHO is t." (interactive (let ((accents (french-calendar-accents)) - (months (french-calendar-month-name-array)) - (special-days (french-calendar-special-days-array))) + (months (french-calendar-month-name-array)) + (special-days (french-calendar-special-days-array))) (let* ((year (progn (calendar-read (if accents - "Année de la Révolution (>0): " - "Anne'e de la Re'volution (>0): ") + "Année de la Révolution (>0): " + "Anne'e de la Re'volution (>0): ") '(lambda (x) (> x 0)) (int-to-string (extract-calendar-year (calendar-french-from-absolute (calendar-absolute-from-gregorian (calendar-current-date)))))))) - (month-list - (mapcar 'list - (append months - (if (french-calendar-leap-year-p year) - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array) - (reverse - (cdr;; we don't want rev. day in a non-leap yr. - (reverse - (mapcar - '(lambda (x) - (concat "Jour " x)) - special-days)))))))) - (completion-ignore-case t) - (month (cdr (assoc-ignore-case - (completing-read - "Mois ou Sansculottide: " - month-list - nil t) - (calendar-make-alist month-list 1 'car)))) - (day (if (> month 12) - (- month 12) - (calendar-read - "Jour (1-30): " - '(lambda (x) (and (<= 1 x) (<= x 30)))))) - (month (if (> month 12) 13 month))) - (list (list month day year))))) + (month-list + (mapcar 'list + (append months + (if (french-calendar-leap-year-p year) + (mapcar + '(lambda (x) (concat "Jour " x)) + french-calendar-special-days-array) + (reverse + (cdr;; we don't want rev. day in a non-leap yr. + (reverse + (mapcar + '(lambda (x) + (concat "Jour " x)) + special-days)))))))) + (completion-ignore-case t) + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string + (completing-read + "Mois ou Sansculottide: " + month-list + nil t) + (calendar-make-alist month-list 1 'car) t))) + (day (if (> month 12) + (- month 12) + (calendar-read + "Jour (1-30): " + '(lambda (x) (and (<= 1 x) (<= x 30)))))) + (month (if (> month 12) 13 month))) + (list (list month day year))))) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-absolute-from-french date))) (or noecho (calendar-print-french-date))) ＠＠ -257,4 +262,5 ＠＠ (provide 'cal-french) +;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9 ;;; cal-french.el ends here Index: cal-hebrew.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-hebrew.el,v retrieving revision 1.6 diff -u -u -r1.6 cal-hebrew.el --- cal-hebrew.el 2006/08/20 03:39:41 1.6 +++ cal-hebrew.el 2006/10/20 21:46:44 ＠＠ -1,9 +1,11 ＠＠ ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -;; Copyright (C) 1995,1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Nachum Dershowitz <nachum(a)cs.uiuc.edu&gt; ;; Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Hebrew calendar, calendar, diary ＠＠ -21,10 +23,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -32,9 +34,9 ＠＠ ;; diary.el that deal with the Hebrew calendar. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). - +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). + ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ;; (217) 333-6733 University of Illinois at Urbana-Champaign ＠＠ -43,29 +45,14 ＠＠ ;;; Code: -(require 'calendar) +(defvar date) +(defvar displayed-month) +(defvar displayed-year) +(defvar entry) +(defvar number) +(defvar original-date) -(defun calendar-hebrew-from-absolute (date) - "Compute the Hebrew date (month day year) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((greg-date (calendar-gregorian-from-absolute date)) - (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] - (1- (extract-calendar-month greg-date)))) - (day) - (year (+ 3760 (extract-calendar-year greg-date)))) - (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) - (setq year (1+ year))) - (let ((length (hebrew-calendar-last-month-of-year year))) - (while (> date - (calendar-absolute-from-hebrew - (list month - (hebrew-calendar-last-day-of-month month year) - year))) - (setq month (1+ (% month length))))) - (setq day (1+ - (- date (calendar-absolute-from-hebrew (list month 1 year))))) - (list month day year))) +(require 'calendar) (defun hebrew-calendar-leap-year-p (year) "t if YEAR is a Hebrew calendar leap year." ＠＠ -77,15 +64,6 ＠＠ 13 12)) -(defun hebrew-calendar-last-day-of-month (month year) - "The last day of MONTH in YEAR." - (if (or (memq month (list 2 4 6 10 13)) - (and (= month 12) (not (hebrew-calendar-leap-year-p year))) - (and (= month 8) (not (hebrew-calendar-long-heshvan-p year))) - (and (= month 9) (hebrew-calendar-short-kislev-p year))) - 29 - 30)) - (defun hebrew-calendar-elapsed-days (year) "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR." (let* ((months-elapsed ＠＠ -117,9 +95,9 ＠＠ day))) (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday (memq (% alternative-day 7) (list 0 3 5)) - ;; Then postpone it one (more) day and return + ;; Then postpone it one (more) day and return (1+ alternative-day) - ;; Else return + ;; Else return alternative-day))) (defun hebrew-calendar-days-in-year (year) ＠＠ -135,6 +113,15 ＠＠ "t if Kislev is short in Hebrew YEAR." (= (% (hebrew-calendar-days-in-year year) 10) 3)) +(defun hebrew-calendar-last-day-of-month (month year) + "The last day of MONTH in YEAR." + (if (or (memq month (list 2 4 6 10 13)) + (and (= month 12) (not (hebrew-calendar-leap-year-p year))) + (and (= month 8) (not (hebrew-calendar-long-heshvan-p year))) + (and (= month 9) (hebrew-calendar-short-kislev-p year))) + 29 + 30)) + (defun calendar-absolute-from-hebrew (date) "Absolute date of Hebrew DATE. The absolute date is the number of days elapsed since the (imaginary) ＠＠ -158,13 +145,37 ＠＠ (hebrew-calendar-elapsed-days year);; Days in prior years. -1373429))) ;; Days elapsed before absolute date 1. +(defun calendar-hebrew-from-absolute (date) + "Compute the Hebrew date (month day year) corresponding to absolute DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (let* ((greg-date (calendar-gregorian-from-absolute date)) + (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] + (1- (extract-calendar-month greg-date)))) + (day) + (year (+ 3760 (extract-calendar-year greg-date)))) + (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) + (setq year (1+ year))) + (let ((length (hebrew-calendar-last-month-of-year year))) + (while (> date + (calendar-absolute-from-hebrew + (list month + (hebrew-calendar-last-day-of-month month year) + year))) + (setq month (1+ (% month length))))) + (setq day (1+ + (- date (calendar-absolute-from-hebrew (list month 1 year))))) + (list month day year))) + (defvar calendar-hebrew-month-name-array-common-year ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]) + "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"] +"Array of strings giving the names of the Hebrew months in a common year.") (defvar calendar-hebrew-month-name-array-leap-year ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]) + "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"] +"Array of strings giving the names of the Hebrew months in a leap year.") (defun calendar-hebrew-date-string (&optional date) "String of Hebrew date before sunset of Gregorian DATE. ＠＠ -233,25 +244,27 ＠＠ calendar-hebrew-month-name-array-leap-year calendar-hebrew-month-name-array-common-year)) (completion-ignore-case t) - (month (cdr (assoc-ignore-case - (completing-read - "Hebrew calendar month name: " - (mapcar 'list (append month-array nil)) - (if (= year 3761) - '(lambda (x) - (let ((m (cdr - (assoc-ignore-case - (car x) - (calendar-make-alist - month-array))))) - (< 0 - (calendar-absolute-from-hebrew - (list m - (hebrew-calendar-last-day-of-month - m year) - year)))))) - t) - (calendar-make-alist month-array 1)))) + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string + (completing-read + "Hebrew calendar month name: " + (mapcar 'list (append month-array nil)) + (if (= year 3761) + '(lambda (x) + (let ((m (cdr + ;; XEmacs change, we don't have assoc-string + (cal-assoc-string + (car x) + (calendar-make-alist month-array) + t)))) + (< 0 + (calendar-absolute-from-hebrew + (list m + (hebrew-calendar-last-day-of-month + m year) + year)))))) + t) + (calendar-make-alist month-array 1) t))) (last (hebrew-calendar-last-day-of-month month year)) (first (if (and (= year 3761) (= month 10)) 18 1)) ＠＠ -318,7 +331,7 ＠＠ (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) "Simchat Torah"))) (optional - (list + (list (list (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 6 (- abs-r-h 4))) "Selichot (night)") ＠＠ -352,7 +365,7 ＠＠ (filter-visible-calendar-holidays mandatory))) (if all-hebrew-calendar-holidays (setq output-list - (append + (append (filter-visible-calendar-holidays optional) output-list))) output-list))) ＠＠ -403,7 +416,7 ＠＠ (list (calendar-gregorian-from-absolute (+ abs-p 50)) "Shavuot"))) (optional - (list + (list (list (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 6 (- abs-p 43))) "Shabbat Shekalim") ＠＠ -469,7 +482,7 ＠＠ (filter-visible-calendar-holidays mandatory))) (if all-hebrew-calendar-holidays (setq output-list - (append + (append (filter-visible-calendar-holidays optional) output-list))) output-list))) ＠＠ -483,7 +496,7 ＠＠ (list 5 9 (+ displayed-year 3760))))) (filter-visible-calendar-holidays - (list + (list (list (calendar-gregorian-from-absolute (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21))) "Tzom Tammuz") ＠＠ -515,7 +528,7 ＠＠ (mark (regexp-quote diary-nonmarking-symbol))) (calendar-for-loop i from 1 to number do (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute + (hdate (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian gdate))) (month (extract-calendar-month hdate)) (day (extract-calendar-day hdate)) ＠＠ -527,9 +540,9 ＠＠ (car d))) (backup (equal (car (car d)) 'backup)) (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) + (format "%s\\|%s\\.?" + (calendar-day-name gdate) + (calendar-day-name gdate 'abbrev))) (calendar-month-name-array calendar-hebrew-month-name-array-leap-year) (monthname ＠＠ -575,14 +588,89 ＠＠ gdate (buffer-substring-no-properties entry-start (point)) (buffer-substring-no-properties - (1+ date-start) (1- entry-start))))))) - (setq d (cdr d)))) + (1+ date-start) (1- entry-start)) + (copy-marker entry-start)))))) + (setq d (cdr d)))) (setq gdate (calendar-gregorian-from-absolute (1+ (calendar-absolute-from-gregorian gdate))))) (set-buffer-modified-p diary-modified)) (goto-char (point-min)))) +(defun mark-hebrew-calendar-date-pattern (month day year) + "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. +A value of 0 in any position is a wildcard." + (save-excursion + (set-buffer calendar-buffer) + (if (and (/= 0 month) (/= 0 day)) + (if (/= 0 year) + ;; Fully specified Hebrew date. + (let ((date (calendar-gregorian-from-absolute + (calendar-absolute-from-hebrew + (list month day year))))) + (if (calendar-date-is-visible-p date) + (mark-visible-calendar-date date))) + ;; Month and day in any year--this taken from the holiday stuff. + (if (memq displayed-month;; This test is only to speed things up a + (list ;; bit; it works fine without the test too. + (if (< 11 month) (- month 11) (+ month 1)) + (if (< 10 month) (- month 10) (+ month 2)) + (if (< 9 month) (- month 9) (+ month 3)) + (if (< 8 month) (- month 8) (+ month 4)) + (if (< 7 month) (- month 7) (+ month 5)))) + (let ((m1 displayed-month) + (y1 displayed-year) + (m2 displayed-month) + (y2 displayed-year) + (year)) + (increment-calendar-month m1 y1 -1) + (increment-calendar-month m2 y2 1) + (let* ((start-date (calendar-absolute-from-gregorian + (list m1 1 y1))) + (end-date (calendar-absolute-from-gregorian + (list m2 + (calendar-last-day-of-month m2 y2) + y2))) + (hebrew-start + (calendar-hebrew-from-absolute start-date)) + (hebrew-end (calendar-hebrew-from-absolute end-date)) + (hebrew-y1 (extract-calendar-year hebrew-start)) + (hebrew-y2 (extract-calendar-year hebrew-end))) + (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) + (let ((date (calendar-gregorian-from-absolute + (calendar-absolute-from-hebrew + (list month day year))))) + (if (calendar-date-is-visible-p date) + (mark-visible-calendar-date date))))))) + ;; Not one of the simple cases--check all visible dates for match. + ;; Actually, the following code takes care of ALL of the cases, but + ;; it's much too slow to be used for the simple (common) cases. + (let ((m displayed-month) + (y displayed-year) + (first-date) + (last-date)) + (increment-calendar-month m y -1) + (setq first-date + (calendar-absolute-from-gregorian + (list m 1 y))) + (increment-calendar-month m y 2) + (setq last-date + (calendar-absolute-from-gregorian + (list m (calendar-last-day-of-month m y) y))) + (calendar-for-loop date from first-date to last-date do + (let* ((h-date (calendar-hebrew-from-absolute date)) + (h-month (extract-calendar-month h-date)) + (h-day (extract-calendar-day h-date)) + (h-year (extract-calendar-year h-date))) + (and (or (zerop month) + (= month h-month)) + (or (zerop day) + (= day h-day)) + (or (zerop year) + (= year h-year)) + (mark-visible-calendar-date + (calendar-gregorian-from-absolute date))))))))) + (defun mark-hebrew-diary-entries () "Mark days in the calendar window that have Hebrew date diary entries. Each entry in diary-file (or included files) visible in the calendar window ＠＠ -600,11 +688,12 ＠＠ ((date-form (if (equal (car (car d)) 'backup) (cdr (car d)) (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) + (dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) + (format "%s\\|\\*" + (diary-name-pattern + calendar-hebrew-month-name-array-leap-year))) (month "[0-9]+\\|\\*") (day "[0-9]+\\|\\*") (year "[0-9]+\\|\\*") ＠＠ -639,13 +728,13 ＠＠ (buffer-substring (match-beginning m-name-pos) (match-end m-name-pos)))) - (mm (string-to-int + (mm (string-to-number (if m-pos (buffer-substring (match-beginning m-pos) (match-end m-pos)) ""))) - (dd (string-to-int + (dd (string-to-number (if d-pos (buffer-substring (match-beginning d-pos) ＠＠ -664,109 +753,33 ＠＠ (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (calendar-current-date))))) - (y (+ (string-to-int y-str) + (y (+ (string-to-number 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))))) + (string-to-number 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)))))) + ;; XEmacs change, we don't have assoc-string + (cdr (cal-assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array) t))) (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc-ignore-case - mm-name + (setq mm + (if (string-equal mm-name "*") 0 + (cdr + ;; XEmacs change, we don't have assoc-string + (cal-assoc-string + mm-name (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) + calendar-hebrew-month-name-array-leap-year) t))))) (mark-hebrew-calendar-date-pattern mm dd yy))))) (setq d (cdr d))))) -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - (defun insert-hebrew-diary-entry (arg) "Insert a diary entry. For the Hebrew date corresponding to the date indicated by point. ＠＠ -777,7 +790,7 ＠＠ (make-diary-entry (concat hebrew-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))) ＠＠ -796,7 +809,7 ＠＠ (make-diary-entry (concat hebrew-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))))) ＠＠ -816,7 +829,7 ＠＠ (make-diary-entry (concat hebrew-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))))) ＠＠ -838,12 +851,13 ＠＠ (int-to-string (extract-calendar-year today)))) (month-array calendar-month-name-array) (completion-ignore-case t) - (month (cdr (assoc-ignore-case - (completing-read - "Month of death (name): " - (mapcar 'list (append month-array nil)) - nil t) - (calendar-make-alist month-array 1)))) + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string + (completing-read + "Month of death (name): " + (mapcar 'list (append month-array nil)) + nil t) + (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year)) (day (calendar-read (format "Day of death (1-%d): " last) ＠＠ -902,7 +916,7 ＠＠ "Omer count diary entry. Entry applies if date is within 50 days after Passover. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((passover (calendar-absolute-from-hebrew ＠＠ -911,18 +925,18 ＠＠ (week (/ omer 7)) (day (% omer 7))) (if (and (> omer 0) (< omer 50)) - (cons mark - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s")))))))))) + (cons mark + (format "Day %d%s of the omer (until sunset)" + omer + (if (zerop week) + "" + (format ", that is, %d week%s%s" + week + (if (= week 1) "" "s") + (if (zerop day) + "" + (format " and %d day%s" + day (if (= day 1) "" "s")))))))))) (defun diary-yahrzeit (death-month death-day death-year &optional mark) "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. ＠＠ -932,13 +946,13 ＠＠ Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((h-date (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (if european-calendar-style (list death-day death-month death-year) - (list death-month death-day death-year))))) + (list death-month death-day death-year))))) (h-month (extract-calendar-month h-date)) (h-day (extract-calendar-day h-date)) (h-year (extract-calendar-year h-date)) ＠＠ -947,7 +961,7 ＠＠ (diff (- yr h-year)) (y (hebrew-calendar-yahrzeit h-date yr))) (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (cons mark + (cons mark (format "Yahrzeit of %s%s: %d%s anniversary" entry (if (= y d) "" " (evening)") ＠＠ -961,7 +975,7 ＠＠ "Rosh Hodesh diary entry. Entry applies if date is Rosh Hodesh, the day before, or the Saturday before. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((d (calendar-absolute-from-gregorian date)) (h-date (calendar-hebrew-from-absolute d)) ＠＠ -978,7 +992,7 ＠＠ (h-yesterday (extract-calendar-day (calendar-hebrew-from-absolute (1- d))))) (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (cons mark + (cons mark (format "Rosh Hodesh %s" (if (= h-day 30) ＠＠ -991,8 +1005,8 ＠＠ (if (= h-yesterday 30) (format "%s (second day)" this-month) this-month)))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarchim - (cons mark + (if (= (% d 7) 6) ;; Saturday--check for Shabbat Mevarchim + (cons mark (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) (format "Mevarchim Rosh Hodesh %s (%s)" (aref h-month-names ＠＠ -1009,8 +1023,8 ＠＠ (aref calendar-day-name-array (- 29 h-day))) (aref calendar-day-name-array (% (- 30 h-day) 7)))))) - (if (and (= h-day 29) (/= h-month 6)) - (cons mark + (if (and (= h-day 29) (/= h-month 6)) + (cons mark (format "Erev Rosh Hodesh %s" (aref h-month-names (if (= h-month ＠＠ -1018,13 +1032,33 ＠＠ h-year)) 0 h-month))))))))) +(defvar hebrew-calendar-parashiot-names +["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" + "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" + "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" + "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" + "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" + "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" + "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" + "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" + "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] + "The names of the parashiot in the Torah.") + +(defun hebrew-calendar-parasha-name (p) + "Name(s) corresponding to parasha P." + (if (arrayp p);; combined parasha + (format "%s/%s" + (aref hebrew-calendar-parashiot-names (aref p 0)) + (aref hebrew-calendar-parashiot-names (aref p 1))) + (aref hebrew-calendar-parashiot-names p))) + (defun diary-parasha (&optional mark) "Parasha diary entry--entry applies if date is a Saturday. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday + (if (= (% d 7) 6) ;; Saturday (let* ((h-year (extract-calendar-year (calendar-hebrew-from-absolute d))) ＠＠ -1043,18 +1077,18 ＠＠ (t "regular"))) (year-format (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah + (intern (format "hebrew-calendar-year-%s-%s-%s" ;; keviah rosh-hashanah-day type passover-day)))) - (first-saturday;; of Hebrew year + (first-saturday ;; of Hebrew year (calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah))) - (saturday;; which Saturday of the Hebrew year + (saturday ;; which Saturday of the Hebrew year (/ (- d first-saturday) 7)) (parasha (aref year-format saturday))) (if parasha - (cons mark + (cons mark (format "Parashat %s" - (if (listp parasha);; Israel differs from diaspora + (if (listp parasha) ;; Israel differs from diaspora (if (car parasha) (format "%s (diaspora), %s (Israel)" (hebrew-calendar-parasha-name (car parasha)) ＠＠ -1063,18 +1097,6 ＠＠ (hebrew-calendar-parasha-name (cdr parasha)))) (hebrew-calendar-parasha-name parasha))))))))) -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - ;; The seven ordinary year types (keviot) (defconst hebrew-calendar-year-Saturday-incomplete-Sunday ＠＠ -1194,14 +1216,7 ＠＠ Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both have 30 days), and has Passover start on Tuesday.") -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - (provide 'cal-hebrew) +;;; arch-tag: aaab6718-7712-42ac-a32d-28fe1f944f3c ;;; cal-hebrew.el ends here Index: cal-islam.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-islam.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-islam.el --- cal-islam.el 2006/07/31 02:15:22 1.4 +++ cal-islam.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-islam.el --- calendar functions for the Islamic calendar -;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Islamic calendar, calendar, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -31,8 +33,8 ＠＠ ;; diary.el that deal with the Islamic calendar. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -42,11 +44,18 ＠＠ ;;; Code: +(defvar date) +(defvar displayed-month) +(defvar displayed-year) +(defvar number) +(defvar original-date) + (require 'cal-julian) (defvar calendar-islamic-month-name-array ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II" - "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]) + "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"] +"Array of strings giving the names of the Islamic months.") (defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622)) "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).") ＠＠ -97,7 +106,7 ＠＠ (if (< date calendar-islamic-epoch) (list 0 0 0);; pre-Islamic date (let* ((approx (/ (- date calendar-islamic-epoch) - 355));; Approximation from below. + 355));; Approximation from below. (year ;; Search forward from the approximation. (+ approx (calendar-sum y approx ＠＠ -152,12 +161,13 ＠＠ (calendar-absolute-from-gregorian today)))))) (month-array calendar-islamic-month-name-array) (completion-ignore-case t) - (month (cdr (assoc-ignore-case + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string (completing-read "Islamic calendar month name: " (mapcar 'list (append month-array nil)) nil t) - (calendar-make-alist month-array 1)))) + (calendar-make-alist month-array 1) t))) (last (islamic-calendar-last-day-of-month month year)) (day (calendar-read (format "Islamic calendar day (1-%d): " last) ＠＠ -211,7 +221,7 ＠＠ (mark (regexp-quote diary-nonmarking-symbol))) (calendar-for-loop i from 1 to number do (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute + (idate (calendar-islamic-from-absolute (calendar-absolute-from-gregorian gdate))) (month (extract-calendar-month idate)) (day (extract-calendar-day idate)) ＠＠ -223,9 +233,9 ＠＠ (car d))) (backup (equal (car (car d)) 'backup)) (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) + (format "%s\\|%s\\.?" + (calendar-day-name gdate) + (calendar-day-name gdate 'abbrev))) (calendar-month-name-array calendar-islamic-month-name-array) (monthname ＠＠ -271,7 +281,8 ＠＠ gdate (buffer-substring-no-properties entry-start (point)) (buffer-substring-no-properties - (1+ date-start) (1- entry-start))))))) + (1+ date-start) (1- entry-start)) + (copy-marker entry-start)))))) (setq d (cdr d)))) (setq gdate (calendar-gregorian-from-absolute ＠＠ -295,11 +306,11 ＠＠ ((date-form (if (equal (car (car d)) 'backup) (cdr (car d)) (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) + (dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) + (format "%s\\|\\*" + (diary-name-pattern calendar-islamic-month-name-array))) (month "[0-9]+\\|\\*") (day "[0-9]+\\|\\*") (year "[0-9]+\\|\\*") ＠＠ -334,13 +345,13 ＠＠ (buffer-substring (match-beginning m-name-pos) (match-end m-name-pos)))) - (mm (string-to-int + (mm (string-to-number (if m-pos (buffer-substring (match-beginning m-pos) (match-end m-pos)) ""))) - (dd (string-to-int + (dd (string-to-number (if d-pos (buffer-substring (match-beginning d-pos) ＠＠ -359,29 +370,28 ＠＠ (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (calendar-current-date))))) - (y (+ (string-to-int y-str) + (y (+ (string-to-number 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))))) + (string-to-number 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)))))) + ;; XEmacs change, we don't have assoc-string + (cdr (cal-assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array) t))) (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc-ignore-case - mm-name - (calendar-make-alist - calendar-islamic-month-name-array)))))) + (setq mm (if (string-equal mm-name "*") 0 + ;; XEmacs change, we don't have assoc-string + (cdr (cal-assoc-string + mm-name + (calendar-make-alist + calendar-islamic-month-name-array) t))))) (mark-islamic-calendar-date-pattern mm dd yy))))) (setq d (cdr d))))) ＠＠ -452,7 +462,7 ＠＠ (make-diary-entry (concat islamic-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))) ＠＠ -470,7 +480,7 ＠＠ (make-diary-entry (concat islamic-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))))) ＠＠ -489,7 +499,7 ＠＠ (make-diary-entry (concat islamic-diary-entry-symbol - (calendar-date-string + (calendar-date-string (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (calendar-cursor-to-date t))))) ＠＠ -497,4 +507,5 ＠＠ (provide 'cal-islam) +;;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7 ;;; cal-islam.el ends here Index: cal-iso.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-iso.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-iso.el --- cal-iso.el 2006/07/31 02:15:22 1.4 +++ cal-iso.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-iso.el --- calendar functions for the ISO calendar -;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: ISO calendar, calendar, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -31,8 +33,8 ＠＠ ;; diary.el that deal with the ISO calendar. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -42,6 +44,8 ＠＠ ;;; Code: +(defvar date) + (require 'calendar) (defun calendar-absolute-from-iso (date) ＠＠ -83,7 +87,7 ＠＠ (defun calendar-iso-date-string (&optional date) "String of ISO date of Gregorian DATE. Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian + (let* ((d (calendar-absolute-from-gregorian (or date (calendar-current-date)))) (day (% d 7)) (iso-date (calendar-iso-from-absolute d))) ＠＠ -98,27 +102,39 ＠＠ (message "ISO date: %s" (calendar-iso-date-string (calendar-cursor-to-date t)))) +(defun calendar-iso-read-args (&optional dayflag) + "Interactively read the arguments for an iso date command." + (let* ((today (calendar-current-date)) + (year (calendar-read + "ISO calendar year (>0): " + '(lambda (x) (> x 0)) + (int-to-string (extract-calendar-year today)))) + (no-weeks (extract-calendar-month + (calendar-iso-from-absolute + (1- + (calendar-dayname-on-or-before + 1 (calendar-absolute-from-gregorian + (list 1 4 (1+ year)))))))) + (week (calendar-read + (format "ISO calendar week (1-%d): " no-weeks) + '(lambda (x) (and (> x 0) (<= x no-weeks))))) + (day (if dayflag (calendar-read + "ISO day (1-7): " + '(lambda (x) (and (<= 1 x) (<= x 7)))) + 1))) + (list (list week day year)))) + (defun calendar-goto-iso-date (date &optional noecho) "Move cursor to ISO DATE; echo ISO date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "ISO calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year today)))) - (no-weeks (extract-calendar-month - (calendar-iso-from-absolute - (1- - (calendar-dayname-on-or-before - 1 (calendar-absolute-from-gregorian - (list 1 4 (1+ year)))))))) - (week (calendar-read - (format "ISO calendar week (1-%d): " no-weeks) - '(lambda (x) (and (> x 0) (<= x no-weeks))))) - (day (calendar-read - "ISO day (1-7): " - '(lambda (x) (and (<= 1 x) (<= x 7)))))) - (list (list week day year)))) + (interactive (calendar-iso-read-args t)) + (calendar-goto-date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso date))) + (or noecho (calendar-print-iso-date))) + +(defun calendar-goto-iso-week (date &optional noecho) + "Move cursor to ISO DATE; echo ISO date unless NOECHO is t. +Interactively, goes to the first day of the specified week." + (interactive (calendar-iso-read-args)) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-absolute-from-iso date))) (or noecho (calendar-print-iso-date))) ＠＠ -129,4 +145,5 ＠＠ (provide 'cal-iso) +;;; arch-tag: 3c0154cc-d30f-4981-9f60-42bdf7a468f6 ;;; cal-iso.el ends here Index: cal-japanese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-japanese.el,v retrieving revision 1.1 diff -u -u -r1.1 cal-japanese.el --- cal-japanese.el 1999/07/09 07:32:32 1.1 +++ cal-japanese.el 2006/10/20 21:46:44 ＠＠ -32,7 +32,8 ＠＠ ;;; Code: (eval-when-compile - (require 'cl)) + (require 'cl) + (require 'calendar)) ;; We're not ready for this, yet. ;; (defvar calendar-japanese-day-names Index: cal-julian.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-julian.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-julian.el --- cal-julian.el 2006/07/31 02:15:23 1.4 +++ cal-julian.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-julian.el --- calendar functions for the Julian calendar -;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Julian calendar, Julian day number, calendar, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -31,8 +33,8 ＠＠ ;; diary.el that deal with the Julian calendar. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -42,6 +44,10 ＠＠ ;;; Code: +(defvar date) +(defvar displayed-month) +(defvar displayed-year) + (require 'calendar) (defun calendar-julian-from-absolute (date) ＠＠ -114,20 +120,21 ＠＠ today)))))) (month-array calendar-month-name-array) (completion-ignore-case t) - (month (cdr (assoc-ignore-case + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string (completing-read "Julian calendar month name: " (mapcar 'list (append month-array nil)) nil t) - (calendar-make-alist month-array 1)))) - (last + (calendar-make-alist month-array 1) t))) + (last (if (and (zerop (% year 4)) (= month 2)) 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) (day (calendar-read (format "Julian calendar day (%d-%d): " (if (and (= year 1) (= month 1)) 3 1) last) - '(lambda (x) + '(lambda (x) (and (< (if (and (= year 1) (= month 1)) 2 0) x) (<= x last)))))) (list (list month day year)))) ＠＠ -184,7 +191,7 ＠＠ (or date (calendar-current-date))))))) (defun calendar-print-astro-day-number () - "Show astronomical (Julian) day numberafter noon UTC on date shown by cursor." + "Show astronomical (Julian) day number after noon UTC on date shown by cursor." (interactive) (message "Astronomical (Julian) day number (at noon UTC): %s.0" ＠＠ -196,10 +203,10 ＠＠ (interactive (list (calendar-read "Astronomical (Julian) day number (>1721425): " '(lambda (x) (> x 1721425))))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (floor - (calendar-absolute-from-astro daynumber )))) + (calendar-goto-date + (calendar-gregorian-from-absolute + (floor + (calendar-absolute-from-astro daynumber)))) (or noecho (calendar-print-astro-day-number))) (defun diary-astro-day-number () ＠＠ -209,4 +216,5 ＠＠ (provide 'cal-julian) +;;; arch-tag: 0520acdd-1c60-4188-9aa8-9b8c24d856ae ;;; cal-julian.el ends here Index: cal-mayan.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-mayan.el,v retrieving revision 1.5 diff -u -u -r1.5 cal-mayan.el --- cal-mayan.el 2006/07/31 02:15:23 1.5 +++ cal-mayan.el 2006/10/20 21:46:44 ＠＠ -1,9 +1,11 ＠＠ ;;; cal-mayan.el --- calendar functions for the Mayan calendars -;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Stewart M. Clamen <clamen(a)cs.cmu.edu&gt; ;; Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Mayan calendar, Maya, calendar, diary ＠＠ -21,10 +23,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -46,8 +48,8 ＠＠ ;; Comments, improvements, and bug reports should be sent to Reingold. ;; Technical details of the Mayan calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997), and in +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001), and in ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' ;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), ＠＠ -55,6 +57,8 ＠＠ ;;; Code: +(defvar date) + (require 'calendar) (defconst calendar-mayan-days-before-absolute-zero 1137142 ＠＠ -139,7 +143,7 ＠＠ 365))) (defun calendar-next-haab-date (haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE. + "Move cursor to next instance of Mayan HAAB-DATE. Echo Mayan date if NOECHO is t." (interactive (list (calendar-read-mayan-haab-date))) (calendar-goto-date ＠＠ -151,7 +155,7 ＠＠ (or noecho (calendar-print-mayan-date))) (defun calendar-previous-haab-date (haab-date &optional noecho) - "Move cursor to previous instance of Mayan HAAB-DATE. + "Move cursor to previous instance of Mayan HAAB-DATE. Echo Mayan date if NOECHO is t." (interactive (list (calendar-read-mayan-haab-date))) (calendar-goto-date ＠＠ -201,7 +205,7 ＠＠ 260))) (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to next instance of Mayan TZOLKIN-DATE. + "Move cursor to next instance of Mayan TZOLKIN-DATE. Echo Mayan date if NOECHO is t." (interactive (list (calendar-read-mayan-tzolkin-date))) (calendar-goto-date ＠＠ -213,7 +217,7 ＠＠ (or noecho (calendar-print-mayan-date))) (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to previous instance of Mayan TZOLKIN-DATE. + "Move cursor to previous instance of Mayan TZOLKIN-DATE. Echo Mayan date if NOECHO is t." (interactive (list (calendar-read-mayan-tzolkin-date))) (calendar-goto-date ＠＠ -232,7 +236,7 ＠＠ (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE. Latest such date on or before DATE. -Returns nil if such a tzolkin-haab combination is impossible." +Returns nil if such a tzolkin-haab combination is impossible." (let* ((haab-difference (calendar-mayan-haab-difference (calendar-mayan-haab-from-absolute 0) ＠＠ -255,14 +259,15 ＠＠ (haab-day (calendar-read "Haab kin (0-19): " '(lambda (x) (and (>= x 0) (< x 20))))) - (haab-month-list (append calendar-mayan-haab-month-name-array + (haab-month-list (append calendar-mayan-haab-month-name-array (and (< haab-day 5) '("Uayeb")))) (haab-month (cdr - (assoc-ignore-case - (completing-read "Haab uinal: " - (mapcar 'list haab-month-list) - nil t) - (calendar-make-alist haab-month-list 1))))) + ;; XEmacs change, we don't have assoc-string + (cal-assoc-string + (completing-read "Haab uinal: " + (mapcar 'list haab-month-list) + nil t) + (calendar-make-alist haab-month-list 1) t)))) (cons haab-day haab-month))) (defun calendar-read-mayan-tzolkin-date () ＠＠ -273,11 +278,12 ＠＠ '(lambda (x) (and (> x 0) (< x 14))))) (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) (tzolkin-name (cdr - (assoc-ignore-case - (completing-read "Tzolkin uinal: " + ;; XEmacs change, we don't have assoc-string + (cal-assoc-string + (completing-read "Tzolkin uinal: " (mapcar 'list tzolkin-name-list) nil t) - (calendar-make-alist tzolkin-name-list 1))))) + (calendar-make-alist tzolkin-name-list 1) t)))) (cons tzolkin-count tzolkin-name))) (defun calendar-next-calendar-round-date ＠＠ -328,7 +334,7 ＠＠ (defun calendar-mayan-date-string (&optional date) "String of Mayan date of Gregorian DATE. Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian + (let* ((d (calendar-absolute-from-gregorian (or date (calendar-current-date)))) (tzolkin (calendar-mayan-tzolkin-from-absolute d)) (haab (calendar-mayan-haab-from-absolute d)) ＠＠ -350,7 +356,7 ＠＠ (let (lc) (while (not lc) (let ((datum - (calendar-string-to-mayan-long-count + (calendar-string-to-mayan-long-count (read-string "Mayan long count (baktun.katun.tun.uinal.kin): " (calendar-mayan-long-count-to-string (calendar-mayan-long-count-from-absolute ＠＠ -363,7 +369,7 ＠＠ (calendar-gregorian-from-absolute (calendar-absolute-from-mayan-long-count date))) (or noecho (calendar-print-mayan-date))) - + (defun calendar-mayan-long-count-common-era (lc) "T if long count represents date in the Common Era." (let ((base (calendar-mayan-long-count-from-absolute 1))) ＠＠ -378,4 +384,5 ＠＠ (provide 'cal-mayan) +;;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df ;;; cal-mayan.el ends here Index: cal-move.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-move.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-move.el --- cal-move.el 2006/07/31 02:15:23 1.4 +++ cal-move.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-move.el --- calendar functions for movement in the calendar -;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: calendar ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -38,6 +40,9 ＠＠ ;;; Code: +(defvar displayed-month) +(defvar displayed-year) + (require 'calendar) (defun calendar-goto-today () ＠＠ -262,13 +267,14 ＠＠ (day (extract-calendar-day date)) (year (extract-calendar-year date)) (jan-first (list 1 1 year)) - (calendar-move-hook nil)) + (calendar-move-hook nil)) (if (and (= day 1) (= 1 month)) (calendar-backward-month (* 12 arg)) (if (and (= arg 1) (calendar-date-is-visible-p jan-first)) (calendar-cursor-to-visible-date jan-first) - (calendar-other-month 1 (- year (1- arg)))))) + (calendar-other-month 1 (- year (1- arg))) + (calendar-cursor-to-visible-date (list 1 1 displayed-year))))) (run-hooks 'calendar-move-hook)) (defun calendar-end-of-year (arg) ＠＠ -280,13 +286,13 ＠＠ (day (extract-calendar-day date)) (year (extract-calendar-year date)) (dec-31 (list 12 31 year)) - (calendar-move-hook nil)) + (calendar-move-hook nil)) (if (and (= day 31) (= 12 month)) (calendar-forward-month (* 12 arg)) (if (and (= arg 1) (calendar-date-is-visible-p dec-31)) (calendar-cursor-to-visible-date dec-31) - (calendar-other-month 12 (- year (1- arg))) + (calendar-other-month 12 (+ year (1- arg))) (calendar-cursor-to-visible-date (list 12 31 displayed-year))))) (run-hooks 'calendar-move-hook)) ＠＠ -326,6 +332,28 ＠＠ (calendar-cursor-to-visible-date date) (run-hooks 'calendar-move-hook)) +(defun calendar-goto-day-of-year (year day &optional noecho) + "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is t. +Negative DAY counts backward from end of year." + (interactive + (let* ((year (calendar-read + "Year (>0): " + (lambda (x) (> x 0)) + (int-to-string (extract-calendar-year + (calendar-current-date))))) + (last (if (calendar-leap-year-p year) 366 365)) + (day (calendar-read + (format "Day number (+/- 1-%d): " last) + '(lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))))) + (list year day))) + (calendar-goto-date + (calendar-gregorian-from-absolute + (if (< 0 day) + (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year))) + (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year)))))) + (or noecho (calendar-print-day-of-year))) + (provide 'cal-move) +;;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781 ;;; cal-move.el ends here Index: cal-persia.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-persia.el,v retrieving revision 1.4 diff -u -u -r1.4 cal-persia.el --- cal-persia.el 2006/07/31 02:15:23 1.4 +++ cal-persia.el 2006/10/20 21:46:44 ＠＠ -1,8 +1,10 ＠＠ ;;; cal-persia.el --- calendar functions for the Persian calendar -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Persian calendar, calendar, diary ＠＠ -20,10 +22,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -31,8 +33,8 ＠＠ ;; diary.el that deal with the Persian calendar. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -42,6 +44,8 ＠＠ ;;; Code: +(defvar date) + (require 'cal-julian) (defvar persian-calendar-month-name-array ＠＠ -208,4 +212,5 ＠＠ (provide 'cal-persia) +;;; arch-tag: 2832383c-e4b4-4dc2-8ee9-cfbdd53e5e2d ;;; cal-persia.el ends here Index: cal-tex.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-tex.el,v retrieving revision 1.5 diff -u -u -r1.5 cal-tex.el --- cal-tex.el 2006/08/04 20:23:50 1.5 +++ cal-tex.el 2006/10/20 21:46:44 ＠＠ -1,9 +1,11 ＠＠ ;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -;; Copyright (C) 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Steve Fisk <fisk(a)bowdoin.edu&gt; ;; Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: Calendar, LaTeX ＠＠ -21,10 +23,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -45,12 +47,12 ＠＠ (require 'calendar) -(autoload 'list-diary-entries "diary-lib" nil t) +(autoload 'diary-list-entries "diary-lib" nil t) (autoload 'calendar-holiday-list "holidays" nil t) (autoload 'calendar-iso-from-absolute "cal-iso" nil t) ;;; -;;; Customizable variables +;;; Customizable variables ;;; (defcustom cal-tex-which-days '(0 1 2 3 4 5 6) ＠＠ -77,8 +79,8 ＠＠ (defcustom cal-tex-rules nil "*If t, pages will be ruled in some styles." -:type 'boolean -:group 'calendar-tex) +:type 'boolean +:group 'calendar-tex) (defcustom cal-tex-daily-string '(let* ((year (extract-calendar-year date)) ＠＠ -121,52 +123,60 ＠＠ :type 'integer :group 'calendar-tex) +(defcustom cal-tex-preamble-extra nil + "A string giving extra LaTeX commands to insert in the calendar preamble. +For example, to include extra packages: +\"\\\\usepackage{foo}\\n\\\\usepackage{bar}\\n\"." +:type 'string +:group 'calendar-tex +:version "22.1") + (defcustom cal-tex-hook nil "*List of functions called after any LaTeX calendar buffer is generated. You can use this to do postprocessing on the buffer. For example, to change characters with diacritical marks to their LaTeX equivalents, use (add-hook 'cal-tex-hook '(lambda () (iso-iso2tex (point-min) (point-max))))" -:type 'hook -:group 'calendar-tex) +:type 'hook +:group 'calendar-tex) (defcustom cal-tex-year-hook nil "*List of functions called after a LaTeX year calendar buffer is generated." -:type 'hook -:group 'calendar-tex) +:type 'hook +:group 'calendar-tex) (defcustom cal-tex-month-hook nil "*List of functions called after a LaTeX month calendar buffer is generated." -:type 'hook -:group 'calendar-tex) +:type 'hook +:group 'calendar-tex) (defcustom cal-tex-week-hook nil "*List of functions called after a LaTeX week calendar buffer is generated." -:type 'hook -:group 'calendar-tex) +:type 'hook +:group 'calendar-tex) (defcustom cal-tex-daily-hook nil "*List of functions called after a LaTeX daily calendar buffer is generated." -:type 'hook -:group 'calendar-tex) +:type 'hook +:group 'calendar-tex) ;;; ;;; Definitions for LaTeX code ;;; (defvar cal-tex-day-prefix "\\caldate{%s}{%s}" - "The initial LaTeX code for a day. + "The initial LaTeX code for a day. The holidays, diary entries, bottom string, and the text follow.") - + (defvar cal-tex-day-name-format "\\myday{%s}%%" "The format for LaTeX code for a day name. The names are taken from -calendar-day-name-array.") +`calendar-day-name-array'.") (defvar cal-tex-cal-one-month "\\def\\calmonth#1#2% {\\begin{center}% \\Huge\\bf\\uppercase{#1} #2 \\\\[1cm]% -\\end{center}}% +\\end{center}}% \\vspace*{-1.5cm}% % " ＠＠ -176,7 +186,7 ＠＠ "\\def\\calmonth#1#2#3#4% {\\begin{center}% \\Huge\\bf #1 #2---#3 #4\\\\[1cm]% -\\end{center}}% +\\end{center}}% \\vspace*{-1.5cm}% % " ＠＠ -216,8 +226,8 ＠＠ (displayed-month (extract-calendar-month start)) (displayed-year (extract-calendar-year start)) (end (calendar-gregorian-from-absolute d2)) - (end-month (extract-calendar-month end)) - (end-year (extract-calendar-year end)) + (end-month (extract-calendar-month end)) + (end-year (extract-calendar-year end)) (number-of-intervals (1+ (/ (calendar-interval displayed-month displayed-year end-month end-year) ＠＠ -231,7 +241,7 ＠＠ (while holidays (and (car (car holidays)) (let ((a (calendar-absolute-from-gregorian (car (car holidays))))) - (and (<= d1 a) (<= a d2))) + (and (<= d1 a) (<= a d2))) (setq in-range (append (list (car holidays)) in-range))) (setq holidays (cdr holidays))) in-range)) ＠＠ -240,7 +250,7 ＠＠ "Generate a list of all diary-entries from absolute date D1 to D2." (let ((diary-list-include-blanks nil) (diary-display-hook 'ignore)) - (list-diary-entries + (diary-list-entries (calendar-gregorian-from-absolute d1) (1+ (- d2 d1))))) ＠＠ -253,8 +263,10 ＠＠ (insert "\\documentclass") (if args (insert "[" args "]")) - (insert "{article}\n" - "\\hbadness 20000 + (insert "{article}\n") + (if (stringp cal-tex-preamble-extra) + (insert cal-tex-preamble-extra "\n")) + (insert "\\hbadness 20000 \\hfuzz=1000pt \\vbadness 20000 \\lineskip 0pt ＠＠ -357,13 +369,15 ＠＠ (cal-tex-noindent) (cal-tex-nl) (let ((month-names; don't use default in case user changed it + ;; These are only used to define the command names, not + ;; the names of the months they insert. ["January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"])) - (calendar-for-loop i from 1 to 12 do - (insert (cal-tex-mini-calendar i year - (aref month-names (1- i)) - "1in" ".9in" "tiny" "0.6mm")))) - (insert + (calendar-for-loop i from 1 to 12 do + (insert (cal-tex-mini-calendar i year + (aref month-names (1- i)) + "1in" ".9in" "tiny" "0.6mm")))) + (insert "\\noindent\\fbox{\\January}\\fbox{\\February}\\fbox{\\March}\\\\ \\noindent\\fbox{\\April}\\fbox{\\May}\\fbox{\\June}\\\\ \\noindent\\fbox{\\July}\\fbox{\\August}\\fbox{\\September}\\\\ ＠＠ -449,7 +463,7 ＠＠ 7))) (insert "\\vspace*{-\\cellwidth}\\hspace*{-2\\cellwidth}" "\\lastmonth\\nextmonth% - ")) +")) (if (/= i n) (progn (run-hooks 'cal-tex-month-hook) ＠＠ -506,12 +520,12 ＠＠ (cal-tex-insert-days month year diary-list holidays cal-tex-day-prefix) (if (= (mod (calendar-absolute-from-gregorian - (list month - (calendar-last-day-of-month month year) - year)) + (list month + (calendar-last-day-of-month month year) + year)) 7) 6); last day of month was Saturday - (progn + (progn (cal-tex-hfill) (cal-tex-nl))) (increment-calendar-month month year 1)) ＠＠ -519,7 +533,7 ＠＠ (cal-tex-end-document))) (run-hooks 'cal-tex-hook)) -(defun cal-tex-insert-days (month year diary-list holidays day-format) +(defun cal-tex-insert-days (month year diary-list holidays day-format) "Insert LaTeX commands for a range of days in monthly calendars. LaTeX commands are inserted for the days of the MONTH in YEAR. Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS are included. ＠＠ -534,7 +548,7 ＠＠ (calendar-for-loop i from 1 to last do (setq date (list month i year)) (if (memq (calendar-day-of-week date) cal-tex-which-days) - (progn + (progn (insert (format day-format (cal-tex-month-name month) i)) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) ＠＠ -551,21 +565,21 ＠＠ "Insert the names of the days at top of a monthly calendar." (calendar-for-loop i from 0 to 6 do (if (memq i cal-tex-which-days) - (insert (format cal-tex-day-name-format - (cal-tex-LaTeXify-string - (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7)))))) + (insert (format cal-tex-day-name-format + (cal-tex-LaTeXify-string + (aref calendar-day-name-array + (mod (+ calendar-week-start-day i) 7)))))) (cal-tex-comment))) (defun cal-tex-insert-month-header (n month year end-month end-year) "Create a title for a calendar. -A title is inserted for a calendar with N months starting with +A title is inserted for a calendar with N months starting with MONTH YEAR and ending with END-MONTH END-YEAR." (let ((month-name (cal-tex-month-name month)) (end-month-name (cal-tex-month-name end-month))) (if (= 1 n) (insert (format "\\calmonth{%s}{%s}\n\\vspace*{-0.5cm}" - month-name year) ) + month-name year) ) (insert (format "\\calmonth{%s}{%s}{%s}{%s}\n\\vspace*{-0.5cm}" month-name year end-month-name end-year)))) (cal-tex-comment)) ＠＠ -581,7 +595,7 ＠＠ (- (calendar-day-of-week (list month 1 year)) calendar-week-start-day) 7))) - (calendar-for-loop i from 0 to (1- blank-days) do + (calendar-for-loop i from 0 to (1- blank-days) do (if (memq i cal-tex-which-days) (insert (format day-format " " " ") "{}{}{}{}%\n")))))) ＠＠ -596,7 +610,7 ＠＠ (- (calendar-day-of-week (list month last-day year)) calendar-week-start-day) 7))) - (calendar-for-loop i from (1+ blank-days) to 6 do + (calendar-for-loop i from (1+ blank-days) to 6 do (if (memq i cal-tex-which-days) (insert (format day-format "" "") "{}{}{}{}%\n")))))) ＠＠ -633,8 +647,8 ＠＠ (defun cal-tex-number-weeks (month year n) "Determine the number of weeks in a range of dates. -Compute the number of weeks in the calendar starting with MONTH and YEAR, -and lasting N months, including only the days in WHICH-DAYS. As it stands, +Compute the number of weeks in the calendar starting with MONTH and YEAR, +and lasting N months, including only the days in WHICH-DAYS. As it stands, this is only an upper bound." (let ((d (list month 1 year))) (increment-calendar-month month year (1- n)) ＠＠ -651,6 +665,11 ＠＠ ;;; Weekly calendars ;;; +(defvar cal-tex-LaTeX-hourbox + "\\newcommand{\\hourbox}[2]% +{\\makebox[2em]{\\rule{0cm}{#2ex}#1}\\rule{3in}{.15mm}}\n" + "One hour and a line on the right.") + (defun cal-tex-cursor-week (&optional arg) "Make a buffer with LaTeX commands for a two-page one-week calendar. It applies to the week that point is in. ＠＠ -689,7 +708,7 ＠＠ (cal-tex-e-center) (cal-tex-hspace "-.2in") (cal-tex-b-parbox "l" "7in") - (calendar-for-loop j from 1 to 7 do + (calendar-for-loop j from 1 to 7 do (cal-tex-week-hours date holidays "3.1") (setq date (cal-tex-incr-date date))) (cal-tex-e-parbox) ＠＠ -741,7 +760,7 ＠＠ (cal-tex-e-center) (cal-tex-hspace "-.2in") (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 1 to 3 do + (calendar-for-loop j from 1 to 3 do (cal-tex-week-hours date holidays "5") (setq date (cal-tex-incr-date date))) (cal-tex-e-parbox) ＠＠ -769,7 +788,7 ＠＠ (insert "}") (cal-tex-nl) (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 4 to 7 do + (calendar-for-loop j from 4 to 7 do (cal-tex-week-hours date holidays "5") (setq date (cal-tex-incr-date date))) (cal-tex-e-parbox) ＠＠ -827,7 +846,7 ＠＠ (cal-tex-nl ".5cm") (cal-tex-e-center) (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 1 to 7 do + (calendar-for-loop j from 1 to 7 do (cal-tex-b-parbox "t" "\\textwidth") (cal-tex-b-parbox "t" "\\textwidth") (cal-tex-rule "0pt" "\\textwidth" ".2mm") ＠＠ -872,13 +891,8 ＠＠ (cal-tex-end-document) (run-hooks 'cal-tex-hook))) -(defvar cal-tex-LaTeX-hourbox - "\\newcommand{\\hourbox}[2]% -{\\makebox[2em]{\\rule{0cm}{#2ex}#1}\\rule{3in}{.15mm}}\n" - "One hour and a line on the right.") - (defun cal-tex-week-hours (date holidays height) - "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT." + "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT." (let ((month (extract-calendar-month date)) (day (extract-calendar-day date)) (year (extract-calendar-year date)) ＠＠ -971,16 +985,16 ＠＠ (if (not weekend) (progn (calendar-for-loop i from 8 to 12 do - (insert (format "{\\large\\sf %d}\\\\\n" i))) + (insert (format "{\\large\\sf %d}\\\\\n" i))) (calendar-for-loop i from 1 to 5 do - (insert (format "{\\large\\sf %d}\\\\\n" - (if cal-tex-24 (+ i 12) i)))))) + (insert (format "{\\large\\sf %d}\\\\\n" + (if cal-tex-24 (+ i 12) i)))))) (cal-tex-nl ".5cm") (if weekend (progn (cal-tex-vspace "1cm") (insert "\\ \\vfill") - (insert (format "{\\Large\\bf %s,} %s/%s/%s\\\\\n" + (insert (format "{\\Large\\bf %s,} %s/%s/%s\\\\\n" dayname1 month1 day1 year1)) (cal-tex-rule "0pt" "7.5cm" ".5mm") (cal-tex-nl "1.5cm") ＠＠ -1054,25 +1068,25 ＠＠ (if (= (extract-calendar-month date) (extract-calendar-month d)) (format "%s %s" - (cal-tex-month-name - (extract-calendar-month date)) + (cal-tex-month-name + (extract-calendar-month date)) (extract-calendar-year date)) (if (= (extract-calendar-year date) (extract-calendar-year d)) (format "%s---%s %s" - (cal-tex-month-name - (extract-calendar-month date)) (cal-tex-month-name + (extract-calendar-month date)) + (cal-tex-month-name (extract-calendar-month d)) (extract-calendar-year date)) (format "%s %s---%s %s" - (cal-tex-month-name - (extract-calendar-month date)) + (cal-tex-month-name + (extract-calendar-month date)) (extract-calendar-year date) (cal-tex-month-name (extract-calendar-month d)) (extract-calendar-year d)))))) (insert "%\n") - (calendar-for-loop j from 1 to 7 do + (calendar-for-loop j from 1 to 7 do (if (= (mod i 2) 1) (insert "\\rightday") (insert "\\leftday")) ＠＠ -1093,7 +1107,7 ＠＠ (defun cal-tex-cursor-filofax-week (&optional arg) "One-week-at-a-glance Filofax style calendar for week indicated by cursor. Optional prefix argument specifies number of weeks. -Weeks start on Monday. +Weeks start on Monday. Diary entries are included if `cal-tex-diary' is t. Holidays are included if `cal-tex-holidays' is t." (interactive "p") ＠＠ -1181,7 +1195,7 ＠＠ (cal-tex-month-name (extract-calendar-month d)) (extract-calendar-year d)))))) (insert "%\n") - (calendar-for-loop j from 1 to 3 do + (calendar-for-loop j from 1 to 3 do (insert "\\leftday") (cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date))) (cal-tex-arg (int-to-string (extract-calendar-day date))) ＠＠ -1216,7 +1230,7 ＠＠ (cal-tex-month-name (extract-calendar-month d)) (extract-calendar-year d)))))) (insert "%\n") - (calendar-for-loop j from 1 to 2 do + (calendar-for-loop j from 1 to 2 do (insert "\\rightday") (cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date))) (cal-tex-arg (int-to-string (extract-calendar-day date))) ＠＠ -1225,7 +1239,7 ＠＠ (cal-tex-arg (eval cal-tex-daily-string)) (insert "%\n") (setq date (cal-tex-incr-date date))) - (calendar-for-loop j from 1 to 2 do + (calendar-for-loop j from 1 to 2 do (insert "\\weekend") (cal-tex-arg (cal-tex-LaTeXify-string (calendar-day-name date))) (cal-tex-arg (int-to-string (extract-calendar-day date))) ＠＠ -1243,7 +1257,7 ＠＠ (defun cal-tex-cursor-filofax-daily (&optional arg) "Day-per-page Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. Weeks start on Monday. +Optional prefix argument specifies number of weeks. Weeks start on Monday. Diary entries are included if `cal-tex-diary' is t. Holidays are included if `cal-tex-holidays' is t. Pages are ruled if `cal-tex-rules' is t." ＠＠ -1266,8 +1280,8 ＠＠ (cal-tex-list-diary-entries (calendar-absolute-from-gregorian (list month 1 year)) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) + (+ (* 7 n) + (calendar-absolute-from-gregorian date)))))) (cal-tex-preamble "twoside") (cal-tex-cmd "\\textwidth 3.25in") (cal-tex-cmd "\\textheight 6.5in") ＠＠ -1311,24 +1325,24 ＠＠ (cal-tex-b-document) (cal-tex-cmd "\\pagestyle{empty}") (calendar-for-loop i from 1 to n do - (calendar-for-loop j from 1 to 5 do - (let ((odd (/= 0 (% j 2)))) - (insert (if odd "\\righthead" "\\lefthead")) - (cal-tex-arg (calendar-date-string date)) - (insert "%\n") - (insert (if odd "\\rightday" "\\leftday"))) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) - (cal-tex-arg (eval cal-tex-daily-string)) - (insert "%\n") + (calendar-for-loop j from 1 to 5 do + (let ((odd (/= 0 (% j 2)))) + (insert (if odd "\\righthead" "\\lefthead")) + (cal-tex-arg (calendar-date-string date)) + (insert "%\n") + (insert (if odd "\\rightday" "\\leftday"))) + (cal-tex-arg (cal-tex-latexify-list diary-list date)) + (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) + (cal-tex-arg (eval cal-tex-daily-string)) + (insert "%\n") (if cal-tex-rules (insert "\\linesfill\n") (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) - (cal-tex-newpage) - (setq date (cal-tex-incr-date date))) + (cal-tex-newpage) + (setq date (cal-tex-incr-date date))) (insert "%\n") - (calendar-for-loop j from 1 to 2 do - (insert "\\lefthead") + (calendar-for-loop j from 1 to 2 do + (insert "\\lefthead") (cal-tex-arg (calendar-date-string date)) (insert "\\weekend") (cal-tex-arg (cal-tex-latexify-list diary-list date)) ＠＠ -1438,7 +1452,7 ＠＠ (cal-tex-hfill) (insert "}") (cal-tex-banner "end of cal-tex-daily-page"))) - + ;;; ;;; Mini calendars ;;; ＠＠ -1470,15 +1484,15 ＠＠ (int-to-string year) "}\\\\[1mm]\n"))) (calendar-for-loop i from 0 to 6 do - (setq str - (concat str - (cal-tex-LaTeXify-string - (substring (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7)) - 0 2)) - (if (/= i 6) - " & " - "\\\\[0.7mm]\n")))) + (setq str + (concat str + (cal-tex-LaTeXify-string + (substring (aref calendar-day-name-array + (mod (+ calendar-week-start-day i) 7)) + 0 2)) + (if (/= i 6) + " & " + "\\\\[0.7mm]\n")))) (calendar-for-loop i from 1 to blank-days do (setq str (concat str " & "))) (calendar-for-loop i from 1 to last do ＠＠ -1506,19 +1520,19 ＠＠ FINAL-SEPARATOR is t." (let* ((sep (if separator separator "\\\\")) (result - (mapconcat '(lambda (x) (cal-tex-LaTeXify-string x)) - (let ((result) - (p date-list)) - (while p - (and (car (car p)) - (calendar-date-equal date (car (car p))) - (setq result (cons (car (cdr (car p))) result))) - (setq p (cdr p))) - (reverse result)) - sep))) + (mapconcat '(lambda (x) (cal-tex-LaTeXify-string x)) + (let ((result) + (p date-list)) + (while p + (and (car (car p)) + (calendar-date-equal date (car (car p))) + (setq result (cons (car (cdr (car p))) result))) + (setq p (cdr p))) + (reverse result)) + sep))) (if (and final-separator (not (string-equal result ""))) - (concat result sep) - result))) + (concat result sep) + result))) (defun cal-tex-previous-month (date) "Return the date of the first day in the month previous to DATE." ＠＠ -1540,12 +1554,12 ＠＠ (defun cal-tex-end-document () "Finish the LaTeX document. -Insert the trailer to LaTeX document, pop to LaTeX buffer, add +Insert the trailer to LaTeX document, pop to LaTeX buffer, add informative header, and run HOOK." (cal-tex-e-document) (latex-mode) (pop-to-buffer cal-tex-buffer) - (goto-char (point-min)) + (goto-char (point-min)) (cal-tex-comment " This buffer was produced by cal-tex.el.") (cal-tex-comment " To print a calendar, type") (cal-tex-comment " M-x tex-buffer RET") ＠＠ -1554,8 +1568,8 ＠＠ (defun cal-tex-insert-preamble (weeks landscape size &optional append) "Initialize the output buffer. -Select the output buffer, and insert the preamble for a calendar of -WEEKS weeks. Insert code for landscape mode if LANDSCAPE is true. +Select the output buffer, and insert the preamble for a calendar of +WEEKS weeks. Insert code for landscape mode if LANDSCAPE is true. Use pointsize SIZE. Optional argument APPEND, if t, means add to end of without erasing current contents." (let ((width "18cm") ＠＠ -1567,7 +1581,7 ＠＠ (if (not append) (progn (cal-tex-preamble size) - (if (not landscape) + (if (not landscape) (progn (cal-tex-cmd "\\oddsidemargin -1.75cm") (cal-tex-cmd "\\def\\holidaymult{.06}")) ＠＠ -1585,16 +1599,16 ＠＠ (/ 1.1 (length cal-tex-which-days)))) (cal-tex-cmd "\\setlength{\\cellheight}" height) (insert (format "\\setlength{\\cellheight}{%f\\cellheight}\n" - (/ 1.0 weeks))) + (/ 1.0 weeks))) (cal-tex-cmd "\\ \\par") (cal-tex-vspace "-3cm"))) (defvar cal-tex-LaTeX-subst-list '(("\"". "``") ("\"". "''");; Quote changes meaning when list is reversed. - ("＠" . "\\verb|＠|") - ("&" . "\\&") - ("%" . "\\%") + ("＠" . "\\verb|＠|") + ("&" . "\\&") + ("%" . "\\%") ("$" . "\\$") ("#" . "\\#") ("_" . "\\_") ＠＠ -1660,11 +1674,11 ＠＠ (defun cal-tex-nl (&optional skip comment) "End a line with \\. If SKIP, then add that much spacing. Add COMMENT if present" - (insert "\\\\") - (if skip + (insert "\\\\") + (if skip (insert "[" skip "]")) (cal-tex-comment comment)) - + (defun cal-tex-arg (&optional text) "Insert optional TEXT surrounded by braces." (insert "{") ＠＠ -1783,4 +1797,5 ＠＠ (provide 'cal-tex) +;;; arch-tag: ca8168a4-5a00-4508-a565-17e3bccce6d0 ;;; cal-tex.el ends here Index: cal-x.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-x.el,v retrieving revision 1.5 diff -u -u -r1.5 cal-x.el --- cal-x.el 2006/07/31 02:15:23 1.5 +++ cal-x.el 2006/10/20 21:46:44 ＠＠ -1,31 +1,32 ＠＠ -;;; cal-x.el --- calendar windows in dedicated frames in x-windows +;;; cal-x.el --- calendar windows in dedicated frames in X -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Michael Kifer <kifer(a)cs.sunysb.edu&gt; ;; Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; -;; Modified for XEmacs by: Chuck Thompson <cthomp(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: calendar, dedicated frames, X Window System -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; GNU Emacs is distributed in the hope that it will be useful, +;; XEmacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with (Mostly): FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -45,38 +46,40 ＠＠ (defvar calendar-frame nil "Frame in which to display the calendar.") (defvar diary-frame nil "Frame in which to display the diary.") - + ;; This should not specify the font. That's up to the user. ;; Certainly it should not specify auto-lower and auto-raise ;; since most users won't like that. (defvar diary-frame-parameters - '((name . "Diary") (title . "Diary") (height . 10) (width . 80) + '((name . "Diary") (title . "Diary") (height . 10) (width . 80) (unsplittable . t) (minibuffer . nil)) "Parameters of the diary frame, if the diary is in its own frame. Location and color should be set in .Xdefaults.") - + (defvar calendar-frame-parameters - '((name . "Calendar") (title . "Calendar") (minibuffer . nil) + '((name . "Calendar") (title . "Calendar") (minibuffer . nil) (height . 10) (width . 80) (unsplittable . t) (vertical-scroll-bars . nil)) "Parameters of the calendar frame, if the calendar is in a separate frame. Location and color should be set in .Xdefaults.") (defvar calendar-and-diary-frame-parameters - '((name . "Calendar") (title . "Calendar") (height . 28) (width . 80) + '((name . "Calendar") (title . "Calendar") (height . 28) (width . 80) (minibuffer . nil)) "Parameters of the frame that displays both the calendar and the diary. Location and color should be set in .Xdefaults.") - + (defvar calendar-after-frame-setup-hooks nil "Hooks to be run just after setting up a calendar frame. Can be used to change frame parameters, such as font, color, location, etc.") +;; XEmacs change (defun calendar-not-using-window-system-p () "Return t if not running under a window system." (if (fboundp 'device-type) (not (eq (device-type (selected-device)) 'x)) (not window-system))) +;; XEmacs change (defun calendar-deiconify-frame (frame) "Deiconify the given frame if it is currently iconified." (if (string-match "XEmacs" emacs-version) ＠＠ -88,7 +91,9 ＠＠ (iconify-or-deiconify-frame)))) (defun calendar-one-frame-setup (&optional arg) - "Start calendar and display it in a dedicated frame together with the diary." + "Start calendar and display it in a dedicated frame together with the diary. +This function requires a display capable of multiple frames, else +`calendar-basic-setup' is used instead." (if (not (display-multi-frame-p)) (calendar-basic-setup arg) (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) ＠＠ -103,7 +108,7 ＠＠ (select-frame calendar-frame) (calendar-deiconify-frame calendar-frame) (calendar-basic-setup arg) - (set-window-dedicated-p (selected-window) 'calendar) + (set-window-dedicated-p (selected-window) t) (set-window-dedicated-p (display-buffer (if (not (memq 'fancy-diary-display diary-display-hook)) ＠＠ -111,10 +116,12 ＠＠ (if (not (bufferp (get-buffer fancy-diary-buffer))) (make-fancy-diary-buffer)) fancy-diary-buffer)) - 'diary)))))) + t)))))) (defun calendar-only-one-frame-setup (&optional arg) - "Start calendar and display it in a dedicated frame." + "Start calendar and display it in a dedicated frame. +This function requires a display capable of multiple frames, else +`calendar-basic-setup' is used instead." (if (not (display-multi-frame-p)) (calendar-basic-setup arg) (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) ＠＠ -123,15 +130,17 ＠＠ (save-window-excursion (save-excursion (setq calendar-frame - (make-frame calendar-frame-parameters)) + (make-frame calendar-frame-parameters)) (run-hooks 'calendar-after-frame-setup-hooks) (select-frame calendar-frame) (calendar-deiconify-frame calendar-frame) (calendar-basic-setup arg) - (set-window-dedicated-p (selected-window) 'calendar)))))) + (set-window-dedicated-p (selected-window) t)))))) (defun calendar-two-frame-setup (&optional arg) - "Start calendar and diary in separate, dedicated frames." + "Start calendar and diary in separate, dedicated frames. +This function requires a display capable of multiple frames, else +`calendar-basic-setup' is used instead." (if (not (display-multi-frame-p)) (calendar-basic-setup arg) (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) ＠＠ -146,7 +155,7 ＠＠ (select-frame calendar-frame) (calendar-deiconify-frame calendar-frame) (display-buffer calendar-buffer) - (set-window-dedicated-p (selected-window) 'calendar) + (set-window-dedicated-p (selected-window) t) (setq diary-frame (make-frame diary-frame-parameters)) (run-hooks 'calendar-after-frame-setup-hooks) (select-frame diary-frame) ＠＠ -159,20 +168,19 ＠＠ (if (not (bufferp (get-buffer fancy-diary-buffer))) (make-fancy-diary-buffer)) fancy-diary-buffer)) - 'diary))))) + t))))) -;(if (not (string-match "XEmacs" emacs-version)) ;; Formerly (get-file-buffer diary-file) was added to the list here, ;; but that isn't clean, and the value could even be nil. - (setq special-display-buffer-names - (append special-display-buffer-names - (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer - other-calendars-buffer calendar-buffer))) -;) +(setq special-display-buffer-names + (append special-display-buffer-names + (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer + fancy-diary-buffer + other-calendars-buffer calendar-buffer))) (run-hooks 'cal-x-load-hook) (provide 'cal-x) +;;; arch-tag: c6dbddca-ae84-442d-87fc-244b76e38e17 ;;; cal-x.el ends here Index: cal-xemacs.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/cal-xemacs.el,v retrieving revision 1.9 diff -u -u -r1.9 cal-xemacs.el --- cal-xemacs.el 2006/08/04 20:23:50 1.9 +++ cal-xemacs.el 2006/10/20 21:46:44 ＠＠ -1,11 +1,12 ＠＠ ;;; cal-xemacs.el --- calendar functions for menu bar and popup menu support ;;; Original file is cal-menu.el. -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; ;; Lara Rios <lrios(a)coewl.cen.uiuc.edu&gt; -;; Ported to XEmacs by Chuck Thompson <cthomp(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: calendar, popup menus, menu bar ＠＠ -23,11 +24,12 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: cal-menu.el in Emacs 21.4 +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 +;;; The Emacs counterpart is named cal-menu.el + ;;; Commentary: ;; This collection of functions implements menu bar and popup menu support for ＠＠ -40,8 +42,18 ＠＠ ;; Urbana, Illinois 61801 ;;; Code: +(eval-when-compile + (require 'cal-tex) + (require 'cal-compat) + (require 'holidays)) + +(defvar displayed-month) +(defvar displayed-year) + +;; Don't require calendar because calendar requires us. +;; (eval-when-compile (require 'calendar)) +(defvar calendar-mode-map) -(eval-when-compile (require 'calendar)) (require 'easymenu) ;; XEmacs change ＠＠ -55,8 +67,8 ＠＠ (memq (framep-on-display display) '(x ns gtk mswindows)) (display-mouse-p display))) ) + - (defconst calendar-popup-menu-3 '("Calendar" ["Scroll forward" scroll-calendar-left-three-months t] ＠＠ -66,7 +78,7 ＠＠ ["Mark holidays" mark-calendar-holidays t] ["Unmark" calendar-unmark t] ["Lunar phases" calendar-phases-of-moon t] - ["Show diary" show-all-diary-entries t] + ["Show diary" diary-show-all-entries t] ["Exit calendar" exit-calendar t] )) ＠＠ -77,22 +89,7 ＠＠ (define-key calendar-mode-map 'button2 'calendar-mouse-2-date-menu) -(defun cal-tex-mouse-filofax (e) - "Pop up sub-submenu for Mouse-2 for Filofax cal-tex commands for selected date." - (interactive "e") - (let* ((date (calendar-event-to-date t)) - (menu (list (calendar-date-string date t nil) - "-----" - ["Filofax Daily (One-day-per-page)" - cal-tex-mouse-filofax-daily] - ["Filofax Weekly (2-weeks-at-a-glance)" - cal-tex-mouse-filofax-2week] - ["Filofax Weekly (week-at-a-glance)" - cal-tex-mouse-filofax-week] - ["Filofax Yearly" cal-tex-mouse-filofax-year] - ))) - (popup-menu menu) - )) + (defconst calendar-scroll-menu '("Scroll" ＠＠ -112,11 +109,14 ＠＠ ["End of month" calendar-end-of-month (calendar-cursor-to-date)] ["Beginning of year" calendar-beginning-of-year (calendar-cursor-to-date)] ["End of year" calendar-end-of-year (calendar-cursor-to-date)] + ["Day of Year" calendar-goto-day-of-year] ["Other date" calendar-goto-date t] ["ISO date" calendar-goto-iso-date t] + ["ISO week" calendar-goto-iso-week t] ["Astronomical date" calendar-goto-astro-day-number t] ["Hebrew date" calendar-goto-hebrew-date t] ["Persian date" calendar-goto-persian-date t] + ["Baha'i date" calendar-goto-bahai-date t] ["Islamic date" calendar-goto-islamic-date t] ["Julian date" calendar-goto-julian-date t] ["Chinese date" calendar-goto-chinese-date t] ＠＠ -144,9 +144,9 ＠＠ (defconst calendar-diary-menu '("Diary" ["Other File" view-other-diary-entries (calendar-cursor-to-date)] - ["Cursor Date" view-diary-entries (calendar-cursor-to-date)] + ["Cursor Date" diary-view-entries (calendar-cursor-to-date)] ["Mark All" mark-diary-entries t] - ["Show All" show-all-diary-entries t] + ["Show All" diary-show-all-entries t] ["Insert Diary Entry"insert-diary-entry t] ["Insert Weekly" insert-weekly-diary-entry (calendar-cursor-to-date)] ["Insert Monthly" insert-monthly-diary-entry (calendar-cursor-to-date)] ＠＠ -154,6 +154,7 ＠＠ ["Insert Anniversary" insert-anniversary-diary-entry (calendar-cursor-to-date)] ["Insert Block" insert-block-diary-entry (calendar-cursor-to-date)] ["Insert Cyclic" insert-cyclic-diary-entry (calendar-cursor-to-date)] + ["Insert Baha'i" calendar-mouse-insert-bahai-diary-entry (calendar-cursor-to-date)] ["Insert Islamic" calendar-mouse-insert-islamic-diary-entry (calendar-cursor-to-date)] ["Insert Hebrew" calendar-mouse-insert-hebrew-diary-entry (calendar-cursor-to-date)])) ＠＠ -172,7 +173,16 ＠＠ (add-submenu '("Calendar") calendar-diary-menu)) (if (not (assoc "Moon" current-menubar)) (add-menu-button '("Calendar") ["Moon" calendar-phases-of-moon t])))) - + +(defun calendar-flatten (list) + "Flatten LIST eliminating sublists structure; result is a list of atoms. +This is the same as the preorder list of leaves in a rooted forest." + (if (atom list) + (list list) + (if (cdr list) + (append (calendar-flatten (car list)) (calendar-flatten (cdr list))) + (calendar-flatten (car list))))) + (defun cal-menu-list-holidays-year () "Display a list of the holidays of the selected date's year." (interactive) ＠＠ -193,56 +203,61 ＠＠ (defun cal-menu-update () ;; Update the holiday part of calendar menu bar for the current display. - (interactive) +;; (interactive) (condition-case nil (if (eq major-mode 'calendar-mode) (let ((l)) - (let ((date (calendar-cursor-to-date))) - (if date - (setq l (cons (vector - (format "For Date (%s)" - (calendar-date-string date)) - 'cal-menu-today-holidays t) l)))) - (let ((title - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (if (= y1 y2) - (format "%s-%s, %d" - (calendar-month-name m1 3) - (calendar-month-name m2 3) - y2) - (format "%s, %d-%s, %d" - (calendar-month-name m1 3) - y1 - (calendar-month-name m2 3) - y2))))) - (setq l (cons (vector - (format "For Window (%s)" title ) - 'list-calendar-holidays t) l))) - (setq l (cons (vector - (format "For Today (%s)" - (calendar-date-string - (calendar-current-date) t t)) - 'cal-menu-today-holidays t) l)) - (setq l (cons "---" l)) - (calendar-for-loop;; Show 11 years--5 before, 5 after year of - ;; middle month (calendar-mouse-goto-date (calendar-event-to-date)) - - i from (- displayed-year 5) to (+ displayed-year 5) do - (setq l (cons (vector (format "For Year %s" i) - (list (list 'lambda 'nil '(interactive) - (list 'list-holidays i i))) - t) - l))) + ;; Show 11 years--5 before, 5 after year of middle month + (dotimes (i 11) + (let ((y (+ displayed-year -5 i))) + (push (vector (format "For Year %s" y) + (list (list 'lambda 'nil '(interactive) + (list 'list-holidays y y))) + t) + l))) (setq l (cons ["Mark Holidays" mark-calendar-holidays t] (cons ["Unmark Calendar" calendar-unmark t] - (cons ["--" '("--") t] l)))) + (cons "--" l)))) + (easy-menu-change '("Calendar") "Holidays" (nreverse l)) + + (add-menu-button '("Calendar" "Holidays") + "---" + (format "For Year %s" (- displayed-year 5))) + (add-menu-button '("Calendar" "Holidays") + (vector + (format "For Today (%s)" + (calendar-date-string (calendar-current-date) t t)) + 'cal-menu-today-holidays t) + "---") + (let ((title + (let ((my1 (calendar-increment-month -1)) + (my2 (calendar-increment-month 1))) + (if (= (cdr my1) (cdr my2)) + (format "%s-%s, %d" + (calendar-month-name (car my1) 'abbrev) + (calendar-month-name (car my2) 'abbrev) + (cdr my2)) + (format "%s, %d-%s, %d" + (calendar-month-name (car my1) 'abbrev) + (cdr my1) + (calendar-month-name (car my2) 'abbrev) + (cdr my2)))))) + (add-menu-button '("Calendar" "Holidays") + (vector + (format "For Window (%s)" title ) + 'list-calendar-holidays t) + "---")) + (let ((date (calendar-cursor-to-date))) + (if date + (add-menu-button '("Calendar" "Holidays") + (vector + (format "For Cursor Date (%s)" + (calendar-date-string date t t)) + 'calendar-cursor-holidays) + "---"))) )) + ;; Try to avoid entering infinite beep mode in case of errors. (error (ding)))) (defun calendar-event-to-date (&optional error) ＠＠ -252,17 +267,17 ＠＠ (save-excursion ;; we keep a copy of the last button press event. This makes it easier ;; to mimic the Emacs version. Otherwise, on the next call, we get - ;; a misc-user-event when a menu item is selected. Then we lose the + ;; a misc-user-event when a menu item is selected. Then we lose the ;; buffer and point information (if (button-event-p last-input-event) (progn (setq last-calendar-button-event (allocate-event)) (copy-event last-input-event last-calendar-button-event)) ) - ;; Emacs has this. + ;; Emacs has this. ;;(set-buffer (window-buffer (posn-window (event-start last-input-event)))) ;;(goto-char (posn-point (event-start last-input-event))) - ;; I think this does the same thing - jmiller + ;; I think this does the same thing - jmiller (set-buffer (event-buffer last-calendar-button-event)) (goto-char (event-point last-calendar-button-event)) (calendar-cursor-to-date error))) ＠＠ -291,6 +306,18 ＠＠ ["Yearly" insert-yearly-islamic-diary-entry t]))) (popup-menu menu))) +(defun calendar-mouse-insert-bahai-diary-entry (event) + "Pop up menu to insert an Baha'i-date diary entry." + (interactive "e") + (let ((menu (list (format "Baha'i insert menu - %s" + (calendar-bahai-date-string + (calendar-cursor-to-date))) + "-----" + ["One time" insert-bahai-diary-entry t] + ["Monthly" insert-monthly-bahai-diary-entry t] + ["Yearly" insert-yearly-bahai-diary-entry t]))) + (popup-menu menu))) + (defun calendar-mouse-sunrise/sunset () "Show sunrise/sunset times for mouse-selected date." (interactive) ＠＠ -304,58 +331,63 ＠＠ (save-excursion (calendar-cursor-to-date (calendar-current-date)) (calendar-cursor-holidays))) + +(autoload 'check-calendar-holidays "holidays") +(autoload 'diary-list-entries "diary-lib") -(defun calendar-mouse-holidays () +(defun calendar-mouse-holidays (&optional event) "Pop up menu of holidays for mouse selected date." - (interactive) + (interactive "e") (save-excursion (let* ((date (calendar-event-to-date)) (l (check-calendar-holidays date)) - (menu + (menu (cons (format "Holidays for %s" (calendar-date-string date)) (if l l '("None"))))) (popup-menu menu)))) - -(defun calendar-mouse-view-diary-entries () - "Pop up menu of diary entries for mouse selected date." - (interactive) - (save-excursion - (let* ((date (calendar-event-to-date)) - (l (mapcar '(lambda (x) (concat (car (cdr x)) "")) - (let ((diary-list-include-blanks nil) - (diary-display-hook 'ignore)) - (list-diary-entries date 1)))) - (menu - (cons - (format "Diary Entries for %s" (calendar-date-string date)) - (if l l '("None"))))) - (popup-menu menu)))) + +(defun calendar-mouse-view-diary-entries (&optional date diary event) + "Pop up menu of diary entries for mouse-selected date. +Use optional DATE and alternative file DIARY. + +Any holidays are shown if `holidays-in-diary-buffer' is t." + (interactive) + ; (save-excursion + (let* ((date (if date date (calendar-event-to-date))) + (diary-file (if diary diary diary-file)) + (diary-list-include-blanks nil) + (diary-display-hook 'ignore) + (diary-entries + (mapcar (lambda (x) (split-string (car (cdr x)) "\^M\\|\n")) + (diary-list-entries date 1 'list-only))) + (holidays (if holidays-in-diary-buffer + (mapcar '(lambda (x) (list x)) + (check-calendar-holidays date)))) + (title (concat "Diary entries " + (if diary (format "from %s " diary) "") + "for " + (calendar-date-string date))) + (menu + (append + (list title) + (if holidays + (mapcar '(lambda (x) (concat " " (car x))) + holidays)) + (if holidays + (list "--:shadowEtchedIn" "--:shadowEtchedIn")) + + (if diary-entries + (mapcar 'concat (calendar-flatten diary-entries)) + '("None"))))) + (popup-menu menu))) (defun calendar-mouse-view-other-diary-entries () "Pop up menu of diary entries from alternative file on mouse-selected date." (interactive) - (save-excursion - (let* ((date (calendar-event-to-date)) - (diary-list-include-blanks nil) - (diary-display-hook 'ignore) - (diary-file (read-file-name - "Enter diary file name: " - default-directory nil t)) - ; The following doesn't really do the right thing. The problem is - ; that a newline in the diary entry does not give a newline in a - ; pop-up menu; for that you need a separate list item. When the (car - ; (cdr x)) contains newlines, the item should be split into a list of - ; items. Too minor and messy to worry about. - (l (mapcar '(lambda (x) (concat (car (cdr x)) "")) - (list-diary-entries date 1))) - (menu - (cons - (format "Diary Entries from %s for %s" - diary-file - (calendar-date-string date)) - (if l l '("None"))))) - (popup-menu menu)))) + (calendar-mouse-view-diary-entries + (calendar-event-to-date) + (read-file-name "Enter diary file name: " default-directory nil t))) (defun calendar-mouse-insert-diary-entry () "Insert diary entry for mouse-selected date." ＠＠ -467,9 +499,9 ＠＠ (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-year-landscape nil))) -(defun calendar-mouse-print-dates () +(defun calendar-mouse-print-dates (&optional event) "Pop up menu of equivalent dates to mouse selected date." - (interactive) + (interactive "e") (let* ((date (calendar-event-to-date)) (menu (list (format "Date Menu - %s (Gregorian)" (calendar-date-string date)) ＠＠ -486,6 +518,8 ＠＠ (calendar-hebrew-date-string date)) (format "Persian date: %s" (calendar-persian-date-string date)) + (format "Baha'i date: %s" + (calendar-bahai-date-string date)) (let ((i (calendar-islamic-date-string date))) (if (not (string-equal i "")) (format "Islamic date (before sunset): %s" i))) ＠＠ -500,33 +534,14 ＠＠ (let ((f (calendar-french-date-string date))) (if (not (string-equal f "")) (format "French Revolutionary date: %s" f))) - (format "Mayan date: %s" + (format "Mayan date: %s" (calendar-mayan-date-string date)) ))) (popup-menu menu) )) -(defun calendar-mouse-cal-tex-menu (e) - "Pop up submenu for Mouse-2 for cal-tex commands for selected date in the calendar window." - (interactive "e") - (let* ((date (calendar-event-to-date t)) - (menu (list (calendar-date-string date t nil) - "-----" - ["Daily (1 page)" cal-tex-mouse-day ] - ["Weekly (1 page)" cal-tex-mouse-week ] - ["Weekly (2 pages)" cal-tex-mouse-week2] - ["Weekly (other style; 1 page)" cal-tex-mouse-week-iso] - ["Weekly (yet another style; 1 page)" - cal-tex-mouse-week-monday] - ["Monthly" cal-tex-mouse-month] - ["Monthly (landscape)" cal-tex-mouse-month-landscape] - ["Yearly" cal-tex-mouse-year] - ["Yearly (landscape)" cal-tex-mouse-year-landscape] - ["Filofax styles" cal-tex-mouse-filofax] - ))) - (popup-menu menu) - )) + (defun calendar-mouse-chinese-date () "Show Chinese equivalent for mouse-selected date." (interactive) ＠＠ -556,8 +571,47 ＠＠ ))) (popup-menu menu))) +(defun calendar-mouse-cal-tex-menu (event) + "Pop up submenu for Mouse-2 for cal-tex commands for selected date in the calendar window." + (interactive "e") + (let* ((date (calendar-event-to-date t)) + (menu (list (calendar-date-string date t nil) + "-----" + ["Daily (1 page)" cal-tex-mouse-day ] + ["Weekly (1 page)" cal-tex-mouse-week ] + ["Weekly (2 pages)" cal-tex-mouse-week2] + ["Weekly (other style; 1 page)" cal-tex-mouse-week-iso] + ["Weekly (yet another style; 1 page)" + cal-tex-mouse-week-monday] + ["Monthly" cal-tex-mouse-month] + ["Monthly (landscape)" cal-tex-mouse-month-landscape] + ["Yearly" cal-tex-mouse-year] + ["Yearly (landscape)" cal-tex-mouse-year-landscape] + ["Filofax styles" cal-tex-mouse-filofax] + ))) + (popup-menu menu) + )) + +(defun cal-tex-mouse-filofax (event) + "Pop up sub-submenu for Mouse-2 for Filofax cal-tex commands for selected date." + (interactive "e") + (let* ((date (calendar-event-to-date t)) + (menu (list (calendar-date-string date t nil) + "-----" + ["Filofax Daily (One-day-per-page)" + cal-tex-mouse-filofax-daily] + ["Filofax Weekly (2-weeks-at-a-glance)" + cal-tex-mouse-filofax-2week] + ["Filofax Weekly (week-at-a-glance)" + cal-tex-mouse-filofax-week] + ["Filofax Yearly" cal-tex-mouse-filofax-year] + ))) + (popup-menu menu) + )) + (run-hooks 'cal-xemacs-load-hook) (provide 'cal-xemacs) +;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9 ;;; cal-menu.el ends here Index: calendar.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/calendar.el,v retrieving revision 1.10 diff -u -u -r1.10 calendar.el --- calendar.el 2006/08/04 20:23:50 1.10 +++ calendar.el 2006/10/20 21:46:45 ＠＠ -1,13 +1,12 ＠＠ ;;; calendar.el --- calendar functions ;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, -;; 2000, 2001 Free Software Foundation, Inc. +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar -;; Human-Keywords: calendar, Gregorian calendar, Julian calendar, -;; Hebrew calendar, Islamic calendar, ISO calendar, Julian day number, -;; diary, holidays +;; Human-Keywords: calendar, Gregorian calendar, diary, holidays ;; This file is part of XEmacs. ＠＠ -23,34 +22,37 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with (Mostly): FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: -;; This collection of functions implements a calendar window. It generates a -;; calendar for the current month, together with the previous and coming -;; months, or for any other three-month period. The calendar can be scrolled -;; forward and backward in the window to show months in the past or future; -;; the cursor can move forward and backward by days, weeks, or months, making -;; it possible, for instance, to jump to the date a specified number of days, -;; weeks, or months from the date under the cursor. The user can display a -;; list of holidays and other notable days for the period shown; the notable -;; days can be marked on the calendar, if desired. The user can also specify -;; that dates having corresponding diary entries (in a file that the user -;; specifies) be marked; the diary entries for any date can be viewed in a -;; separate window. The diary and the notable days can be viewed -;; independently of the calendar. Dates can be translated from the (usual) -;; Gregorian calendar to the day of the year/days remaining in year, to the -;; ISO commercial calendar, to the Julian (old style) calendar, to the Hebrew -;; calendar, to the Islamic calendar, to the French Revolutionary calendar, to -;; the Mayan calendar, to the Chinese calendar, to the Coptic calendar, to the -;; Ethiopic calendar,and to the astronomical (Julian) day number. When -;; floating point is available, times of sunrise/sunset can be displayed, as -;; can the phases of the moon. Appointment notification for diary entries is -;; available. Calendar printing via LaTeX is available. +;; This collection of functions implements a calendar window. It +;; generates a calendar for the current month, together with the +;; previous and coming months, or for any other three-month period. +;; The calendar can be scrolled forward and backward in the window to +;; show months in the past or future; the cursor can move forward and +;; backward by days, weeks, or months, making it possible, for +;; instance, to jump to the date a specified number of days, weeks, or +;; months from the date under the cursor. The user can display a list +;; of holidays and other notable days for the period shown; the +;; notable days can be marked on the calendar, if desired. The user +;; can also specify that dates having corresponding diary entries (in +;; a file that the user specifies) be marked; the diary entries for +;; any date can be viewed in a separate window. The diary and the +;; notable days can be viewed independently of the calendar. Dates +;; can be translated from the (usual) Gregorian calendar to the day of +;; the year/days remaining in year, to the ISO commercial calendar, to +;; the Julian (old style) calendar, to the Hebrew calendar, to the +;; Islamic calendar, to the Baha'i calendar, to the French +;; Revolutionary calendar, to the Mayan calendar, to the Chinese +;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to +;; the astronomical (Julian) day number. When floating point is +;; available, times of sunrise/sunset can be displayed, as can the +;; phases of the moon. Appointment notification for diary entries is +;; available. Calendar printing via LaTeX is available. ;; The following files are part of the calendar/diary code: ＠＠ -60,6 +62,7 ＠＠ ;; cal-dst.el Daylight savings time rules ;; cal-hebrew.el Hebrew calendar ;; cal-islam.el Islamic calendar +;; cal-bahai.el Baha'i calendar ;; cal-iso.el ISO calendar ;; cal-julian.el Julian/astronomical calendars ;; cal-mayan.el Mayan calendars ＠＠ -75,13 +78,13 ＠＠ ;; solar.el Sunrise/sunset, equinoxes/solstices ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). - +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). + ;; An earlier version of the technical details appeared in ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), -;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical +;; pages 899-928, and in ``Calendrical Calculations, Part II: Three Historical ;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), ;; pages 383-404. ＠＠ -96,71 +99,16 ＠＠ ;; reingold(a)cs.uiuc.edu 1304 West Springfield Avenue ;; Urbana, Illinois 61801 -;; XEmacs change -;; not available until 21.5 -(unless (fboundp 'display-multi-frame-p) - (defun display-multi-frame-p () - (not (null (memq (device-type) '(x mswindows gtk)))) - )) - -;; XEmacs change -;; not available until 21.5 -(unless (fboundp 'display-color-p) - (defun display-color-p () - (eq 'color (device-class)) - )) - -;; XEmacs change -;; only available in MULE -(unless (featurep 'mule) - (setq enable-multibyte-characters nil)) - -; propertize appeared in XEmacs subr.el r21-5-7: 1.26 -(unless (fboundp 'propertize) -;; `propertize' is a builtin in GNU Emacs 21. - (defun propertize (string &rest properties) - "Return a copy of STRING with text properties added. -First argument is the string to copy. -Remaining arguments form a sequence of PROPERTY VALUE pairs for text -properties to add to the result." - (let ((str (copy-sequence string))) - (add-text-properties 0 (length str) - properties - str) - str)) - ) - -;; XEmacs change -;; fit-window-to-buffer is only available in Emacs. -;; shamelessly taken from ibuffer -(unless (fboundp 'fit-window-to-buffer) - (defun cal-fit-window-to-buffer (&optional owin) - "Make window the right size to display its contents exactly." - (interactive) - (if owin - (delete-other-windows)) - (when (> (length (window-list nil 'nomini)) 1) - (let* ((window (selected-window)) - (buf (window-buffer window)) - (height (window-displayed-height (selected-window))) - (new-height (with-current-buffer buf - (count-lines (point-min) (point-max)))) - (diff (- new-height height))) - (unless (zerop diff) - (enlarge-window diff)) - (let ((end (with-current-buffer buf (point-max)))) - (while (and (> (length (window-list nil 'nomini)) 1) - (not (pos-visible-in-window-p end))) - (enlarge-window 1))))))) - ;;; Code: -(eval-when-compile - (defvar displayed-month) - (defvar displayed-year) - (defvar calendar-month-name-array) - (defvar calendar-starred-day)) +(eval-and-compile + (require 'cal-compat)) +(defvar displayed-month) +(defvar displayed-year) +(defvar calendar-month-name-array) +(defvar calendar-starred-day) + (defun calendar-version () (interactive) (message "Version 6, October 12, 1995")) ＠＠ -198,17 +146,13 ＠＠ :prefix "calendar-" :group 'calendar) - ;;;###autoload -(defcustom calendar-week-start-day 0 - "*The day of the week on which a week in the calendar begins. -0 means Sunday (default), 1 means Monday, and so on." -:type 'integer -:group 'calendar) +(defconst calendar-buffer "*Calendar*" + "Name of the buffer used for the calendar.") ;;;###autoload (defcustom calendar-offset 0 - "*The offset of the principal month from the center of the calendar window. + "The offset of the principal month from the center of the calendar window. 0 means the principal month is in the center (default), -1 means on the left, +1 means on the right. Larger (or smaller) values push the principal month off the screen." ＠＠ -217,57 +161,31 ＠＠ ;;;###autoload (defcustom view-diary-entries-initially nil - "*Non-nil means display current date's diary entries on entry. + "Non-nil means display current date's diary entries on entry to calendar. The diary is displayed in another window when the calendar is first displayed, if the current date is visible. The number of days of diary entries displayed -is governed by the variable `number-of-diary-entries'." +is governed by the variable `number-of-diary-entries'. This variable can +be overridden by the value of `calendar-setup'." :type 'boolean :group 'diary) ;;;###autoload -(defcustom number-of-diary-entries 1 - "*Specifies how many days of diary entries are to be displayed initially. -This variable affects the diary display when the command \\[diary] is used, -or if the value of the variable `view-diary-entries-initially' is t. For -example, if the default value 1 is used, then only the current day's diary -entries will be displayed. If the value 2 is used, then both the current -day's and the next day's entries will be displayed. - -The value can also be a vector such as [0 2 2 2 2 4 1]; this value -says to display no diary entries on Sunday, the display the entries -for the current date and the day after on Monday through Thursday, -display Friday through Monday's entries on Friday, and display only -Saturday's entries on Saturday. - -This variable does not affect the diary display with the `d' command -from the calendar; in that case, the prefix argument controls the -number of days of diary entries displayed." -:type '(choice (integer :tag "Entries") - (vector :value [0 0 0 0 0 0 0] - (integer :tag "Sunday") - (integer :tag "Monday") - (integer :tag "Tuesday") - (integer :tag "Wednesday") - (integer :tag "Thursday") - (integer :tag "Friday") - (integer :tag "Saturday"))) -:group 'diary) - -;;;###autoload (defcustom mark-diary-entries-in-calendar nil - "*Non-nil means mark dates with diary entries, in the calendar window. + "Non-nil means mark dates with diary entries, in the calendar window. The marking symbol is specified by the variable `diary-entry-marker'." :type 'boolean :group 'diary) ;;;###autoload (defcustom calendar-remove-frame-by-deleting nil - "*Determine how the calendar mode removes a frame no longer needed. + "Determine how the calendar mode removes a frame no longer needed. If nil, make an icon of the frame. If non-nil, delete the frame." -:type 'boolean -:group 'view) +:type 'boolean +:group 'view) -(defface diary-face +(defvar diary-face 'diary + "Face name to use for diary entries.") +(defface diary '((((class color) (background light)) (:foreground "red")) (((class color) (background dark)) ＠＠ -275,43 +193,42 ＠＠ (t (:weight bold t))) "Face for highlighting diary entries." -:group 'diary) +:group 'diary) +;; backward-compatibility alias +(put 'diary-face 'face-alias 'diary) (defface calendar-today-face '((t (:underline t))) "Face for indicating today's date." -:group 'diary) +:group 'diary) +;; backward-compatibility alias + (defface holiday-face '((((class color) (background light)) (:background "pink")) (((class color) (background dark)) (:background "chocolate4")) (t - (:inverse-video t))) + (:inverse-video t))) "Face for indicating dates that have holidays." -:group 'diary) +:group 'diary) +;; backward-compatibility alias (defcustom diary-entry-marker (if (not (display-color-p)) "+" - 'diary-face) - "*How to mark dates that have diary entries. + 'diary) + "How to mark dates that have diary entries. The value can be either a single-character string or a face." :type '(choice string face) :group 'diary) -(eval-after-load "facemenu" - '(progn - (add-to-list 'facemenu-unlisted-faces 'diary-face) - (add-to-list 'facemenu-unlisted-faces 'calendar-today-face) - (add-to-list 'facemenu-unlisted-faces 'holiday-face))) - (defcustom calendar-today-marker (if (not (display-color-p)) "=" 'calendar-today-face) - "*How to mark today's date in the calendar. + "How to mark today's date in the calendar. The value can be either a single-character string or a face. Marking today's date is done only if you set up `today-visible-calendar-hook' to request that." ＠＠ -322,14 +239,14 ＠＠ (if (not (display-color-p)) "*" 'holiday-face) - "*How to mark notable dates in the calendar. + "How to mark notable dates in the calendar. The value can be either a single-character string or a face." :type '(choice string face) :group 'calendar) ;;;###autoload (defcustom view-calendar-holidays-initially nil - "*Non-nil means display holidays for current three month period on entry. + "Non-nil means display holidays for current three month period on entry. The holidays are displayed in another window when the calendar is first displayed." :type 'boolean ＠＠ -337,14 +254,14 ＠＠ ;;;###autoload (defcustom mark-holidays-in-calendar nil - "*Non-nil means mark dates of holidays in the calendar window. + "Non-nil means mark dates of holidays in the calendar window. The marking symbol is specified by the variable `calendar-holiday-marker'." :type 'boolean :group 'holidays) ;;;###autoload (defcustom all-hebrew-calendar-holidays nil - "*If nil, show only major holidays from the Hebrew calendar. + "If nil, show only major holidays from the Hebrew calendar. This means only those Jewish holidays that appear on secular calendars. If t, show all the holidays that would appear in a complete Hebrew calendar." ＠＠ -353,7 +270,7 ＠＠ ;;;###autoload (defcustom all-christian-calendar-holidays nil - "*If nil, show only major holidays from the Christian calendar. + "If nil, show only major holidays from the Christian calendar. This means only those Christian holidays that appear on secular calendars. If t, show all the holidays that would appear in a complete Christian ＠＠ -363,7 +280,7 ＠＠ ;;;###autoload (defcustom all-islamic-calendar-holidays nil - "*If nil, show only major holidays from the Islamic calendar. + "If nil, show only major holidays from the Islamic calendar. This means only those Islamic holidays that appear on secular calendars. If t, show all the holidays that would appear in a complete Islamic ＠＠ -371,16 +288,31 ＠＠ :type 'boolean :group 'holidays) +(defcustom diary-file-name-prefix-function (function (lambda (str) str)) + "The function that will take a diary file name and return the desired prefix." +:type 'function +:group 'diary) + ;;;###autoload +(defcustom all-bahai-calendar-holidays nil + "If nil, show only major holidays from the Baha'i calendar. +These are the days on which work and school must be suspended. + +If t, show all the holidays that would appear in a complete Baha'i +calendar." +:type 'boolean +:group 'holidays) + +;;;###autoload (defcustom calendar-load-hook nil - "*List of functions to be called after the calendar is first loaded. + "List of functions to be called after the calendar is first loaded. This is the place to add key bindings to `calendar-mode-map'." :type 'hook :group 'calendar-hooks) ;;;###autoload (defcustom initial-calendar-window-hook nil - "*List of functions to be called when the calendar window is first opened. + "List of functions to be called when the calendar window is first opened. The functions invoked are called after the calendar window is opened, but once opened is never called again. Leaving the calendar with the `q' command and reentering it will cause these functions to be called again." ＠＠ -389,7 +321,7 ＠＠ ;;;###autoload (defcustom today-visible-calendar-hook nil - "*List of functions called whenever the current date is visible. + "List of functions called whenever the current date is visible. This can be used, for example, to replace today's date with asterisks; a function `calendar-star-date' is included for this purpose: (setq today-visible-calendar-hook 'calendar-star-date) ＠＠ -409,7 +341,7 ＠＠ ;;;###autoload (defcustom today-invisible-calendar-hook nil - "*List of functions called whenever the current date is not visible. + "List of functions called whenever the current date is not visible. The corresponding variable `today-visible-calendar-hook' is the list of functions called when the calendar function was called when the current ＠＠ -423,21 +355,22 ＠＠ ;;;###autoload (defcustom calendar-move-hook nil - "*List of functions called whenever the cursor moves in the calendar. + "List of functions called whenever the cursor moves in the calendar. -For example, +For example, - (add-hook 'calendar-move-hook (lambda () (view-diary-entries 1))) + (add-hook 'calendar-move-hook (lambda () (diary-view-entries 1))) redisplays the diary for whatever date the cursor is moved to." -:type 'hook -:group 'calendar-hooks) +:type 'hook +:group 'calendar-hooks) ;;;###autoload (defcustom diary-file "~/diary" - "*Name of the file in which one's personal diary of dates is kept. + "Name of the file in which one's personal diary of dates is kept. -The file's entries are lines in any of the forms +The file's entries are lines beginning with any of the forms +specified by the variable `american-date-diary-pattern', by default: MONTH/DAY MONTH/DAY/YEAR ＠＠ -445,19 +378,24 ＠＠ MONTHNAME DAY, YEAR DAYNAME -at the beginning of the line; the remainder of the line is the diary entry -string for that date. MONTH and DAY are one or two digit numbers, YEAR is -a number and may be written in full or abbreviated to the final two digits. -If the date does not contain a year, it is generic and applies to any year. -DAYNAME entries apply to any date on which is on that day of the week. -MONTHNAME and DAYNAME can be spelled in full, abbreviated to three -characters (with or without a period), capitalized or not. Any of DAY, -MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year, -respectively. - -The European style (in which the day precedes the month) can be used -instead, if you execute `european-calendar' when in the calendar, or set -`european-calendar-style' to t in your .emacs file. The European forms are +with the remainder of the line being the diary entry string for +that date. MONTH and DAY are one or two digit numbers, YEAR is a +number and may be written in full or abbreviated to the final two +digits (if `abbreviated-calendar-year' is non-nil). MONTHNAME +and DAYNAME can be spelled in full (as specified by the variables +`calendar-month-name-array' and `calendar-day-name-array'), +abbreviated (as specified by `calendar-month-abbrev-array' and +`calendar-day-abbrev-array') with or without a period, +capitalized or not. Any of DAY, MONTH, or MONTHNAME, YEAR can be +`*' which matches any day, month, or year, respectively. If the +date does not contain a year, it is generic and applies to any +year. A DAYNAME entry applies to the appropriate day of the week +in every week. + +The European style (in which the day precedes the month) can be +used instead, if you execute `european-calendar' when in the +calendar, or set `european-calendar-style' to t in your .emacs +file. The European forms (see `european-date-diary-pattern') are DAY/MONTH DAY/MONTH/YEAR ＠＠ -512,21 +450,23 ＠＠ %%(diary-block 11 1 1990 11 10 1990) Vacation -causes the diary entry \"Vacation\" to appear from November 1 through November -10, 1990. Other functions available are `diary-float', `diary-anniversary', -`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date', -`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date', +causes the diary entry \"Vacation\" to appear from November 1 through +November 10, 1990. Other functions available are `diary-float', +`diary-anniversary', `diary-cyclic', `diary-day-of-year', +`diary-iso-date', `diary-french-date', `diary-hebrew-date', +`diary-islamic-date', `diary-bahai-date', `diary-mayan-date', `diary-chinese-date', `diary-coptic-date', `diary-ethiopic-date', `diary-persian-date', `diary-yahrzeit', `diary-sunrise-sunset', -`diary-phases-of-moon', `diary-parasha', `diary-omer', `diary-rosh-hodesh', -and `diary-sabbath-candles'. See the documentation for the function -`list-sexp-diary-entries' for more details. - -Diary entries based on the Hebrew and/or the Islamic calendar are also -possible, but because these are somewhat slow, they are ignored -unless you set the `nongregorian-diary-listing-hook' and the -`nongregorian-diary-marking-hook' appropriately. See the documentation -for these functions for details. +`diary-phases-of-moon', `diary-parasha', `diary-omer', +`diary-rosh-hodesh', and `diary-sabbath-candles'. See the +documentation for the function `list-sexp-diary-entries' for more +details. + +Diary entries based on the Hebrew, the Islamic and/or the Baha'i +calendar are also possible, but because these are somewhat slow, they +are ignored unless you set the `nongregorian-diary-listing-hook' and +the `nongregorian-diary-marking-hook' appropriately. See the +documentation for these functions for details. Diary files can contain directives to include the contents of other files; for details, see the documentation for the variable `list-diary-entries-hook'." ＠＠ -535,49 +475,93 ＠＠ ;;;###autoload (defcustom diary-nonmarking-symbol "&" - "*Symbol indicating that a diary entry is not to be marked in the calendar." + "Symbol indicating that a diary entry is not to be marked in the calendar." :type 'string :group 'diary) ;;;###autoload (defcustom hebrew-diary-entry-symbol "H" - "*Symbol indicating a diary entry according to the Hebrew calendar." + "Symbol indicating a diary entry according to the Hebrew calendar." :type 'string :group 'diary) ;;;###autoload (defcustom islamic-diary-entry-symbol "I" - "*Symbol indicating a diary entry according to the Islamic calendar." + "Symbol indicating a diary entry according to the Islamic calendar." :type 'string :group 'diary) ;;;###autoload +(defcustom bahai-diary-entry-symbol "B" + "Symbol indicating a diary entry according to the Baha'i calendar." +:type 'string +:group 'diary) + +;;;###autoload (defcustom diary-include-string "#include" - "*The string indicating inclusion of another file of diary entries. + "The string indicating inclusion of another file of diary entries. See the documentation for the function `include-other-diary-files'." :type 'string :group 'diary) +(defcustom diary-glob-file-regexp-prefix "^\\#" + "The regular expression that gets pre-pended to each of the attribute-regexp's for file-wide specifiers." +:type 'regexp +:group 'diary) + +(defcustom diary-face-attrs + '((" *\\[foreground:\\([-a-z]+\\)\\]$" 1 :foreground string) + (" *\\[background:\\([-a-z]+\\)\\]$" 1 :background string) + (" *\\[width:\\([-a-z]+\\)\\]$" 1 :width symbol) + (" *\\[height:\\([-0-9a-z]+\\)\\]$" 1 :height int) + (" *\\[weight:\\([-a-z]+\\)\\]$" 1 :weight symbol) + (" *\\[slant:\\([-a-z]+\\)\\]$" 1 :slant symbol) + ;; XEmacs change, we don't support underline faces + (" *\\[underline:\\([-a-z]+\\)\\]$" 1 :underline tnil) + (" *\\[overline:\\([-a-z]+\\)\\]$" 1 :overline stringtnil) + (" *\\[strike-through:\\([-a-z]+\\)\\]$" 1 :strike-through stringtnil) + (" *\\[inverse-video:\\([-a-z]+\\)\\]$" 1 :inverse-video tnil) + (" *\\[face:\\([-0-9a-z]+\\)\\]$" 1 :face string) + (" *\\[font:\\([-a-z0-9]+\\)\\]$" 1 :font string) + ;; Unsupported. +;;; (" *\\[box:\\([-a-z]+\\)\\]$" 1 :box) +;;; (" *\\[stipple:\\([-a-z]+\\)\\]$" 1 :stipple) + ) + "A list of (regexp regnum attr attrtype) lists where the +regexp says how to find the tag, the regnum says which +parenthetical sub-regexp this regexp looks for, and the attr says +which attribute of the face (or that this _is_ a face) is being +modified." +:type 'sexp +:group 'diary) + +(defcustom diary-file-name-prefix nil + "If non-nil each diary entry is prefixed with the name of the file where it is defined." +:type 'boolean +:group 'diary) + ;;;###autoload (defcustom sexp-diary-entry-symbol "%%" - "*The string used to indicate a sexp diary entry in `diary-file'. + "The string used to indicate a sexp diary entry in `diary-file'. See the documentation for the function `list-sexp-diary-entries'." :type 'string :group 'diary) ;;;###autoload (defcustom abbreviated-calendar-year t - "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. -For the Gregorian calendar; similarly for the Hebrew and Islamic calendars. -If this variable is nil, years must be written in full." + "Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. +For the Gregorian calendar; similarly for the Hebrew, Islamic and +Baha'i calendars. If this variable is nil, years must be written in +full." :type 'boolean :group 'diary) ;;;###autoload (defcustom european-calendar-style nil - "*Use the European style of dates in the diary and in any displays. + "Use the European style of dates in the diary and in any displays. If this variable is t, a date 1/2/1990 would be interpreted as February 1, -1990. The accepted European date styles are +1990. The default European date styles (see `european-date-diary-pattern') +are DAY/MONTH DAY/MONTH/YEAR ＠＠ -585,8 +569,12 ＠＠ DAY MONTHNAME YEAR DAYNAME -Names can be capitalized or not, written in full, or abbreviated to three -characters with or without a period." +Names can be capitalized or not, written in full (as specified by the +variable `calendar-day-name-array'), or abbreviated (as specified by +`calendar-day-abbrev-array') with or without a period. To take effect, +this variable should be set before the calendar package and its associates +are loaded. Otherwise, use one of the functions `european-calendar' or +`american-calendar' to force the appropriate update." :type 'boolean :group 'diary) ＠＠ -597,7 +585,7 ＠＠ (monthname " *" day "[^,0-9]") (monthname " *" day ", *" year "[^0-9]") (dayname "\\W")) - "*List of pseudo-patterns describing the American patterns of date used. + "List of pseudo-patterns describing the American patterns of date used. See the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" :value (backup . nil) ＠＠ -617,7 +605,7 ＠＠ (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)") (day " *" monthname " *" year "[^0-9]") (dayname "\\W")) - "*List of pseudo-patterns describing the European patterns of date used. + "List of pseudo-patterns describing the European patterns of date used. See the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" :value (backup . nil) ＠＠ -634,18 +622,20 ＠＠ (if european-calendar-style european-date-diary-pattern american-date-diary-pattern) - "*List of pseudo-patterns describing the forms of date used in the diary. + "List of pseudo-patterns describing the forms of date used in the diary. The patterns on the list must be MUTUALLY EXCLUSIVE and should not match any portion of the diary entry itself, just the date component. A pseudo-pattern is a list of regular expressions and the keywords `month', `day', `year', `monthname', and `dayname'. The keyword `monthname' will -match the name of the month, capitalized or not, or its three-letter -abbreviation, followed by a period or not; it will also match `*'. -Similarly, `dayname' will match the name of the day, capitalized or not, or -its three-letter abbreviation, followed by a period or not. The keywords -`month', `day', and `year' will match those numerical values, preceded by -arbitrarily many zeros; they will also match `*'. +match the name of the month (see `calendar-month-name-array'), capitalized +or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'), +followed by a period or not; it will also match `*'. Similarly, `dayname' +will match the name of the day (see `calendar-day-name-array'), capitalized or +not, or its user-specified abbreviation (see `calendar-day-abbrev-array'), +followed by a period or not. The keywords `month', `day', and `year' will +match those numerical values, preceded by arbitrarily many zeros; they will +also match `*'. The matching of the diary entries with the date forms is done with the standard syntax table from Fundamental mode, but with the `*' changed so ＠＠ -670,7 +660,7 ＠＠ ;;;###autoload (defcustom european-calendar-display-form '((if dayname (concat dayname ", ")) day " " monthname " " year) - "*Pseudo-pattern governing the way a date appears in the European style. + "Pseudo-pattern governing the way a date appears in the European style. See the documentation of `calendar-date-display-form' for an explanation." :type 'sexp :group 'calendar) ＠＠ -678,7 +668,7 ＠＠ ;;;###autoload (defcustom american-calendar-display-form '((if dayname (concat dayname ", ")) monthname " " day ", " year) - "*Pseudo-pattern governing the way a date appears in the American style. + "Pseudo-pattern governing the way a date appears in the American style. See the documentation of `calendar-date-display-form' for an explanation." :type 'sexp :group 'calendar) ＠＠ -687,7 +677,7 ＠＠ (if european-calendar-style european-calendar-display-form american-calendar-display-form) - "*Pseudo-pattern governing the way a date appears. + "Pseudo-pattern governing the way a date appears. Used by the function `calendar-date-string', a pseudo-pattern is a list of expressions that can involve the keywords `month', `day', and `year', all ＠＠ -728,7 +718,7 ＠＠ ;;;###autoload (defcustom print-diary-entries-hook 'lpr-buffer - "*List of functions called after a temporary diary buffer is prepared. + "List of functions called after a temporary diary buffer is prepared. The buffer shows only the diary entries currently visible in the diary buffer. The default just does the printing. Other uses might include, for example, rearranging the lines into order by day and time, saving the buffer ＠＠ -738,7 +728,7 ＠＠ ;;;###autoload (defcustom list-diary-entries-hook nil - "*List of functions called after diary file is culled for relevant entries. + "List of functions called after diary file is culled for relevant entries. It is to be used for diary entries that are not found in the diary file. A function `include-other-diary-files' is provided for use as the value of ＠＠ -764,18 +754,19 ＠＠ diary entries from various included files, each day's entries sorted into lexicographic order." :type 'hook +:options '(include-other-diary-files sort-diary-entries) :group 'diary) ;;;###autoload (defcustom diary-hook nil - "*List of functions called after the display of the diary. + "List of functions called after the display of the diary. Can be used for appointment notification." :type 'hook :group 'diary) ;;;###autoload (defcustom diary-display-hook nil - "*List of functions that handle the display of the diary. + "List of functions that handle the display of the diary. If nil (the default), `simple-diary-display' is used. Use `ignore' for no diary display. ＠＠ -796,21 +787,26 ＠＠ if that day is a holiday; if you want such days to be shown in the fancy diary buffer, set the variable `diary-list-include-blanks' to t." :type 'hook +:options '(fancy-diary-display) :group 'diary) ;;;###autoload (defcustom nongregorian-diary-listing-hook nil - "*List of functions called for listing diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `list-hebrew-diary-entries' -and `list-islamic-diary-entries'. The documentation for these functions + "List of functions called for listing diary file and included files. +As the files are processed for diary entries, these functions are used +to cull relevant entries. You can use either or both of +`list-hebrew-diary-entries', `list-islamic-diary-entries' and +`list-bahai-diary-entries'. The documentation for these functions describes the style of such diary entries." :type 'hook +:options '(list-hebrew-diary-entries + list-islamic-diary-entries + list-bahai-diary-entries) :group 'diary) ;;;###autoload (defcustom mark-diary-entries-hook nil - "*List of functions called after marking diary entries in the calendar. + "List of functions called after marking diary entries in the calendar. A function `mark-included-diary-files' is also provided for use as the `mark-diary-entries-hook'; it enables you to use shared diary files together ＠＠ -823,21 +819,26 ＠＠ part of the mark-diary-entries-hook, you will probably also want to use the function `include-other-diary-files' as part of `list-diary-entries-hook'." :type 'hook +:options '(mark-included-diary-files) :group 'diary) ;;;###autoload (defcustom nongregorian-diary-marking-hook nil - "*List of functions called for marking diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `mark-hebrew-diary-entries' -and `mark-islamic-diary-entries'. The documentation for these functions + "List of functions called for marking diary file and included files. +As the files are processed for diary entries, these functions are used +to cull relevant entries. You can use either or both of +`mark-hebrew-diary-entries', `mark-islamic-diary-entries' and +`mark-bahai-diary-entries'. The documentation for these functions describes the style of such diary entries." :type 'hook +:options '(mark-hebrew-diary-entries + mark-islamic-diary-entries + mark-bahai-diary-entries) :group 'diary) ;;;###autoload (defcustom diary-list-include-blanks nil - "*If nil, do not include days with no diary entry in the list of diary entries. + "If nil, do not include days with no diary entry in the list of diary entries. Such days will then not be shown in the fancy diary buffer, even if they are holidays." :type 'boolean ＠＠ -845,7 +846,7 ＠＠ ;;;###autoload (defcustom holidays-in-diary-buffer t - "*Non-nil means include holidays in the diary display. + "Non-nil means include holidays in the diary display. The holidays appear in the mode line of the diary buffer, or in the fancy diary buffer next to the date. This slows down the diary functions somewhat; setting it to nil makes the diary display faster." ＠＠ -875,7 +876,7 ＠＠ (holiday-fixed 10 31 "Halloween") (holiday-fixed 11 11 "Veteran's Day") (holiday-float 11 4 4 "Thanksgiving")) - "*General holidays. Default value is for the United States. + "General holidays. Default value is for the United States. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -885,8 +886,8 ＠＠ ;;;###autoload (defcustom oriental-holidays '((if (fboundp 'atan) - (holiday-chinese-new-year))) - "*Oriental holidays. + (holiday-chinese-new-year))) + "Oriental holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -895,7 +896,7 ＠＠ (put 'local-holidays 'risky-local-variable t) ;;;###autoload (defcustom local-holidays nil - "*Local holidays. + "Local holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'local ＠＠ -905,7 +906,7 ＠＠ (put 'other-holidays 'risky-local-variable t) ;;;###autoload (defcustom other-holidays nil - "*User defined holidays. + "User defined holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -1009,7 +1010,7 ＠＠ ;;;###autoload (defcustom hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 hebrew-holidays-3 hebrew-holidays-4) - "*Jewish holidays. + "Jewish holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -1020,17 +1021,47 ＠＠ (defcustom christian-holidays '((if all-christian-calendar-holidays (holiday-fixed 1 6 "Epiphany")) - (holiday-easter-etc) + (holiday-easter-etc 0 "Easter Sunday") + (holiday-easter-etc -2 "Good Friday") + (holiday-easter-etc -46 "Ash Wednesday") + (if all-christian-calendar-holidays + (holiday-easter-etc -63 "Septuagesima Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -56 "Sexagesima Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -49 "Shrove Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -48 "Shrove Monday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -47 "Shrove Tuesday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -14 "Passion Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -7 "Palm Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc -3 "Maundy Thursday")) + (if all-christian-calendar-holidays + (holiday-easter-etc 35 "Rogation Sunday")) (if all-christian-calendar-holidays + (holiday-easter-etc 39 "Ascension Day")) + (if all-christian-calendar-holidays + (holiday-easter-etc 49 "Pentecost (Whitsunday)")) + (if all-christian-calendar-holidays + (holiday-easter-etc 50 "Whitmonday")) + (if all-christian-calendar-holidays + (holiday-easter-etc 56 "Trinity Sunday")) + (if all-christian-calendar-holidays + (holiday-easter-etc 60 "Corpus Christi")) + (if all-christian-calendar-holidays (holiday-greek-orthodox-easter)) (if all-christian-calendar-holidays (holiday-fixed 8 15 "Assumption")) (if all-christian-calendar-holidays - (holiday-advent)) + (holiday-advent 0 "Advent")) (holiday-fixed 12 25 "Christmas") (if all-christian-calendar-holidays (holiday-julian 12 25 "Eastern Orthodox Christmas"))) - "*Christian holidays. + "Christian holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -1065,12 +1096,54 ＠＠ (holiday-islamic 10 1 "Id-al-Fitr")) (if all-islamic-calendar-holidays (holiday-islamic 12 10 "Id-al-Adha"))) - "*Islamic holidays. + "Islamic holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ;;;###autoload +(put 'bahai-holidays 'risky-local-variable t) +;;;###autoload +(defcustom bahai-holidays + '((holiday-fixed + 3 21 + (format "Baha'i New Year (Naw-Ruz) %d" (- displayed-year (1- 1844)))) + (holiday-fixed 4 21 "First Day of Ridvan") + (if all-bahai-calendar-holidays + (holiday-fixed 4 22 "Second Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 23 "Third Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 24 "Fourth Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 25 "Fifth Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 26 "Sixth Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 27 "Seventh Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 4 28 "Eighth Day of Ridvan")) + (holiday-fixed 4 29 "Ninth Day of Ridvan") + (if all-bahai-calendar-holidays + (holiday-fixed 4 30 "Tenth Day of Ridvan")) + (if all-bahai-calendar-holidays + (holiday-fixed 5 1 "Eleventh Day of Ridvan")) + (holiday-fixed 5 2 "Twelfth Day of Ridvan") + (holiday-fixed 5 23 "Declaration of the Bab") + (holiday-fixed 5 29 "Ascension of Baha'u'llah") + (holiday-fixed 7 9 "Martyrdom of the Bab") + (holiday-fixed 10 20 "Birth of the Bab") + (holiday-fixed 11 12 "Birth of Baha'u'llah") + (if all-bahai-calendar-holidays + (holiday-fixed 11 26 "Day of the Covenant")) + (if all-bahai-calendar-holidays + (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha"))) + "Baha'i holidays. +See the documentation for `calendar-holidays' for details." +:type 'sexp +:group 'holidays) + +;;;###autoload (put 'solar-holidays 'risky-local-variable t) ;;;###autoload (defcustom solar-holidays ＠＠ -1097,7 +1170,7 ＠＠ (/ calendar-daylight-savings-ends-time (float 60)) calendar-daylight-time-zone-name) "")))) - "*Sun-related holidays. + "Sun-related holidays. See the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) ＠＠ -1107,16 +1180,28 ＠＠ (defcustom calendar-holidays (append general-holidays local-holidays other-holidays christian-holidays hebrew-holidays islamic-holidays - oriental-holidays solar-holidays) - "*List of notable days for the command \\[holidays]. + bahai-holidays oriental-holidays solar-holidays) + "List of notable days for the command \\[holidays]. + +Additional holidays are easy to add to the list, just put them in the +list `other-holidays' in your .emacs file. Similarly, by setting any +of `general-holidays', `local-holidays' `christian-holidays', +`hebrew-holidays', `islamic-holidays', `bahai-holidays', +`oriental-holidays', or `solar-holidays' to nil in your .emacs file, +you can eliminate unwanted categories of holidays. + +The aforementioned variables control the holiday choices offered +by the function `list-holidays' when it is called interactively. + +They also initialize the default value of `calendar-holidays', +which is the default list of holidays used by the function +`list-holidays' in the non-interactive case. Note that these +variables have no effect on `calendar-holidays' after it has been +set (e.g. after the calendar is loaded). In that case, customize +`calendar-holidays' directly. -Additional holidays are easy to add to the list, just put them in the list -`other-holidays' in your .emacs file. Similarly, by setting any of -`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', -`islamic-holidays', `oriental-holidays', or `solar-holidays' to nil in your -.emacs file, you can eliminate unwanted categories of holidays. The intention -is that (in the US) `local-holidays' be set in site-init.el and -`other-holidays' be set by the user. +The intention is that (in the US) `local-holidays' be set in +site-init.el and `other-holidays' be set by the user. Entries on the list are expressions that return (possibly empty) lists of items of the form ((month day year) string) of a holiday in the in the ＠＠ -1127,10 +1212,11 ＠＠ (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in MONTH on the Gregorian calendar (0 for Sunday, etc.); K<0 means count back from the end of the - month. An optional parameter DAY means the Kth + month. An optional parameter DAY means the Kth DAYNAME after/before MONTH DAY. (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar + (holiday-bahai MONTH DAY STRING) a fixed date on the Baha'i calendar (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression in the variable `year'; if it evaluates to ＠＠ -1158,6 +1244,11 ＠＠ (holiday-islamic 3 12 \"Mohammed's Birthday\") since the Islamic months are numbered from 1 starting with Muharram. To +add an entry for the Baha'i festival of Ridvan, use + + (holiday-bahai 2 13 \"Festival of Ridvan\") + +since the Baha'i months are numbered from 1 starting with Baha. To add Thomas Jefferson's birthday, April 2, 1743 (Julian), use (holiday-julian 4 2 \"Jefferson's Birthday\") ＠＠ -1167,7 +1258,7 ＠＠ Tuesday after the first Monday in November of years divisible by 4, add (holiday-sexp - (if (zerop (% year 4)) + '(if (zerop (% year 4)) (calendar-gregorian-from-absolute (1+ (calendar-dayname-on-or-before 1 (+ 6 (calendar-absolute-from-gregorian ＠＠ -1196,9 +1287,6 ＠＠ (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... )." :type 'sexp :group 'holidays) - -(defconst calendar-buffer "*Calendar*" - "Name of the buffer used for the calendar.") (defconst holiday-buffer "*Holidays*" "Name of the buffer used for the displaying the holidays.") ＠＠ -1213,22 +1301,38 ＠＠ "Name of the buffer used for the lunar phases.") (defmacro increment-calendar-month (mon yr n) - "Move the variables MON and YR to the month and year by N months. -Forward if N is positive or backward if N is negative." - `(let ((macro-y (+ (* ,yr 12) ,mon -1 ,n))) - (setq ,mon (1+ (% macro-y 12))) - (setq ,yr (/ macro-y 12)))) + "Increment the variables MON and YR by N months. +Forward if N is positive or backward if N is negative. +A negative YR is interpreted as BC; -1 being 1 BC, and so on." + `(let (macro-y) + (if (< ,yr 0) (setq ,yr (1+ ,yr))) ; -1 BC -> 0 AD, etc + (setq macro-y (+ (* ,yr 12) ,mon -1 ,n) + ,mon (1+ (mod macro-y 12)) + ,yr (/ macro-y 12)) + (and (< macro-y 0) (> ,mon 1) (setq ,yr (1- ,yr))) + (if (< ,yr 1) (setq ,yr (1- ,yr))))) ; 0 AD -> -1 BC, etc + +(defun calendar-increment-month (n &optional mon yr) + "Return the Nth month after MON/YR. +The return value is a pair (MONTH . YEAR). +MON defaults to `displayed-month'. YR defaults to `displayed-year'." + (unless mon (setq mon displayed-month)) + (unless yr (setq yr displayed-year)) + (increment-calendar-month mon yr n) + (cons mon yr)) (defmacro calendar-for-loop (var from init to final do &rest body) "Execute a for loop." + (declare (debug (symbolp "from" form "to" form "do" body))) `(let ((,var (1- ,init))) (while (>= ,final (setq ,var (1+ ,var))) ,＠body))) (defmacro calendar-sum (index initial condition expression) "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION." + (declare (debug (symbolp form form form))) `(let ((,index ,initial) - (sum 0)) + (sum 0)) (while ,condition (setq sum (+ sum ,expression)) (setq ,index (1+ ,index))) ＠＠ -1268,6 +1372,7 ＠＠ "Extract the month part of DATE which has the form (month day year)." (car date)) +;; Note gives wrong answer for result of (calendar-read-date 'noday). (defsubst extract-calendar-day (date) "Extract the day part of DATE which has the form (month day year)." (car (cdr date))) ＠＠ -1277,7 +1382,10 ＠＠ (car (cdr (cdr date)))) (defsubst calendar-leap-year-p (year) - "Return t if YEAR is a Gregorian leap year." + "Return t if YEAR is a Gregorian leap year. +A negative year is interpreted as BC; -1 being 1 BC, and so on." + ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc. + (if (< year 0) (setq year (1- (abs year)))) (and (zerop (% year 4)) (or (not (zerop (% year 100))) (zerop (% year 400))))) ＠＠ -1317,13 +1425,30 ＠＠ (defsubst calendar-absolute-from-gregorian (date) "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let ((prior-years (1- (extract-calendar-year date)))) - (+ (calendar-day-number date);; Days this year - (* 365 prior-years);; + Days in prior years - (/ prior-years 4);; + Julian leap years - (- (/ prior-years 100));; - century years - (/ prior-years 400))));; + Gregorian leap years +The Gregorian date Sunday, December 31, 1 BC is imaginary. +DATE is a list of the form (month day year). A negative year is +interpreted as BC; -1 being 1 BC, and so on. Dates before 12/31/1 BC +return negative results." + (let ((year (extract-calendar-year date)) + offset-years) + (cond ((= year 0) + (error "There was no year zero")) + ((> year 0) + (setq offset-years (1- year)) + (+ (calendar-day-number date) ; Days this year + (* 365 offset-years) ; + Days in prior years + (/ offset-years 4) ; + Julian leap years + (- (/ offset-years 100)) ; - century years + (/ offset-years 400))) ; + Gregorian leap years + (t + ;; Years between date and 1 BC, excluding 1 BC (1 for 2 BC, etc). + (setq offset-years (abs (1+ year))) + (- (calendar-day-number date) + (* 365 offset-years) + (/ offset-years 4) + (- (/ offset-years 100)) + (/ offset-years 400) + (calendar-day-number '(12 31 -1))))))) ; days in year 1 BC (autoload 'calendar-goto-today "cal-move" "Reposition the calendar window so the current date is visible." ＠＠ -1413,22 +1538,39 ＠＠ "Move cursor to DATE." t) +(autoload 'calendar-goto-day-of-year "cal-move" + "Move cursor to day of year." + t) + (autoload 'calendar-only-one-frame-setup "cal-x" - "Start calendar and display it in a dedicated frame.") + "Start calendar and display it in a dedicated frame.") (autoload 'calendar-one-frame-setup "cal-x" "Start calendar and display it in a dedicated frame together with the diary.") (autoload 'calendar-two-frame-setup "cal-x" "Start calendar and diary in separate, dedicated frames.") - + ;;;###autoload -(defvar calendar-setup nil - "The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dedicated frame), `two-frames' (calendar and diary in separate, dedicated -frames), `calendar-only' (calendar in a separate, dedicated frame); with -any other value the current frame is used.") +(defcustom calendar-setup nil + "The frame setup of the calendar. +The choices are: `one-frame' (calendar and diary together in one separate, +dedicated frame); `two-frames' (calendar and diary in separate, dedicated +frames); `calendar-only' (calendar in a separate, dedicated frame); with +any other value the current frame is used. Using any of the first +three options overrides the value of `view-diary-entries-initially'." +:type '(choice + (const :tag "calendar and diary in separate frame" one-frame) + (const :tag "calendar and diary each in own frame" two-frames) + (const :tag "calendar in separate frame" calendar-only) + (const :tag "use current frame" nil)) +:group 'calendar) + +(defcustom calendar-minimum-window-height 8 + "Minimum height `generate-calendar-window' should use for calendar window." +:type 'integer +:version "22.1" +:group 'calendar) ;;;###autoload (defun calendar (&optional arg) ＠＠ -1481,7 +1623,7 ＠＠ `initial-calendar-window-hook' are run. The hooks given by the variable `today-visible-calendar-hook' are run -everytime the calendar window gets scrolled, if the current date is visible +every time the calendar window gets scrolled, if the current date is visible in the window. If it is not visible, the hooks given by the variable `today-invisible-calendar-hook' are run. Thus, for example, setting `today-visible-calendar-hook' to 'calendar-star-date will cause today's date ＠＠ -1496,14 +1638,14 ＠＠ (calendar-current-date))) (month (extract-calendar-month date)) (year (extract-calendar-year date))) + ;; (calendar-read-date t) returns a date with day = nil, which is + ;; not a legal date for the visible test in the diary section. + (if arg (setcar (cdr date) 1)) (pop-to-buffer calendar-buffer) (increment-calendar-month month year (- calendar-offset)) (generate-calendar-window month year) (if (and view-diary-entries-initially (calendar-date-is-visible-p date)) - (view-diary-entries - (if (vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date)) - number-of-diary-entries)))) + (diary-view-entries))) (let* ((diary-buffer (get-file-buffer diary-file)) (diary-window (if diary-buffer (get-buffer-window diary-buffer))) (split-height-threshold (if diary-window 2 1000))) ＠＠ -1511,13 +1653,20 ＠＠ (list-calendar-holidays))) (run-hooks 'initial-calendar-window-hook)) -(autoload 'view-diary-entries "diary-lib" +(autoload 'diary-view-entries "diary-lib" "Prepare and display a buffer with diary entries. Searches your diary file for entries that match ARG days starting with the date indicated by the cursor position in the displayed three-month calendar." t) +(autoload 'view-other-diary-entries "diary-lib" + "Prepare and display buffer of diary entries from an alternative diary file. +Searches for entries that match ARG days, starting with the date indicated +by the cursor position in the displayed three-month calendar. +D-FILE specifies the file to use as the diary file." + t) + (autoload 'calendar-sunrise-sunset "solar" "Local time of sunrise and sunset for date under cursor." t) ＠＠ -1535,12 +1684,10 ＠＠ t) (autoload 'calendar-french-date-string "cal-french" - "String of French Revolutionary date of Gregorian date." - t) + "String of French Revolutionary date of Gregorian date.") (autoload 'calendar-mayan-date-string "cal-mayan" - "String of Mayan date of Gregorian date." - t) + "String of Mayan date of Gregorian date.") (autoload 'calendar-print-mayan-date "cal-mayan" "Show the Mayan long count, Tzolkin, and Haab equivalents of the date under the cursor." ＠＠ -1583,19 +1730,17 ＠＠ t) (autoload 'calendar-chinese-date-string "cal-china" - "String of Chinese date of Gregorian date." - t) + "String of Chinese date of Gregorian date.") -(autoload 'calendar-absolute-from-astro "cal-julian" +(autoload 'calendar-absolute-from-astro "cal-julian" "Absolute date of astronomical (Julian) day number D." - t) + t ) (autoload 'calendar-astro-from-absolute "cal-julian" "Astronomical (Julian) day number of absolute date D.") (autoload 'calendar-astro-date-string "cal-julian" - "String of astronomical (Julian) day number of Gregorian date." - t) + "String of astronomical (Julian) day number of Gregorian date.") (autoload 'calendar-goto-astro-day-number "cal-julian" "Move cursor to astronomical (Julian) day number." ＠＠ -1627,13 +1772,16 ＠＠ "Move cursor to ISO date." t) +(autoload 'calendar-goto-iso-week "cal-iso" + "Move cursor to start of ISO week." + t) + (autoload 'calendar-print-iso-date "cal-iso" "Show the ISO date equivalents of date." t) (autoload 'calendar-iso-date-string "cal-iso" - "String of ISO date of Gregorian date." - t) + "String of ISO date of Gregorian date.") (autoload 'calendar-goto-islamic-date "cal-islam" "Move cursor to Islamic date." ＠＠ -1644,11 +1792,17 ＠＠ t) (autoload 'calendar-islamic-date-string "cal-islam" - "String of Islamic date of Gregorian date." + "String of Islamic date of Gregorian date.") + +(autoload 'calendar-print-bahai-date "cal-bahai" + "Show the Baha'i date equivalents of date." t) +(autoload 'calendar-bahai-date-string "cal-bahai" + "String of Baha'i date of Gregorian date.") + (autoload 'calendar-goto-hebrew-date "cal-hebrew" - "Move cursor to Hebrew date date." + "Move cursor to Hebrew date." t) (autoload 'calendar-print-hebrew-date "cal-hebrew" ＠＠ -1656,11 +1810,10 ＠＠ t) (autoload 'calendar-hebrew-date-string "cal-hebrew" - "String of Hebrew date of Gregorian date." - t) + "String of Hebrew date of Gregorian date.") (autoload 'calendar-goto-coptic-date "cal-coptic" - "Move cursor to Coptic date date." + "Move cursor to Coptic date." t) (autoload 'calendar-print-coptic-date "cal-coptic" ＠＠ -1668,23 +1821,21 ＠＠ t) (autoload 'calendar-coptic-date-string "cal-coptic" - "String of Coptic date of Gregorian date." - t) + "String of Coptic date of Gregorian date.") (autoload 'calendar-goto-ethiopic-date "cal-coptic" - "Move cursor to Ethiopic date date." - t) + "Move cursor to Ethiopic date." + t) (autoload 'calendar-print-ethiopic-date "cal-coptic" - "Show the Ethiopic date equivalents of date." - t) + "Show the Ethiopic date equivalents of date." + t) (autoload 'calendar-ethiopic-date-string "cal-coptic" - "String of Ethiopic date of Gregorian date." - t) + "String of Ethiopic date of Gregorian date.") (autoload 'calendar-goto-persian-date "cal-persia" - "Move cursor to Persian date date." + "Move cursor to Persian date." t) (autoload 'calendar-print-persian-date "cal-persia" ＠＠ -1692,10 +1843,9 ＠＠ t) (autoload 'calendar-persian-date-string "cal-persia" - "String of Persian date of Gregorian date." - t) + "String of Persian date of Gregorian date.") -(autoload 'show-all-diary-entries "diary-lib" +(autoload 'diary-show-all-entries "diary-lib" "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 ＠＠ -1708,8 +1858,7 ＠＠ t) (autoload 'make-diary-entry "diary-lib" - "Insert a diary entry STRING which may be NONMARKING in FILE." - t) + "Insert a diary entry STRING which may be NONMARKING in FILE.") (autoload 'insert-diary-entry "diary-lib" "Insert a diary entry for the date indicated by point." ＠＠ -1770,6 +1919,21 ＠＠ to the date indicated by point." t) +(autoload 'insert-bahai-diary-entry "cal-bahai" + "Insert a diary entry for the Baha'i date corresponding to the date +indicated by point." + t) + +(autoload 'insert-monthly-bahai-diary-entry "cal-bahai" + "Insert a monthly diary entry for the day of the Baha'i month corresponding +to the date indicated by point." + t) + +(autoload 'insert-yearly-bahai-diary-entry "cal-bahai" + "Insert an annual diary entry for the day of the Baha'i year corresponding +to the date indicated by point." + t) + (autoload 'list-calendar-holidays "holidays" "Create a buffer containing the holidays for the current calendar window. The holidays are those in the list `calendar-notable-days'. Returns t if any ＠＠ -1779,69 +1943,69 ＠＠ (autoload 'cal-tex-cursor-month "cal-tex" "Make a buffer with LaTeX commands for the month cursor is on. Optional prefix argument specifies number of months to be produced. -Calendar is condensed onto one page.") +Calendar is condensed onto one page." t) (autoload 'cal-tex-cursor-month-landscape "cal-tex" "Make a buffer with LaTeX commands for the month cursor is on. -Optional prefix argument specifies number of months to be produced.") +Optional prefix argument specifies number of months to be produced." t) (autoload 'cal-tex-cursor-day "cal-tex" - "Make a buffer with LaTeX commands for the day cursor is on.") + "Make a buffer with LaTeX commands for the day cursor is on." t) (autoload 'cal-tex-cursor-week "cal-tex" "Make a buffer with LaTeX commands for a two-page one-week calendar. It applies to the week that point is in. Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) -(autoload 'cal-tex-cursor-week2 "cal-tex" +(autoload 'cal-tex-cursor-week2 "cal-tex" "Make a buffer with LaTeX commands for a two-page one-week calendar. It applies to the week that point is in. Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-week-iso "cal-tex" "Make a buffer with LaTeX commands for a one page ISO-style weekly calendar. Optional prefix argument specifies number of weeks. Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-week-monday "cal-tex" "Make a buffer with LaTeX commands for a two-page one-week calendar. It applies to the week that point is in, and starts on Monday. Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-filofax-2week "cal-tex" "Two-weeks-at-a-glance Filofax style calendar for week indicated by cursor. Optional prefix argument specifies number of weeks. Diary entries are included if cal-tex-diary is t. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-filofax-week "cal-tex" "One-week-at-a-glance Filofax style calendar for week indicated by cursor. Optional prefix argument specifies number of weeks. -Weeks start on Monday. +Weeks start on Monday. Diary entries are included if cal-tex-diary is t. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-filofax-daily "cal-tex" "Day-per-page Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. Weeks start on Monday. +Optional prefix argument specifies number of weeks. Weeks start on Monday. Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t.") +Holidays are included if `cal-tex-holidays' is t." t) (autoload 'cal-tex-cursor-year "cal-tex" "Make a buffer with LaTeX commands for a year's calendar. -Optional prefix argument specifies number of years.") +Optional prefix argument specifies number of years." t) (autoload 'cal-tex-cursor-year-landscape "cal-tex" "Make a buffer with LaTeX commands for a year's calendar (landscape). -Optional prefix argument specifies number of years.") +Optional prefix argument specifies number of years." t) (autoload 'cal-tex-cursor-filofax-year "cal-tex" "Make a buffer with LaTeX commands for a year's calendar (Filofax). -Optional prefix argument specifies number of years.") +Optional prefix argument specifies number of years." t) (autoload 'mark-calendar-holidays "holidays" "Mark notable days in the calendar window." ＠＠ -1863,25 +2027,36 ＠＠ (or (not mon) (let ((offset (calendar-interval mon yr month year))) (and (<= offset 1) (>= offset -1))))) - (day-in-week (calendar-day-of-week today))) + (day-in-week (calendar-day-of-week today)) + (in-calendar-window (eq (window-buffer (selected-window)) + (get-buffer calendar-buffer)))) (update-calendar-mode-line) (if mon (generate-calendar mon yr) - (generate-calendar month year)) + (generate-calendar month year)) (calendar-cursor-to-visible-date (if today-visible today (list displayed-month 1 displayed-year))) (set-buffer-modified-p nil) - (if (or (one-window-p t) (/= (frame-width) (window-width))) - ;; Don't mess with the window size, but ensure that the first - ;; line is fully visible - (if (fboundp 'set-window-vscroll) - (set-window-vscroll nil 0)) - ;; Adjust the window to exactly fit the displayed calendar - (cal-fit-window-to-buffer)) - (sit-for 0) + ;; Don't do any window-related stuff if we weren't called from a + ;; window displaying the calendar + (when in-calendar-window + (if (or (one-window-p t) (/= (frame-width) (window-width))) + ;; Don't mess with the window size, but ensure that the first + ;; line is fully visible + ;; XEmacs change. XEmacs doesn't have this function + (if (fboundp 'set-window-vscroll) + (set-window-vscroll nil 0)) + ;; Adjust the window to exactly fit the displayed calendar + ;; XEmacs change, f-w-t-b shows up in 21.5 + (cal-fit-window-to-buffer)) + (sit-for 0)) + (if (and (boundp 'font-lock-mode) + font-lock-mode) + (font-lock-fontify-buffer)) (and mark-holidays-in-calendar +;;; (calendar-date-is-legal-p today) ; useful for BC dates (mark-calendar-holidays) - (sit-for 0)) + (and in-calendar-window (sit-for 0))) (unwind-protect (if mark-diary-entries-in-calendar (mark-diary-entries)) (if today-visible ＠＠ -1890,10 +2065,14 ＠＠ (defun generate-calendar (month year) "Generate a three-month Gregorian calendar centered around MONTH, YEAR." +;;; A negative YEAR is interpreted as BC; -1 being 1 BC, and so on. +;;; Note that while calendars for years BC could be displayed as it +;;; stands, almost all other calendar functions (eg holidays) would +;;; at best have unpredictable results for such dates. (if (< (+ month (* 12 (1- year))) 2) - (error "Months before February, 1 AD are not available")) - (setq displayed-month month) - (setq displayed-year year) + (error "Months before January, 1 AD cannot be displayed")) + (setq displayed-month month + displayed-year year) (erase-buffer) (increment-calendar-month month year -1) (calendar-for-loop i from 0 to 2 do ＠＠ -1921,10 +2100,15 ＠＠ (calendar-year-name year month 1))) ? 20) indent t) (calendar-insert-indented "" indent);; Go to proper spot + ;; Use the first two characters of each day to head the columns. (calendar-for-loop i from 0 to 6 do - (insert (calendar-day-name (mod (+ calendar-week-start-day i) 7) - 2 t)) - (insert " ")) + (insert + (let ((string + (calendar-day-name (mod (+ calendar-week-start-day i) 7) nil t))) + (if enable-multibyte-characters + (truncate-string-to-width string 2) + (substring string 0 2))) + " ")) (calendar-insert-indented "" 0 t);; Force onto following line (calendar-insert-indented "" indent);; Go to proper spot ;; Add blank days before the first of the month ＠＠ -1932,9 +2116,12 ＠＠ ;; Put in the days of the month (calendar-for-loop i from 1 to last do (insert (format "%2d " i)) - (add-text-properties (- (point) (if (< i 10) 2 3)) (1- (point)) - '(mouse-face highlight - help-echo "mouse-2:menu of operations for this date")) + (add-text-properties + ;; XEmacs change. + ;; This makes the extent the width of the date, 1 vs 2 digits wide. + (- (point) (if (< i 10) 2 3)) (1- (point)) + '(mouse-face highlight + help-echo "mouse-2: menu of operations for this date")) (and (zerop (mod (+ i blank-days) 7)) (/= i last) (calendar-insert-indented "" 0 t) ;; Force onto following line ＠＠ -1961,142 +2148,174 ＠＠ t) (defun redraw-calendar () - "Redraw the calendar display." + "Redraw the calendar display, if `calendar-buffer' is live." (interactive) - (let ((cursor-date (calendar-cursor-to-nearest-date))) - (generate-calendar-window displayed-month displayed-year) - (calendar-cursor-to-visible-date cursor-date))) + (if (get-buffer calendar-buffer) + (with-current-buffer calendar-buffer + (let ((cursor-date (calendar-cursor-to-nearest-date))) + (generate-calendar-window displayed-month displayed-year) + (calendar-cursor-to-visible-date cursor-date))))) + +;;;###autoload +;; XEmacs - for now we are keeping this original definition +;; if I use the newer definition, I get autoload errors about regexp-opt +(defcustom calendar-week-start-day 0 + "The day of the week on which a week in the calendar begins. +0 means Sunday (default), 1 means Monday, and so on. + +If you change this variable directly (without using customize) +after starting `calendar', you should call `redraw-calendar' to +update the calendar display to reflect the change, otherwise +movement commands will not work correctly." +:type 'integer +:set (lambda (sym val) + (set sym val) + (let ((buffer (get-buffer calendar-buffer))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (redraw-calendar))))) +:group 'calendar) (defcustom calendar-debug-sexp nil - "*Turn debugging on when evaluating a sexp in the diary or holiday list." + "Turn debugging on when evaluating a sexp in the diary or holiday list." :type 'boolean :group 'calendar) (defvar calendar-mode-map nil) (if calendar-mode-map nil - (setq calendar-mode-map (make-sparse-keymap)) - (calendar-for-loop i from 0 to 9 do - (define-key calendar-mode-map (int-to-string i) 'digit-argument)) - (let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph - 'mark-defun 'mark-whole-buffer 'mark-page - 'downcase-region 'upcase-region 'kill-region - 'copy-region-as-kill 'capitalize-region 'write-region))) - (while l - (substitute-key-definition (car l) 'calendar-not-implemented - calendar-mode-map global-map) - (setq l (cdr l)))) - (define-key calendar-mode-map "-" 'negative-argument) - (define-key calendar-mode-map "\C-x>" 'scroll-calendar-right) - (define-key calendar-mode-map [prior] 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\ev" 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\C-x<" 'scroll-calendar-left) - (define-key calendar-mode-map [next] 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-v" 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-b" 'calendar-backward-day) - (define-key calendar-mode-map "\C-p" 'calendar-backward-week) - (define-key calendar-mode-map "\e{" 'calendar-backward-month) - (define-key calendar-mode-map "\C-x[" 'calendar-backward-year) - (define-key calendar-mode-map "\C-f" 'calendar-forward-day) - (define-key calendar-mode-map "\C-n" 'calendar-forward-week) - (define-key calendar-mode-map [left] 'calendar-backward-day) - (define-key calendar-mode-map [up] 'calendar-backward-week) - (define-key calendar-mode-map [right] 'calendar-forward-day) - (define-key calendar-mode-map [down] 'calendar-forward-week) - (define-key calendar-mode-map "\e}" 'calendar-forward-month) - (define-key calendar-mode-map "\C-x]" 'calendar-forward-year) - (define-key calendar-mode-map "\C-a" 'calendar-beginning-of-week) - (define-key calendar-mode-map "\C-e" 'calendar-end-of-week) - (define-key calendar-mode-map "\ea" 'calendar-beginning-of-month) - (define-key calendar-mode-map "\ee" 'calendar-end-of-month) - (define-key calendar-mode-map "\e<" 'calendar-beginning-of-year) - (define-key calendar-mode-map "\e>" 'calendar-end-of-year) - (define-key calendar-mode-map "\C-＠" 'calendar-set-mark) - ;; Many people are used to typing C-SPC and getting C-＠. - (define-key calendar-mode-map [?\C- ] 'calendar-set-mark) - (define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark) - (define-key calendar-mode-map "\e=" 'calendar-count-days-region) - (define-key calendar-mode-map "gd" 'calendar-goto-date) - (define-key calendar-mode-map "gj" 'calendar-goto-julian-date) - (define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number) - (define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date) - (define-key calendar-mode-map "gi" 'calendar-goto-islamic-date) - (define-key calendar-mode-map "gC" 'calendar-goto-chinese-date) - (define-key calendar-mode-map "gk" 'calendar-goto-coptic-date) - (define-key calendar-mode-map "ge" 'calendar-goto-ethiopic-date) - (define-key calendar-mode-map "gp" 'calendar-goto-persian-date) - (define-key calendar-mode-map "gc" 'calendar-goto-iso-date) - (define-key calendar-mode-map "gf" 'calendar-goto-french-date) - (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date) - (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date) - (define-key calendar-mode-map "gmnc" 'calendar-next-calendar-round-date) - (define-key calendar-mode-map "gmph" 'calendar-previous-haab-date) - (define-key calendar-mode-map "gmnh" 'calendar-next-haab-date) - (define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date) - (define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date) - (define-key calendar-mode-map "Aa" 'appt-add) - (define-key calendar-mode-map "Ad" 'appt-delete) - (define-key calendar-mode-map "S" 'calendar-sunrise-sunset) - (define-key calendar-mode-map "M" 'calendar-phases-of-moon) - (define-key calendar-mode-map " " 'scroll-other-window) - (define-key calendar-mode-map [backspace] 'scroll-other-window-down) - (define-key calendar-mode-map "\C-c\C-l" 'redraw-calendar) - (define-key calendar-mode-map "." 'calendar-goto-today) - (define-key calendar-mode-map "o" 'calendar-other-month) - (define-key calendar-mode-map "q" 'exit-calendar) - (define-key calendar-mode-map "a" 'list-calendar-holidays) - (define-key calendar-mode-map "h" 'calendar-cursor-holidays) - (define-key calendar-mode-map "x" 'mark-calendar-holidays) - (define-key calendar-mode-map "u" 'calendar-unmark) - (define-key calendar-mode-map "m" 'mark-diary-entries) - (define-key calendar-mode-map "d" 'view-diary-entries) - (define-key calendar-mode-map "D" 'view-other-diary-entries) - (define-key calendar-mode-map "s" 'show-all-diary-entries) - (define-key calendar-mode-map "pd" 'calendar-print-day-of-year) - (define-key calendar-mode-map "pC" 'calendar-print-chinese-date) - (define-key calendar-mode-map "pk" 'calendar-print-coptic-date) - (define-key calendar-mode-map "pe" 'calendar-print-ethiopic-date) - (define-key calendar-mode-map "pp" 'calendar-print-persian-date) - (define-key calendar-mode-map "pc" 'calendar-print-iso-date) - (define-key calendar-mode-map "pj" 'calendar-print-julian-date) - (define-key calendar-mode-map "pa" 'calendar-print-astro-day-number) - (define-key calendar-mode-map "ph" 'calendar-print-hebrew-date) - (define-key calendar-mode-map "pi" 'calendar-print-islamic-date) - (define-key calendar-mode-map "pf" 'calendar-print-french-date) - (define-key calendar-mode-map "pm" 'calendar-print-mayan-date) - (define-key calendar-mode-map "po" 'calendar-print-other-dates) - (define-key calendar-mode-map "id" 'insert-diary-entry) - (define-key calendar-mode-map "iw" 'insert-weekly-diary-entry) - (define-key calendar-mode-map "im" 'insert-monthly-diary-entry) - (define-key calendar-mode-map "iy" 'insert-yearly-diary-entry) - (define-key calendar-mode-map "ia" 'insert-anniversary-diary-entry) - (define-key calendar-mode-map "ib" 'insert-block-diary-entry) - (define-key calendar-mode-map "ic" 'insert-cyclic-diary-entry) - (define-key calendar-mode-map "ihd" 'insert-hebrew-diary-entry) - (define-key calendar-mode-map "ihm" 'insert-monthly-hebrew-diary-entry) - (define-key calendar-mode-map "ihy" 'insert-yearly-hebrew-diary-entry) - (define-key calendar-mode-map "iid" 'insert-islamic-diary-entry) - (define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry) - (define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry) - (define-key calendar-mode-map "?" 'calendar-goto-info-node) - (define-key calendar-mode-map "tm" 'cal-tex-cursor-month) - (define-key calendar-mode-map "tM" 'cal-tex-cursor-month-landscape) - (define-key calendar-mode-map "td" 'cal-tex-cursor-day) - (define-key calendar-mode-map "tw1" 'cal-tex-cursor-week) - (define-key calendar-mode-map "tw2" 'cal-tex-cursor-week2) - (define-key calendar-mode-map "tw3" 'cal-tex-cursor-week-iso) - (define-key calendar-mode-map "tw4" 'cal-tex-cursor-week-monday) - (define-key calendar-mode-map "tfd" 'cal-tex-cursor-filofax-daily) - (define-key calendar-mode-map "tfw" 'cal-tex-cursor-filofax-2week) - (define-key calendar-mode-map "tfW" 'cal-tex-cursor-filofax-week) - (define-key calendar-mode-map "tfy" 'cal-tex-cursor-filofax-year) - (define-key calendar-mode-map "ty" 'cal-tex-cursor-year) - (define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape)) + (let ((map (make-keymap))) + ;; XEmacs change. Uncommenting this make xemacs puke. + ;; (suppress-keymap map) + (dolist (c '(narrow-to-region mark-word mark-sexp mark-paragraph + mark-defun mark-whole-buffer mark-page + downcase-region upcase-region kill-region + copy-region-as-kill capitalize-region write-region)) + (define-key map (vector 'remap c) 'calendar-not-implemented)) + (define-key map ">" 'scroll-calendar-right) + (define-key map "\C-x>" 'scroll-calendar-right) + (define-key map [prior] 'scroll-calendar-right-three-months) + (define-key map "\ev" 'scroll-calendar-right-three-months) + (define-key map "<" 'scroll-calendar-left) + (define-key map "\C-x<" 'scroll-calendar-left) + (define-key map [next] 'scroll-calendar-left-three-months) + (define-key map "\C-v" 'scroll-calendar-left-three-months) + (define-key map "\C-b" 'calendar-backward-day) + (define-key map "\C-p" 'calendar-backward-week) + (define-key map "\e{" 'calendar-backward-month) + (define-key map "\C-x[" 'calendar-backward-year) + (define-key map "\C-f" 'calendar-forward-day) + (define-key map "\C-n" 'calendar-forward-week) + (define-key map [left] 'calendar-backward-day) + (define-key map [up] 'calendar-backward-week) + (define-key map [right] 'calendar-forward-day) + (define-key map [down] 'calendar-forward-week) + (define-key map "\e}" 'calendar-forward-month) + (define-key map "\C-x]" 'calendar-forward-year) + (define-key map "\C-a" 'calendar-beginning-of-week) + (define-key map "\C-e" 'calendar-end-of-week) + (define-key map "\ea" 'calendar-beginning-of-month) + (define-key map "\ee" 'calendar-end-of-month) + (define-key map "\e<" 'calendar-beginning-of-year) + (define-key map "\e>" 'calendar-end-of-year) + (define-key map "\C-＠" 'calendar-set-mark) + ;; Many people are used to typing C-SPC and getting C-＠. + (define-key map [?\C- ] 'calendar-set-mark) + (define-key map "\C-x\C-x" 'calendar-exchange-point-and-mark) + (define-key map "\e=" 'calendar-count-days-region) + (define-key map "gd" 'calendar-goto-date) + (define-key map "gD" 'calendar-goto-day-of-year) + (define-key map "gj" 'calendar-goto-julian-date) + (define-key map "ga" 'calendar-goto-astro-day-number) + (define-key map "gh" 'calendar-goto-hebrew-date) + (define-key map "gi" 'calendar-goto-islamic-date) + (define-key map "gb" 'calendar-goto-bahai-date) + (define-key map "gC" 'calendar-goto-chinese-date) + (define-key map "gk" 'calendar-goto-coptic-date) + (define-key map "ge" 'calendar-goto-ethiopic-date) + (define-key map "gp" 'calendar-goto-persian-date) + (define-key map "gc" 'calendar-goto-iso-date) + (define-key map "gw" 'calendar-goto-iso-week) + (define-key map "gf" 'calendar-goto-french-date) + (define-key map "gml" 'calendar-goto-mayan-long-count-date) + (define-key map "gmpc" 'calendar-previous-calendar-round-date) + (define-key map "gmnc" 'calendar-next-calendar-round-date) + (define-key map "gmph" 'calendar-previous-haab-date) + (define-key map "gmnh" 'calendar-next-haab-date) + (define-key map "gmpt" 'calendar-previous-tzolkin-date) + (define-key map "gmnt" 'calendar-next-tzolkin-date) + (define-key map "Aa" 'appt-add) + (define-key map "Ad" 'appt-delete) + (define-key map "S" 'calendar-sunrise-sunset) + (define-key map "M" 'calendar-phases-of-moon) + (define-key map " " 'scroll-other-window) + (define-key map (kbd "DEL") 'scroll-other-window-down) + (define-key map [backspace] 'scroll-other-window-down) + (define-key map "\C-c\C-l" 'redraw-calendar) + (define-key map "." 'calendar-goto-today) + (define-key map "o" 'calendar-other-month) + (define-key map "q" 'exit-calendar) + (define-key map "a" 'list-calendar-holidays) + (define-key map "h" 'calendar-cursor-holidays) + (define-key map "x" 'mark-calendar-holidays) + (define-key map "u" 'calendar-unmark) + (define-key map "m" 'mark-diary-entries) + (define-key map "d" 'diary-view-entries) + (define-key map "D" 'view-other-diary-entries) + (define-key map "s" 'diary-show-all-entries) + (define-key map "pd" 'calendar-print-day-of-year) + (define-key map "pC" 'calendar-print-chinese-date) + (define-key map "pk" 'calendar-print-coptic-date) + (define-key map "pe" 'calendar-print-ethiopic-date) + (define-key map "pp" 'calendar-print-persian-date) + (define-key map "pc" 'calendar-print-iso-date) + (define-key map "pj" 'calendar-print-julian-date) + (define-key map "pa" 'calendar-print-astro-day-number) + (define-key map "ph" 'calendar-print-hebrew-date) + (define-key map "pi" 'calendar-print-islamic-date) + (define-key map "pb" 'calendar-print-bahai-date) + (define-key map "pf" 'calendar-print-french-date) + (define-key map "pm" 'calendar-print-mayan-date) + (define-key map "po" 'calendar-print-other-dates) + (define-key map "id" 'insert-diary-entry) + (define-key map "iw" 'insert-weekly-diary-entry) + (define-key map "im" 'insert-monthly-diary-entry) + (define-key map "iy" 'insert-yearly-diary-entry) + (define-key map "ia" 'insert-anniversary-diary-entry) + (define-key map "ib" 'insert-block-diary-entry) + (define-key map "ic" 'insert-cyclic-diary-entry) + (define-key map "ihd" 'insert-hebrew-diary-entry) + (define-key map "ihm" 'insert-monthly-hebrew-diary-entry) + (define-key map "ihy" 'insert-yearly-hebrew-diary-entry) + (define-key map "iid" 'insert-islamic-diary-entry) + (define-key map "iim" 'insert-monthly-islamic-diary-entry) + (define-key map "iiy" 'insert-yearly-islamic-diary-entry) + (define-key map "iBd" 'insert-bahai-diary-entry) + (define-key map "iBm" 'insert-monthly-bahai-diary-entry) + (define-key map "iBy" 'insert-yearly-bahai-diary-entry) + (define-key map "?" 'calendar-goto-info-node) + (define-key map "tm" 'cal-tex-cursor-month) + (define-key map "tM" 'cal-tex-cursor-month-landscape) + (define-key map "td" 'cal-tex-cursor-day) + (define-key map "tw1" 'cal-tex-cursor-week) + (define-key map "tw2" 'cal-tex-cursor-week2) + (define-key map "tw3" 'cal-tex-cursor-week-iso) + (define-key map "tw4" 'cal-tex-cursor-week-monday) + (define-key map "tfd" 'cal-tex-cursor-filofax-daily) + (define-key map "tfw" 'cal-tex-cursor-filofax-2week) + (define-key map "tfW" 'cal-tex-cursor-filofax-week) + (define-key map "tfy" 'cal-tex-cursor-filofax-year) + (define-key map "ty" 'cal-tex-cursor-year) + (define-key map "tY" 'cal-tex-cursor-year-landscape) + (setq calendar-mode-map map) + (require 'cal-xemacs))) (defun describe-calendar-mode () "Create a help buffer with a brief description of the `calendar-mode'." (interactive) - (with-output-to-temp-buffer "*Help*" + ;; XEmacs - we don't have this + ;; (help-setup-xref (list #'describe-calendar-mode) (interactive-p)) + (with-output-to-temp-buffer (help-buffer) (princ (format "Calendar Mode:\nFor a complete description, type %s\n%s\n" ＠＠ -2111,38 +2330,44 ＠＠ ;; Calendar mode is suitable only for specially formatted data. (put 'calendar-mode 'mode-class 'special) -;; XEmacs - usage of propertize here is essentially a no-op. -;; xemacs doesn't support text properties in the mode-line. -;; (defvar calendar-mode-line-format (list - (propertize (substitute-command-keys - "\\<calendar-mode-map>\\[scroll-calendar-left]") + (propertize (substitute-command-keys + "\\<calendar-mode-map>\\[scroll-calendar-left]") 'help-echo "mouse-2: scroll left" - ) + 'mouse-face 'modeline-mousable + 'keymap (make-mode-line-mouse-map 'button2 + 'mouse-scroll-calendar-left)) "Calendar" (concat - (propertize - (substitute-command-keys + (propertize + (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info") 'help-echo "mouse-2: read Info on Calendar" - ) + 'mouse-face 'modeline-mousable + 'keymap (make-mode-line-mouse-map 'button2 'calendar-goto-info-node)) "/" (propertize (substitute-command-keys - "\\<calendar-mode-map>\\[calendar-other-month] other") + "\\<calendar-mode-map>\\[calendar-other-month] other") 'help-echo "mouse-2: choose another month" - ) + 'mouse-face 'modeline-mousable + 'keymap (make-mode-line-mouse-map + 'button2 'mouse-calendar-other-month)) "/" (propertize (substitute-command-keys - "\\<calendar-mode-map>\\[calendar-goto-today] today") + "\\<calendar-mode-map>\\[calendar-goto-today] today") 'help-echo "mouse-2: go to today's date" - '(calendar-date-string (calendar-current-date) t))) - (propertize (substitute-command-keys + 'mouse-face 'modeline-mousable + 'keymap (make-mode-line-mouse-map 'button2 #'calendar-goto-today))) + '(calendar-date-string (calendar-current-date) t) + (propertize (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]") - 'help-echo "mouse-2: scroll right" - )) + 'help-echo "mouse-2: scroll right" + 'mouse-face 'modeline-mousable + 'keymap (make-mode-line-mouse-map + 'button2 'mouse-scroll-calendar-right))) "The mode line of the calendar buffer. This must be a list of items that evaluate to strings--those strings are ＠＠ -2170,18 +2395,48 ＠＠ \"\")) ") +(defun mouse-scroll-calendar-left (event) + "Scroll the displayed calendar left by one month. +Maintains the relative position of the cursor +with respect to the calendar as well as possible." + (interactive "e") + (save-selected-window + ;; XEmacs change + (select-window (event-window event)) + (scroll-calendar-left 1))) + +(defun mouse-scroll-calendar-right (event) + "Scroll the displayed calendar right by one month. +Maintains the relative position of the cursor +with respect to the calendar as well as possible." + (interactive "e") + (save-selected-window + ;; XEmacs change + (select-window (event-window event)) + (scroll-calendar-right 1))) + +(defun mouse-calendar-other-month (event) + "Display a three-month calendar centered around a specified month and year." + (interactive "e") + (save-selected-window + ;; XEmacs change + (select-window (event-window event)) + (call-interactively 'calendar-other-month))) + (defun calendar-goto-info-node () "Go to the info node for the calendar." (interactive) (require 'info) (let ((where (save-window-excursion - (Info-find-emacs-command-nodes 'calendar)))) + (Info-find-emacs-command-nodes 'calendar)))) (if (not where) (error "Couldn't find documentation for the calendar") (let (same-window-buffer-names) - (info)) - (Info-find-node (car (car where)) (car (cdr (car where))))))) + (info)) + (Info-find-node (car (car where)) (car (cdr (car where))))))) + + (defun calendar-mode () "A major mode for the calendar window. ＠＠ -2189,7 +2444,6 ＠＠ \\<calendar-mode-map>\\[calendar-goto-info-node] from within the calendar. \\<calendar-mode-map>\\{calendar-mode-map}" - (kill-all-local-variables) (setq major-mode 'calendar-mode) (setq mode-name "Calendar") ＠＠ -2204,11 +2458,13 ＠＠ (calendar-add-menus) (make-variable-buffer-local 'scroll-on-clipped-lines) (setq scroll-on-clipped-lines nil))) - (add-hook 'activate-menubar-hook 'cal-menu-update nil t) (make-local-variable 'calendar-mark-ring) (make-local-variable 'displayed-month);; Month in middle of window. - (make-local-variable 'displayed-year));; Year in middle of window. + (make-local-variable 'displayed-year) ;; Year in middle of window. + (set (make-local-variable 'font-lock-defaults) + '(calendar-font-lock-keywords t)) + (run-mode-hooks 'calendar-mode-hook)) (defun calendar-string-spread (strings char length) "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH. ＠＠ -2231,27 +2487,26 ＠＠ (s (car strings)) (strings (cdr strings)) (i 0)) - (while strings + (dolist (string strings) (setq s (concat s (make-string (max 0 (/ (+ n i) m)) char) - (car strings))) - (setq i (1+ i)) - (setq strings (cdr strings))) + string)) + (setq i (1+ i))) ;; XEmacs change - primarily for cal-japanese (truncate-string-to-width s length))) (defun update-calendar-mode-line () "Update the calendar mode line with the current date and date style." (if (bufferp (get-buffer calendar-buffer)) - (save-excursion - (set-buffer calendar-buffer) + (with-current-buffer calendar-buffer (setq mode-line-format + (cal-tp-ml-conv (calendar-string-spread (let ((date (condition-case nil (calendar-cursor-to-nearest-date) (error (calendar-current-date))))) (mapcar 'eval calendar-mode-line-format)) - ? (frame-width))) + ? (frame-width)))) (force-mode-line-update)))) (defun calendar-window-list () ＠＠ -2259,8 +2514,8 ＠＠ (let ((calendar-buffers (calendar-buffer-list)) list) (walk-windows (lambda (w) - (if (memq (window-buffer w) calendar-buffers) - (setq list (cons w list)))) + (if (memq (window-buffer w) calendar-buffers) + (push w list))) nil t) list)) ＠＠ -2269,16 +2524,13 ＠＠ (let* ((diary-buffer (get-file-buffer diary-file)) (buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer fancy-diary-buffer diary-buffer calendar-buffer - other-calendars-buffer)) - (buffer-list nil) - b) - (while buffers - (setq b (car buffers)) + other-calendars-buffer)) + (buffer-list nil)) + (dolist (b buffers) (setq b (cond ((stringp b) (get-buffer b)) ((bufferp b) b) (t nil))) - (if b (setq buffer-list (cons b buffer-list))) - (setq buffers (cdr buffers))) + (if b (push b buffer-list))) buffer-list)) (defun exit-calendar () ＠＠ -2286,14 +2538,14 ＠＠ (interactive) (let* ((diary-buffer (get-file-buffer diary-file))) (if (or (not diary-buffer) - (not (buffer-modified-p diary-buffer)) - (yes-or-no-p - "Diary modified; do you really want to exit the calendar? ")) - ;; Need to do this multiple times because one time can replace some - ;; calendar-related buffers with other calendar-related buffers - (mapcar (lambda (x) - (mapcar 'calendar-hide-window (calendar-window-list))) - (calendar-window-list))))) + (not (buffer-modified-p diary-buffer)) + (yes-or-no-p + "Diary modified; do you really want to exit the calendar? ")) + ;; Need to do this multiple times because one time can replace some + ;; calendar-related buffers with other calendar-related buffers + (mapcar (lambda (x) + (mapcar 'calendar-hide-window (calendar-window-list))) + (calendar-window-list))))) (defun calendar-hide-window (window) "Hide WINDOW if it is calendar-related." ＠＠ -2306,9 +2558,9 ＠＠ (window-frame window)))))) nil) ((and (display-multi-frame-p) (window-dedicated-p window)) - (if calendar-remove-frame-by-deleting - (delete-frame (window-frame window)) - (iconify-frame (window-frame window)))) + (if calendar-remove-frame-by-deleting + (delete-frame (window-frame window)) + (iconify-frame (window-frame window)))) ((not (and (select-window window) (one-window-p window))) (delete-window window)) (t (set-buffer buffer) ＠＠ -2328,31 +2580,32 ＠＠ ;; changes allowing that to be in another frame. ; (if (not (number-or-marker-p displayed-month)) ; nil - (let* ((segment (/ (current-column) 25)) - (month (% (+ displayed-month segment -1) 12)) - (month (if (= 0 month) 12 month)) - (year - (cond - ((and (= 12 month) (= segment 0)) (1- displayed-year)) - ((and (= 1 month) (= segment 2)) (1+ displayed-year)) - (t displayed-year)))) + (let* ((segment (/ (current-column) 25)) + (month (% (+ displayed-month segment -1) 12)) + (month (if (= 0 month) 12 month)) + (year + (cond + ((and (= 12 month) (= segment 0)) (1- displayed-year)) + ((and (= 1 month) (= segment 2)) (1+ displayed-year)) + (t displayed-year)))) (if (and (looking-at "[ 0-9]?[0-9][^0-9]") - (< 2 (count-lines (point-min) (point)))) - (save-excursion + (< 2 (count-lines (point-min) (point)))) + (save-excursion (if (not (looking-at " ")) (re-search-backward "[^0-9]")) - (list month - (string-to-int (buffer-substring (1+ (point)) (+ 4 (point)))) - year)) - (if (looking-at "\\*") - (save-excursion - (re-search-backward "[^*]") - (if (looking-at ".\\*\\*") - (list month calendar-starred-day year) - (if error (error "Not on a date!")))) - (if error (error "Not on a date!")))))) + (list month + (string-to-number (buffer-substring (1+ (point)) (+ 4 (point)))) + year)) + (if (and (looking-at "\\*") + (save-excursion + (re-search-backward "[^*]") + (looking-at ".\\*\\*"))) + (list month calendar-starred-day year) + (if error (error "Not on a date!")))))) ;) +(add-to-list 'debug-ignored-errors "Not on a date!") + ;; The following version of calendar-gregorian-from-absolute is preferred for ;; reasons of clarity, BUT it's much slower than the version that follows it. ＠＠ -2380,7 +2633,8 ＠＠ (defun calendar-gregorian-from-absolute (date) "Compute the list (month day year) corresponding to the absolute DATE. The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." +Gregorian date Sunday, December 31, 1 BC. This function does not +handle dates in years BC." ;; See the footnote on page 384 of ``Calendrical Calculations, Part II: ;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. ;; Clamen, Software--Practice and Experience, Volume 23, Number 4 ＠＠ -2428,7 +2682,7 ＠＠ (let ((date (calendar-cursor-to-date t))) (if (null arg) (progn - (setq calendar-mark-ring (cons date calendar-mark-ring)) + (push date calendar-mark-ring) ;; Since the top of the mark ring is the marked date in the ;; calendar, the mark ring in the calendar is one longer than ;; in other buffers to get the same effect. ＠＠ -2483,7 +2737,7 ＠＠ "Prompt for Gregorian date. Return a list (month day year). If optional NODAY is t, does not ask for day, but just returns \(month nil year); if NODAY is any other non-nil value the value returned is -\(month year) " +\(month year)" (let* ((year (calendar-read "Year (>0): " (lambda (x) (> x 0)) ＠＠ -2491,12 +2745,13 ＠＠ (calendar-current-date))))) (month-array calendar-month-name-array) (completion-ignore-case t) - (month (cdr (assoc-ignore-case + ;; XEmacs change, we don't have assoc-string + (month (cdr (cal-assoc-string (completing-read "Month name: " (mapcar 'list (append month-array nil)) nil t) - (calendar-make-alist month-array 1)))) + (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year))) (if noday (if (eq noday t) ＠＠ -2504,84 +2759,178 ＠＠ (list month year)) (list month (calendar-read (format "Day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))) + (lambda (x) (and (< 0 x) (<= x last)))) year)))) (defun calendar-interval (mon1 yr1 mon2 yr2) - "The number of months difference between MON1, YR1 and MON2, YR2." + "The number of months difference between MON1, YR1 and MON2, YR2. +The result is positive if the second date is later than the first. +Negative years are interpreted as years BC; -1 being 1 BC, and so on." + (if (< yr1 0) (setq yr1 (1+ yr1))) ; -1 BC -> 0 AD, etc + (if (< yr2 0) (setq yr2 (1+ yr2))) (+ (* 12 (- yr2 yr1)) (- mon2 mon1))) -(defun calendar-day-name (date &optional width absolute) - "Return a string with the name of the day of the week of DATE. -If WIDTH is non-nil, return just the first WIDTH characters of the name. -If ABSOLUTE is non-nil, then DATE is actually the day-of-the-week -rather than a date." - (let ((string (aref calendar-day-name-array - (if absolute date (calendar-day-of-week date))))) -; (if width -; (let ((i 0) (result "") (pos 0)) -; (while (and (< i width) (< i (length string))) -; (let ((chartext (char-to-string (aref string pos)))) -; (setq pos (+ pos (length chartext))) -; (setq result (concat result chartext))) -; (setq i (1+ i))) -; result) -; string))) +(defvar calendar-abbrev-length 3 + "*Length of abbreviations to be used for day and month names. +See also `calendar-day-abbrev-array' and `calendar-month-abbrev-array'.") - (cond ((null width) string) - (enable-multibyte-characters (truncate-string-to-width string width)) - (t (substring string 0 width))))) - - +;; XEmacs change for cal-japanese (defvar calendar-english-day-name-array ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) + (defvar calendar-day-name-array calendar-english-day-name-array - "Array of capitalized strings giving, in order, the day names.") + "*Array of capitalized strings giving, in order, the day names. +The first two characters of each string will be used to head the +day columns in the calendar. See also the variable +`calendar-day-abbrev-array'.") + +(defvar calendar-day-abbrev-array + [nil nil nil nil nil nil nil] + "*Array of capitalized strings giving the abbreviated day names. +The order should be the same as that of the full names specified +in `calendar-day-name-array'. These abbreviations may be used +instead of the full names in the diary file. Do not include a +trailing `.' in the strings specified in this variable, though +you may use such in the diary file. If any element of this array +is nil, then the abbreviation will be constructed as the first +`calendar-abbrev-length' characters of the corresponding full name.") +;; XEmacs change for cal-japanese (defvar calendar-english-month-name-array ["January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"]) + (defvar calendar-month-name-array calendar-english-month-name-array - "Array of capitalized strings giving, in order, the month names.") + "*Array of capitalized strings giving, in order, the month names. +See also the variable `calendar-month-abbrev-array'.") -(defun calendar-make-alist (sequence &optional start-index filter) +(defvar calendar-month-abbrev-array + [nil nil nil nil nil nil nil nil nil nil nil nil] + "*Array of capitalized strings giving the abbreviated month names. +The order should be the same as that of the full names specified +in `calendar-month-name-array'. These abbreviations are used in +the calendar menu entries, and can also be used in the diary +file. Do not include a trailing `.' in the strings specified in +this variable, though you may use such in the diary file. If any +element of this array is nil, then the abbreviation will be +constructed as the first `calendar-abbrev-length' characters of the +corresponding full name.") + +(defun calendar-abbrev-construct (abbrev full &optional period) + "Internal calendar function to return a complete abbreviation array. +ABBREV is an array of abbreviations, FULL the corresponding array +of full names. The return value is the ABBREV array, with any nil +elements replaced by the first three characters taken from the +corresponding element of FULL. If optional argument PERIOD is non-nil, +each element returned has a final `.' character." + (let (elem array name) + (dotimes (i (length full)) + (setq name (aref full i) + elem (or (aref abbrev i) + (substring name 0 + (min calendar-abbrev-length (length name)))) + elem (format "%s%s" elem (if period "." "")) + array (append array (list elem)))) + (vconcat array))) + +(defvar calendar-font-lock-keywords + `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t) + " -?[0-9]+") + . font-lock-function-name-face) ; month and year + (,(regexp-opt + (list (substring (aref calendar-day-name-array 6) 0 2) + (substring (aref calendar-day-name-array 0) 0 2))) + ;; Saturdays and Sundays are hilited differently. + . font-lock-comment-face) + ;; First two chars of each day are used in the calendar. + (,(regexp-opt (mapcar (lambda (x) (substring x 0 2)) calendar-day-name-array)) + . font-lock-reference-face)) + "Default keywords to highlight in Calendar mode.") + +(defun calendar-day-name (date &optional abbrev absolute) + "Return a string with the name of the day of the week of DATE. +DATE should be a list in the format (MONTH DAY YEAR), unless the +optional argument ABSOLUTE is non-nil, in which case DATE should +be an integer in the range 0 to 6 corresponding to the day of the +week. Day names are taken from the variable `calendar-day-name-array', +unless the optional argument ABBREV is non-nil, in which case +the variable `calendar-day-abbrev-array' is used." + (aref (if abbrev + (calendar-abbrev-construct calendar-day-abbrev-array + calendar-day-name-array) + calendar-day-name-array) + (if absolute date (calendar-day-of-week date)))) + +(defun calendar-make-alist (sequence &optional start-index filter abbrevs) "Make an assoc list corresponding to SEQUENCE. -Start at index 1, unless optional START-INDEX is provided. -If FILTER is provided, apply it to each item in the list." - (let ((index (if start-index (1- start-index) 0))) - (mapcar - (lambda (x) - (setq index (1+ index)) - (cons (if filter (funcall filter x) x) - index)) - (append sequence nil)))) - -(defun calendar-month-name (month &optional width) - "The name of MONTH. -If WIDTH is non-nil, return just the first WIDTH characters of the name." - (let ((string (aref calendar-month-name-array (1- month)))) - (if width - (let ((i 0) (result "") (pos 0)) - ;; XEmacs change - primarily for cal-japanese. - (while (and (< i width) (< i (length string))) - (let ((chartext (char-to-string (aref string pos)))) - (setq pos (+ pos (length chartext))) - (setq result (concat result chartext))) - (setq i (1+ i))) - result) - string))) +Each element of sequence will be associated with an integer, starting +from 1, or from START-INDEX if that is non-nil. If a sequence ABBREVS +is supplied, the function `calendar-abbrev-construct' is used to +construct abbreviations corresponding to the elements in SEQUENCE. +Each abbreviation is entered into the alist with the same +association index as the full name it represents. +If FILTER is provided, apply it to each key in the alist." + (let ((index 0) + (offset (or start-index 1)) + (aseq (if abbrevs (calendar-abbrev-construct abbrevs sequence))) + (aseqp (if abbrevs (calendar-abbrev-construct abbrevs sequence + 'period))) + alist elem) + (dotimes (i (length sequence) (reverse alist)) + (setq index (+ i offset) + elem (elt sequence i) + alist + (cons (cons (if filter (funcall filter elem) elem) index) alist)) + (if aseq + (setq elem (elt aseq i) + alist (cons (cons (if filter (funcall filter elem) elem) + index) alist))) + (if aseqp + (setq elem (elt aseqp i) + alist (cons (cons (if filter (funcall filter elem) elem) + index) alist)))))) +;(defun calendar-month-name (month &optional width) +; "The name of MONTH. +;If WIDTH is non-nil, return just the first WIDTH characters of the name." +; (let ((string (aref calendar-month-name-array (1- month)))) +; (if width +; (let ((i 0) (result "") (pos 0)) +; ;; XEmacs change - primarily for cal-japanese. +; (while (and (< i width) (< i (length string))) +; (let ((chartext (char-to-string (aref string pos)))) +; (setq pos (+ pos (length chartext))) +; (setq result (concat result chartext))) +; (setq i (1+ i))) +; result) +; string))) +(defun calendar-month-name (month &optional abbrev) + "Return a string with the name of month number MONTH. +Months are numbered from one. Month names are taken from the +variable `calendar-month-name-array', unless the optional +argument ABBREV is non-nil, in which case +`calendar-month-abbrev-array' is used." + (aref (if abbrev + (calendar-abbrev-construct calendar-month-abbrev-array + calendar-month-name-array) + calendar-month-name-array) + (1- month))) + +;; XEmacs only (defun calendar-english-year-name (year month day) (format "%d" year)) (defvar calendar-year-name-function 'calendar-english-year-name) +;; XEmacs only (defun calendar-year-name (year month day) (funcall calendar-year-name-function year month day)) (defun calendar-day-of-week (date) - "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc." - (% (calendar-absolute-from-gregorian date) 7)) + "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc. +DATE is a list of the form (month day year). A negative year is +interpreted as BC; -1 being 1 BC, and so on." + (mod (calendar-absolute-from-gregorian date) 7)) (defun calendar-unmark () "Delete all diary/holiday marks/highlighting from the calendar." ＠＠ -2591,19 +2940,26 ＠＠ (redraw-calendar)) (defun calendar-date-is-visible-p (date) - "Return t if DATE is legal and is visible in the calendar window." + "Return t if DATE is valid and is visible in the calendar window." (let ((gap (calendar-interval displayed-month displayed-year (extract-calendar-month date) (extract-calendar-year date)))) (and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap)))) (defun calendar-date-is-legal-p (date) - "Return t if DATE is a legal date." + "Return t if DATE is a valid date." (let ((month (extract-calendar-month date)) (day (extract-calendar-day date)) (year (extract-calendar-year date))) (and (<= 1 month) (<= month 12) - (<= 1 day) (<= day (calendar-last-day-of-month month year)) + ;; (calendar-read-date t) returns a date with day = nil. + ;; Should not be valid (?), since many funcs prob assume integer. + ;; (calendar-read-date 'noday) returns (month year), which + ;; currently results in extract-calendar-year returning nil. + day year (<= 1 day) (<= day (calendar-last-day-of-month month year)) + ;; BC dates left as non-valid, to suppress errors from + ;; complex holiday algorithms not suitable for years BC. + ;; Note there are side effects on calendar navigation. (<= 1 year)))) (defun calendar-date-equal (date1 date2) ＠＠ -2615,36 +2971,77 ＠＠ (defun mark-visible-calendar-date (date &optional mark) "Mark DATE in the calendar window with MARK. -MARK is either a single-character string or a face. +MARK is a single-character string, a list of face attributes/values, or a face. MARK defaults to `diary-entry-marker'." (if (calendar-date-is-legal-p date) - (save-excursion - (set-buffer calendar-buffer) - (calendar-cursor-to-visible-date date) - (let ((mark (or mark diary-entry-marker))) - (if (stringp mark) - (let ((buffer-read-only nil)) - (forward-char 1) - (delete-char 1) - (insert mark) - (forward-char -2)) - (set-extent-property (make-extent (1- (point)) (1+ (point))) - 'face mark)))))) + (with-current-buffer calendar-buffer + (save-excursion + (calendar-cursor-to-visible-date date) + (setq mark + (or (and (stringp mark) (= (length mark) 1) mark) ; single-char + (and (listp mark) (> (length mark) 0) mark) ; attr list + ;; XEmacs change, our facep != Emacs facep + (and (facep (find-face mark)) mark) ; face-name + diary-entry-marker)) + (cond + ;; face or an attr-list that contained a face + ;; XEmacs change, our facep != Emacs facep + ((and (symbolp mark) + (facep (find-face mark))) + ;; XEmacs change, we use extents, not overlays + (set-extent-property + (make-extent (1- (point)) (1+ (point))) 'face mark)) + ;; single-char + ((and (stringp mark) (= (length mark) 1)) + (let ((inhibit-read-only t)) + (forward-char 1) + ;; Insert before delete so as to better preserve markers. + (insert mark) + (delete-char 1) + (forward-char -2))) + (t ;; attr list + (let ((temp-face + (make-symbol + (apply 'concat "temp-" + (mapcar (lambda (sym) + (cond + ((symbolp sym) (symbol-name sym)) + ((numberp sym) (number-to-string sym)) + (t sym))) + mark)))) + (faceinfo mark)) + (make-face temp-face) + ;; Remove :face info from the mark, copy the face info into + ;; temp-face + (while (setq faceinfo (memq :face faceinfo)) + (copy-face (read (nth 1 faceinfo)) temp-face) + (setcar faceinfo nil) + (setcar (cdr faceinfo) nil)) + (setq mark (delq nil mark)) + ;; Apply the font aspects + ;; XEmacs change. Emacs has set-face-attribute + ;; face-custom-attributes-set is equivalent + (apply 'face-custom-attributes-set temp-face nil nil mark) + ;; XEmacs change, we use extents, not overlays + (set-extent-property + (make-extent (1- (point)) (1+ (point))) 'face temp-face)))))))) (defun calendar-star-date () "Replace the date under the cursor in the calendar window with asterisks. This function can be used with the `today-visible-calendar-hook' run after the calendar window has been prepared." - (let ((inhibit-read-only t)) - (make-local-variable 'calendar-starred-day) + (let ((inhibit-read-only t) + (modified (buffer-modified-p))) (forward-char 1) - (setq calendar-starred-day - (string-to-int - (buffer-substring (point) (- (point) 2)))) - (delete-char -2) + (set (make-local-variable 'calendar-starred-day) + (string-to-number + (buffer-substring (point) (- (point) 2)))) + ;; Insert before deleting, to better preserve markers. (insert "**") - (backward-char 1) - (set-buffer-modified-p nil))) + (forward-char -2) + (delete-char -2) + (forward-char 1) + (restore-buffer-modified-p modified))) (defun calendar-mark-today () "Mark the date under the cursor in the calendar window. ＠＠ -2663,20 +3060,16 ＠＠ (defun calendar-date-string (date &optional abbreviate nodayname) "A string form of DATE, driven by the variable `calendar-date-display-form'. -An optional parameter ABBREVIATE, when t, causes the month and day names to be -abbreviated to three characters. An optional parameter NODAYNAME, when t, -omits the name of the day of the week." +An optional parameter ABBREVIATE, when non-nil, causes the month +and day names to be abbreviated as specified by +`calendar-month-abbrev-array' and `calendar-day-abbrev-array', +respectively. An optional parameter NODAYNAME, when t, omits the +name of the day of the week." (let* ((dayname - (if nodayname - nil - (if abbreviate - (calendar-day-name date 3) - (calendar-day-name date)))) + (unless nodayname + (calendar-day-name date abbreviate))) (month (extract-calendar-month date)) - (monthname - (if abbreviate - (calendar-month-name month 3) - (calendar-month-name month))) + (monthname (calendar-month-name month abbreviate)) (day (int-to-string (extract-calendar-day date))) (month (int-to-string month)) (year (int-to-string (extract-calendar-year date)))) ＠＠ -2737,47 +3130,51 ＠＠ "Show dates on other calendars for date under the cursor." (interactive) (let* ((date (calendar-cursor-to-date t))) - (save-excursion - (set-buffer (get-buffer-create other-calendars-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (concat (calendar-date-string date) " (Gregorian)")) - (erase-buffer) - (insert - (mapconcat 'identity - (list (calendar-day-of-year-string date) - (format "ISO date: %s" (calendar-iso-date-string date)) - (format "Julian date: %s" - (calendar-julian-date-string date)) - (format - "Astronomical (Julian) day number (at noon UTC): %s.0" - (calendar-astro-date-string date)) - (format "Fixed (RD) date: %s" - (calendar-absolute-from-gregorian date)) - (format "Hebrew date (before sunset): %s" - (calendar-hebrew-date-string date)) - (format "Persian date: %s" - (calendar-persian-date-string date)) - (let ((i (calendar-islamic-date-string date))) - (if (not (string-equal i "")) - (format "Islamic date (before sunset): %s" i))) - (format "Chinese date: %s" - (calendar-chinese-date-string date)) - (let ((c (calendar-coptic-date-string date))) - (if (not (string-equal c "")) - (format "Coptic date: %s" c))) - (let ((e (calendar-ethiopic-date-string date))) - (if (not (string-equal e "")) - (format "Ethiopic date: %s" e))) - (let ((f (calendar-french-date-string date))) - (if (not (string-equal f "")) - (format "French Revolutionary date: %s" f))) - (format "Mayan date: %s" - (calendar-mayan-date-string date))) - "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) + (with-current-buffer (get-buffer-create other-calendars-buffer) + (let ((inhibit-read-only t) + (modified (buffer-modified-p))) + (calendar-set-mode-line + (concat (calendar-date-string date) " (Gregorian)")) + (erase-buffer) + (apply + 'insert + (delq nil + (list + (calendar-day-of-year-string date) "\n" + (format "ISO date: %s\n" (calendar-iso-date-string date)) + (format "Julian date: %s\n" + (calendar-julian-date-string date)) + (format "Astronomical (Julian) day number (at noon UTC): %s.0\n" + (calendar-astro-date-string date)) + (format "Fixed (RD) date: %s\n" + (calendar-absolute-from-gregorian date)) + (format "Hebrew date (before sunset): %s\n" + (calendar-hebrew-date-string date)) + (format "Persian date: %s\n" + (calendar-persian-date-string date)) + (let ((i (calendar-islamic-date-string date))) + (if (not (string-equal i "")) + (format "Islamic date (before sunset): %s\n" i))) + (let ((b (calendar-bahai-date-string date))) + (if (not (string-equal b "")) + (format "Baha'i date (before sunset): %s\n" b))) + (format "Chinese date: %s\n" + (calendar-chinese-date-string date)) + (let ((c (calendar-coptic-date-string date))) + (if (not (string-equal c "")) + (format "Coptic date: %s\n" c))) + (let ((e (calendar-ethiopic-date-string date))) + (if (not (string-equal e "")) + (format "Ethiopic date: %s\n" e))) + (let ((f (calendar-french-date-string date))) + (if (not (string-equal f "")) + (format "French Revolutionary date: %s\n" f))) + (format "Mayan date: %s\n" + (calendar-mayan-date-string date))))) + (goto-char (point-min)) + ;; XEmacs change, we don't have restore-buffer-modified-p + (set-buffer-modified-p nil) + (setq buffer-read-only t)) (display-buffer other-calendars-buffer)))) (defun calendar-print-day-of-year () ＠＠ -2787,19 +3184,35 ＠＠ (defun calendar-set-mode-line (str) "Set mode line to STR, centered, surrounded by dashes." - (setq mode-line-format - (calendar-string-spread (list str) ?- (frame-width)))) + (let* ((edges (window-pixel-edges)) + ;; Emacs: + ;; As per doc of window-width, total visible mode-line length. + ;; (width (- (nth 2 edges) (nth 0 edges)))) + + ;; XEmacs change, Emacs is calculating the full column width of the + ;; window. + ;; window-pixel-edges doesn't give the right info, but + ;; window-full-width does + ;; + (width (window-full-width))) + (setq mode-line-format + (if buffer-file-name + `("-" mode-line-modified + ,(calendar-string-spread (list str) ?- (- width 6)) + "---") + (calendar-string-spread (list str) ?- width))))) (defun calendar-mod (m n) "Non-negative remainder of M/N with N instead of 0." - (1+ (mod (1- m) n))) + (1+ (mod (1- m) n))) (run-hooks 'calendar-load-hook) (provide 'calendar) -;;; Local variables: -;;; byte-compile-dynamic: t -;;; End: +;; Local variables: +;; byte-compile-dynamic: t +;; End: +;; arch-tag: 19c61596-c8fb-4c69-bcf1-7dd739919cd8 ;;; calendar.el ends here Index: diary-lib.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/diary-lib.el,v retrieving revision 1.7 diff -u -u -r1.7 diary-lib.el --- diary-lib.el 2006/08/20 03:39:41 1.7 +++ diary-lib.el 2006/10/20 21:46:46 ＠＠ -1,9 +1,10 ＠＠ ;;; diary-lib.el --- diary functions -;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software -;; Foundation, Inc. +;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; This file is part of XEmacs. ＠＠ -20,10 +21,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; (Mostly) Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; XEmacs has extra function `diary-countdown' ;;; Commentary: ＠＠ -41,52 +42,47 ＠＠ (require 'calendar) +(defun diary-check-diary-file () + "Check that the file specified by `diary-file' exists and is readable. +If so, return the expanded file name, otherwise signal an error." + (let ((d-file (substitute-in-file-name diary-file))) + (if (and d-file (file-exists-p d-file)) + (if (file-readable-p d-file) + d-file + (error "Diary file `%s' is not readable" diary-file)) + (error "Diary file `%s' does not exist" diary-file)))) + ;;;###autoload (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." +by the variable `number-of-diary-entries'. A value of ARG less than 1 +does nothing. This function is suitable for execution in a `.emacs' file." (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (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!")))) + (diary-check-diary-file) + (let ((date (calendar-current-date))) + (diary-list-entries date (if arg (prefix-numeric-value arg))))) -(defun view-diary-entries (arg) +(define-obsolete-function-alias 'view-diary-entries 'diary-view-entries) +(defun diary-view-entries (&optional arg) "Prepare and display a buffer with diary entries. Searches the file named in `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") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) + (diary-check-diary-file) + (diary-list-entries (calendar-cursor-to-date t) arg)) (defun view-other-diary-entries (arg d-file) "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." +Searches for entries that match ARG days, starting with the date indicated +by the cursor position in the displayed three-month calendar. +D-FILE specifies the file to use as the diary file." (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) + (list (prefix-numeric-value current-prefix-arg) (read-file-name "Enter diary file name: " default-directory nil t))) (let ((diary-file d-file)) - (view-diary-entries arg))) + (diary-view-entries arg))) (autoload 'check-calendar-holidays "holidays" "Check the list of holidays for any that occur on DATE. ＠＠ -127,6 +123,18 ＠＠ (autoload 'mark-islamic-calendar-date-pattern "cal-islam" "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.") +(autoload 'diary-bahai-date "cal-bahai" + "Baha'i calendar equivalent of date diary entry.") + +(autoload 'list-bahai-diary-entries "cal-bahai" + "Add any Baha'i date entries from the diary file to `diary-entries-list'.") + +(autoload 'mark-bahai-diary-entries "cal-bahai" + "Mark days in the calendar window that have Baha'i date diary entries.") + +(autoload 'mark-bahai-calendar-date-pattern "cal-bahai" + "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.") + (autoload 'diary-hebrew-date "cal-hebrew" "Hebrew calendar equivalent of date diary entry.") ＠＠ -169,15 +177,15 ＠＠ "Local time of candle lighting diary entry--applies if date is a Friday. No diary entry if there is no sunset on that date.") -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) +(defvar diary-syntax-table + (let ((st (copy-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?* "w" st) + (modify-syntax-entry ?: "w" st) + st) "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) -(modify-syntax-entry ?: "w" diary-syntax-table) +syntax of `*' and `:' changed to be word constituents.") -(defvar diary-modified) (defvar diary-entries-list) (defvar displayed-year) (defvar displayed-month) ＠＠ -185,21 +193,183 ＠＠ (defvar date) (defvar number) (defvar date-string) -(defvar d-file) (defvar original-date) -;;;###autoload -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. +(defun diary-attrtype-convert (attrvalue type) + "Convert string ATTRVALUE to TYPE appropriate for a face description. +Valid TYPEs are: string, symbol, int, stringtnil, tnil." + (let (ret) + (setq ret (cond ((eq type 'string) attrvalue) + ((eq type 'symbol) (read attrvalue)) + ((eq type 'int) (string-to-number 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." + (save-excursion + (let (regexp regnum attrname attr-list attrname attrvalue type + ret-attr attr) + (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 (match-string-no-properties 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 (match-string-no-properties regnum entry)) + (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)))) + + +;; This can be removed once the kill/yank treatment of invisible text +;; (see etc/TODO) is fixed. -- gm +(defcustom diary-header-line-flag t + "If non-nil, `diary-simple-display' will show a header line. +The format of the header is specified by `diary-header-line-format'." +:group 'diary +:type 'boolean +:version "22.1") + +(defvar diary-selective-display nil) + +(defcustom diary-header-line-format + '(:eval (calendar-string-spread + (list (if diary-selective-display + "Selective display active - press \"s\" in calendar \ +before edit/copy" + "Diary")) + ?\s (frame-width))) + "Format of the header line displayed by `diary-simple-display'. +Only used if `diary-header-line-flag' is non-nil." +:group 'diary +:type 'sexp +:version "22.1") + +(defvar diary-saved-point) ; internal + + +(defcustom number-of-diary-entries 1 + "Specifies how many days of diary entries are to be displayed initially. +This variable affects the diary display when the command \\[diary] is used, +or if the value of the variable `view-diary-entries-initially' is t. For +example, if the default value 1 is used, then only the current day's diary +entries will be displayed. If the value 2 is used, then both the current +day's and the next day's entries will be displayed. + +The value can also be a vector such as [0 2 2 2 2 4 1]; this value +says to display no diary entries on Sunday, the display the entries +for the current date and the day after on Monday through Thursday, +display Friday through Monday's entries on Friday, and display only +Saturday's entries on Saturday. + +This variable does not affect the diary display with the `d' command +from the calendar; in that case, the prefix argument controls the +number of days of diary entries displayed." +:type '(choice (integer :tag "Entries") + (vector :value [0 0 0 0 0 0 0] + (integer :tag "Sunday") + (integer :tag "Monday") + (integer :tag "Tuesday") + (integer :tag "Wednesday") + (integer :tag "Thursday") + (integer :tag "Friday") + (integer :tag "Saturday"))) +:group 'diary) + + +(defvar diary-modify-entry-list-string-function nil + "Function applied to entry string before putting it into the entries list. +Can be used by programs integrating a diary list into other buffers (e.g. +org.el and planner.el) to modify the string or add properties to it. +The function takes a string argument and must return a string.") + +(defun add-to-diary-list (date string specifier &optional marker + globcolor literal) + "Add an entry to `diary-entries-list'. +Do nothing if DATE or STRING is nil. DATE is the (MONTH DAY +YEAR) for which the entry applies; STRING is the text of the +entry as it will appear in the diary (i.e. with any format +strings such as \"%d\" expanded); SPECIFIER is the date part of +the entry as it appears in the diary-file; LITERAL is the entry +as it appears in the diary-file (i.e. before expansion). If +LITERAL is nil, it is taken to be the same as STRING. + +The entry is added to the list as (DATE STRING SPECIFIER LOCATOR +GLOBCOLOR), where LOCATOR has the form (MARKER FILENAME LITERAL), +FILENAME being the file containing the diary entry." + (when (and date string) + (if diary-file-name-prefix + (let ((prefix (funcall diary-file-name-prefix-function + (buffer-file-name)))) + (or (string= prefix "") + (setq string (format "[%s] %s" prefix string))))) + (and diary-modify-entry-list-string-function + (setq string (funcall diary-modify-entry-list-string-function + string))) + (setq diary-entries-list + (append diary-entries-list + (list (list date string specifier + (list marker (buffer-file-name) literal) + globcolor)))))) + +(define-obsolete-function-alias 'list-diary-entries 'diary-list-entries) +(defun diary-list-entries (date number &optional list-only) + "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 -using selective display. +using selective display. If NUMBER is less than 1, this function does nothing. 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 specifier) where -\(month day year) is the date of the entry, string is the entry text, and -specifier is the applicability. If the variable `diary-list-include-blanks' -is t, this list includes a dummy diary entry consisting of the empty string) +The list entries have the form ((MONTH DAY YEAR) STRING SPECIFIER) where +\(MONTH DAY YEAR) is the date of the entry, STRING is the entry text, and +SPECIFIER is the applicability. If the variable `diary-list-include-blanks' +is t, this list includes a dummy diary entry consisting of the empty string for a date with no diary entries. After the list is prepared, the hooks `nongregorian-diary-listing-hook', ＠＠ -221,74 +391,74 ＠＠ add-hook to set this to ignore. `diary-hook' is run last. This can be used for an appointment - notification function." + notification function. - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - old-diary-syntax-table - diary-entries-list - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (find-buffer-visiting d-file))) - (if (not diary-buffer) - (set-buffer (find-file-noselect d-file t)) - (set-buffer diary-buffer) - (or (verify-visited-file-modtime diary-buffer) - (revert-buffer t t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - ;; First and last characters must be ^M or \n for - ;; selective display to work properly - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (goto-char (point-max)) - (insert "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert "\^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)) +If LIST-ONLY is non-nil don't modify or display the buffer, only return a list." + (unless number + (setq number (if (vectorp number-of-diary-entries) + (aref number-of-diary-entries (calendar-day-of-week date)) + number-of-diary-entries))) + (when (> number 0) + (let ((original-date date);; save for possible use in the hooks + 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 + (let ((diary-buffer (find-buffer-visiting d-file))) + (if (not diary-buffer) + (set-buffer (find-file-noselect d-file t)) + (set-buffer diary-buffer) + (or (verify-visited-file-modtime diary-buffer) + (revert-buffer t t)))) + ;; Setup things like the header-line-format and invisibility-spec. + (when (eq major-mode default-major-mode) (diary-mode)) + ;; d-s-p is passed to the diary display function. + (let ((diary-saved-point (point))) + (save-excursion + (setq file-glob-attrs (nth 1 (diary-pull-attrs nil ""))) + (with-syntax-table diary-syntax-table + (let ((mark (regexp-quote diary-nonmarking-symbol))) + (goto-char (point-min)) + (unless list-only + ;; XEmacs change. We use extents. + (let ((e (make-extent (point-min) (point-max) nil))) + (set (make-local-variable 'diary-selective-display) t) + ;; XEmacs change. We use extents. + (set-extent-property e 'invisible 'diary) + (set-extent-property e 'detachable t))) + (calendar-for-loop + i from 1 to number do + (let ((month (extract-calendar-month date)) (day (extract-calendar-day date)) (year (extract-calendar-year date)) (entry-found (list-sexp-diary-entries date))) - (while d + (dolist (date-form diary-date-forms) (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) + ((backup (when (eq (car date-form) 'backup) + (setq date-form (cdr date-form)) + t)) (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) + (format "%s\\|%s\\.?" + (calendar-day-name date) + (calendar-day-name date 'abbrev))) (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) + (format "\\*\\|%s\\|%s\\.?" + (calendar-month-name month) + (calendar-month-name month 'abbrev))) (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 "\\|" (format "%02d" (% year 100))) + (concat "\\|" (format "%02d" (% year 100))) ""))) (regexp (concat "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") + (mapconcat 'eval date-form "\\)\\(?:") "\\)")) (case-fold-search t)) (goto-char (point-min)) ＠＠ -299,45 +469,63 ＠＠ (not (looking-at " \\|\^I"))) ;; Diary entry that consists only of date. (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. + ;; Found a nonempty diary entry--make it + ;; visible and add it to the list. (setq entry-found t) (let ((entry-start (point)) - (date-start)) + date-start temp) (re-search-backward "\^M\\|\n\\|\\`") (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) + ;; When selective display (rather than + ;; overlays) was used, diary file used to + ;; start in a blank line and end in a + ;; newline. Now that neither of these + ;; need be true, 'move handles the latter + ;; and 1/2 kludge the former. + (re-search-forward + "\^M\\|\n" nil 'move + (if (and (bobp) (not (looking-at "\^M\\|\n"))) + 1 + 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) + (re-search-forward "\^M\\|\n" nil 'move)) + (unless (and (eobp) (not (bolp))) + (backward-char 1)) + (unless list-only + ;; XEmacs change. Mimic remove-overlays + (cal-remove-extents date-start (point) + 'invisible 'diary)) + (setq entry (buffer-substring entry-start (point)) + temp (diary-pull-attrs entry file-glob-attrs) + entry (nth 0 temp)) (add-to-diary-list - date - (buffer-substring - entry-start (point)) + date + entry (buffer-substring - (1+ date-start) (1- entry-start)) ))))) - (setq d (cdr d))) - (or entry-found + (1+ date-start) (1- entry-start)) + (copy-marker entry-start) (nth 1 temp))))))) + (or entry-found (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date "" ""))))) + (add-to-diary-list date "" "" "" "")) (setq date (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) + (1+ (calendar-absolute-from-gregorian date)))) + (setq entry-found nil))))) + (goto-char (point-min)) + (run-hooks 'nongregorian-diary-listing-hook + 'list-diary-entries-hook) + (unless list-only + (if diary-display-hook + (run-hooks 'diary-display-hook) + (simple-diary-display))) + (run-hooks 'diary-hook) + diary-entries-list)))))) + +(defun diary-unhide-everything () + (kill-local-variable 'diary-selective-display) + ;; XEmacs change. Mimic remove-overlays + (cal-remove-extents (point-min) (point-max) 'invisible 'diary) + (kill-local-variable 'mode-line-format)) (defun include-other-diary-files () "Include the diary entries from other diary files with those of diary-file. ＠＠ -351,34 +539,24 ＠＠ (goto-char (point-min)) (while (re-search-forward (concat - "\\(\\`\\|\^M\\|\n\\)" + "\\(?:\\`\\|\^M\\|\n\\)" (regexp-quote diary-include-string) " \"\\([^\"]*\\)\"") nil t) (let* ((diary-file (substitute-in-file-name - (buffer-substring-no-properties - (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil) - (d-buffer (find-buffer-visiting diary-file)) - (diary-modified (if d-buffer - (save-excursion - (set-buffer d-buffer) - (buffer-modified-p))))) + (match-string-no-properties 1))) + (diary-list-include-blanks nil) + (list-diary-entries-hook 'include-other-diary-files) + (diary-display-hook 'ignore) + (diary-hook nil)) (if (file-exists-p diary-file) (if (file-readable-p diary-file) (unwind-protect (setq diary-entries-list (append diary-entries-list - (list-diary-entries original-date number))) - (save-excursion - (set-buffer (find-buffer-visiting diary-file)) - (let ((inhibit-read-only t)) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)) - (setq selective-display nil) - (set-buffer-modified-p diary-modified))) + (diary-list-entries original-date number))) + (with-current-buffer (find-buffer-visiting diary-file) + (diary-unhide-everything))) (beep) (message "Can't read included diary file %s" diary-file) (sleep-for 2)) ＠＠ -391,17 +569,19 ＠＠ "Display the diary buffer if there are any relevant entries or holidays." (let* ((holiday-list (if holidays-in-diary-buffer (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) + (hol-string (format "%s%s%s" + date-string + (if holiday-list ": " "") + (mapconcat 'identity holiday-list "; "))) + (msg (format "No diary entries for %s" hol-string)) + ;; If selected window is dedicated (to the calendar), + ;; need a new one to display the diary. + (pop-up-frames (window-dedicated-p (selected-window)))) + (calendar-set-mode-line (format "Diary for %s" hol-string)) (if (or (not diary-entries-list) (and (not (cdr diary-entries-list)) (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) + (if (< (length msg) (frame-width)) (message "%s" msg) (set-buffer (get-buffer-create holiday-buffer)) (setq buffer-read-only nil) ＠＠ -413,19 +593,66 ＠＠ (setq buffer-read-only t) (display-buffer holiday-buffer) (message "No diary entries for %s" date-string)) - (display-buffer (find-buffer-visiting d-file)) + (with-current-buffer + (find-buffer-visiting (substitute-in-file-name diary-file)) + (let ((window (display-buffer (current-buffer)))) + ;; d-s-p is passed from list-diary-entries. + (set-window-point window diary-saved-point) + (set-window-start window (point-min)))) (message "Preparing diary...done")))) +(defface diary-button '((((type pc) (class color)) + (:foreground "lightblue"))) + "Default face used for buttons." +:version "22.1" +:group 'diary) +;; backward-compatibility alias +(put 'diary-button-face 'face-alias 'diary-button) + +;; XEmacs change. We don't have button.el, it's in Emacs 22 +;(define-button-type 'diary-entry +; 'action #'diary-goto-entry +; 'face #'diary-button) + +;; XEmacs change. Modified to work with our minimal button implementation. +;; Is there a better way to get the extent? +(defun diary-goto-entry (event) + (interactive "＠e") + ;; get the extents + (let* ((select-buffer (event-buffer event)) + (extents (extents-at-event event)) + (locator (cadr (mapcar (lambda (ext) + (when (extent-property ext 'locator) + (extent-property ext 'locator) ) + ) + extents))) + (marker (car locator)) + markbuf file) + ;; If marker pointing to diary location is valid, use that. + (if (and marker (setq markbuf (marker-buffer marker))) + (progn + (pop-to-buffer markbuf) + (goto-char (marker-position marker))) + ;; Marker is invalid (eg buffer has been killed). + (or (and (setq file (cadr locator)) + (file-exists-p file) + (find-file-other-window file) + (progn + (when (eq major-mode default-major-mode) (diary-mode)) + (goto-char (point-min)) + (if (re-search-forward (format "%s.*\\(%s\\)" + (regexp-quote (nth 2 locator)) + (regexp-quote (nth 3 locator))) + nil t) + (goto-char (match-beginning 1))))) + (message "Unable to locate this diary entry"))))) + (defun fancy-diary-display () "Prepare a diary buffer with relevant entries in a fancy, noneditable form. This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (find-buffer-visiting (substitute-in-file-name 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))) + (with-current-buffer ;; Turn off selective-display in the diary file's buffer. + (find-buffer-visiting (substitute-in-file-name diary-file)) + (diary-unhide-everything)) (if (or (not diary-entries-list) (and (not (cdr diary-entries-list)) (string-equal (car (cdr (car diary-entries-list))) ""))) ＠＠ -438,7 +665,6 ＠＠ (message "%s" msg) (set-buffer (get-buffer-create holiday-buffer)) (setq buffer-read-only nil) - (calendar-set-mode-line date-string) (erase-buffer) (insert (mapconcat 'identity holiday-list "\n")) (goto-char (point-min)) ＠＠ -446,8 +672,8 ＠＠ (setq buffer-read-only t) (display-buffer holiday-buffer) (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (make-fancy-diary-buffer)) + (with-current-buffer;; Prepare the fancy diary buffer. + (make-fancy-diary-buffer) (setq buffer-read-only nil) (let ((entry-list diary-entries-list) (holiday-list) ＠＠ -471,8 +697,10 ＠＠ (extract-calendar-month date)) (setq holiday-list-last-year (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) + (progn + (increment-calendar-month + holiday-list-last-month holiday-list-last-year 1) + t) (setq holiday-list (let ((displayed-month holiday-list-last-month) (displayed-year holiday-list-last-year)) ＠＠ -494,27 +722,70 ＠＠ (let* ((l (current-column)) (longest 0)) (insert (mapconcat (lambda (x) - (if (< longest (length x)) - (setq longest (length x))) - x) + (if (< longest (length x)) + (setq longest (length x))) + x) date-holiday-list (concat "\n" (make-string l ? )))) (insert ?\n (make-string (+ l longest) ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) + + (setq entry (car (cdr (car entry-list)))) + (if (< 0 (length entry)) + (let ((this-entry (car entry-list)) + this-loc) + (if (setq this-loc (nth 3 this-entry)) + (insert-button (concat entry "\n") + ;; (MARKER FILENAME SPECIFIER LITERAL) + 'locator (list (car this-loc) + (cadr this-loc) + (nth 2 this-entry) + (or (nth 2 this-loc) + (nth 1 this-entry))) + :type 'diary-entry) + (insert entry ?\n)) + (save-excursion + (let* ((marks (nth 4 this-entry)) + (faceinfo marks) + temp-face) + (when marks + (setq temp-face (make-symbol + (apply + 'concat "temp-face-" + (mapcar (lambda (sym) + (if (stringp sym) + sym + (symbol-name sym))) + marks)))) + (make-face temp-face) + ;; Remove :face info from the marks, + ;; copy the face info into temp-face + (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. + ;; XEmacs change. Emacs has set-face-attribute + ;; face-custom-attributes-set is equivalent + (apply 'face-custom-attributes-set temp-face nil nil marks) + (search-backward entry) + ;; XEmacs change, we use extents, not overlays + (set-extent-property + (make-extent (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) + (fancy-diary-display-mode) + (calendar-set-mode-line date-string) (message "Preparing diary...done")))) (defun make-fancy-diary-buffer () "Create and return the initial fancy diary buffer." - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) + (with-current-buffer (get-buffer-create fancy-diary-buffer) (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) (calendar-set-mode-line "Diary Entries") (erase-buffer) (set-buffer-modified-p nil) ＠＠ -534,26 +805,35 ＠＠ the actual printing." (interactive) (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) + (with-current-buffer (get-buffer fancy-diary-buffer) (run-hooks 'print-diary-entries-hook)) (let ((diary-buffer (find-buffer-visiting (substitute-in-file-name diary-file)))) (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) + (let ((temp-buffer (get-buffer-create " *Printable Diary Entries*")) (heading)) - (save-excursion - (set-buffer diary-buffer) + (with-current-buffer diary-buffer (setq heading (if (not (stringp mode-line-format)) "All Diary Entries" (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) + (match-string 1 mode-line-format))) + (let ((start (point-min)) + end) + (while + (progn + ;; XEmacs change, this is our equivalent to + ;; Emacs next-single-char-property-change + (setq end (next-single-property-change + start 'invisible)) + (if (get-char-property start 'invisible) + nil + (with-current-buffer temp-buffer + (insert-buffer-substring diary-buffer + start (or end (point-max))))) + (setq start end) + (and end (< end (point-max)))))) (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) (goto-char (point-min)) (insert heading "\n" (make-string (length heading) ?=) "\n") ＠＠ -561,42 +841,30 ＠＠ (kill-buffer temp-buffer))) (error "You don't have a diary buffer!"))))) -(defun show-all-diary-entries () +(define-obsolete-function-alias 'show-all-diary-entries 'diary-show-all-entries) +(defun diary-show-all-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) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (find-buffer-visiting d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-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 default-mode-line-format) - (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!")))) - - - -(defcustom diary-mail-addr - (if (boundp 'user-mail-address) user-mail-address nil) - "*Email address that `diary-mail-entries' will send email to." + (let ((d-file (diary-check-diary-file)) + (pop-up-frames (window-dedicated-p (selected-window)))) + (with-current-buffer (or (find-buffer-visiting d-file) + (find-file-noselect d-file t)) + (when (eq major-mode default-major-mode) (diary-mode)) + (diary-unhide-everything) + (display-buffer (current-buffer))))) + +(defcustom diary-mail-addr + (if (boundp 'user-mail-address) user-mail-address "") + "Email address that `diary-mail-entries' will send email to." :group 'diary -:type '(choice string (const nil)) +:type 'string :version "20.3") (defcustom diary-mail-days 7 - "*Number of days for `diary-mail-entries' to check." + "Default number of days for `diary-mail-entries' to check." :group 'diary :type 'integer :version "20.3") ＠＠ -605,6 +873,7 ＠＠ (defun diary-mail-entries (&optional ndays) "Send a mail message showing diary entries for next NDAYS days. If no prefix argument is given, NDAYS is set to `diary-mail-days'. +Mail is sent to the address specified by `diary-mail-addr'. You can call `diary-mail-entries' every night using an at/cron job. For example, this script will run the program at 2am daily. Since ＠＠ -615,9 +884,10 ＠＠ # diary-rem.sh -- repeatedly run the Emacs diary-reminder emacs -batch \\ -eval \"(setq diary-mail-days 3 \\ + diary-file \\\"/path/to/diary.file\\\" \\ european-calendar-style t \\ diary-mail-addr \\\&quot;user(a)host.name\\\&quot; )\" \\ --l diary-lib -f diary-mail-entries +-l diary-lib -f diary-mail-entries at -f diary-rem.sh 0200 tomorrow You may have to tweak the syntax of the `at' command to suit your ＠＠ -625,39 +895,36 ＠＠ 0 1 * * * diary-rem.sh to run it every morning at 1am." (interactive "P") - (let* ((diary-display-hook 'fancy-diary-display) - (diary-list-include-blanks t) - (text (progn (list-diary-entries (calendar-current-date) - (if ndays ndays diary-mail-days)) - (set-buffer fancy-diary-buffer) - (buffer-substring (point-min) (point-max))))) + (if (string-equal diary-mail-addr "") + (error "You must set `diary-mail-addr' to use this command") + (let ((diary-display-hook 'fancy-diary-display)) + (diary-list-entries (calendar-current-date) (or ndays diary-mail-days))) (compose-mail diary-mail-addr - (if (string-equal text "") - "No entries found" - (concat "Diary entries generated " - (calendar-date-string (calendar-current-date))))) - (insert text) - (funcall (get mail-user-agent 'sendfunc)))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert a STRING-ARRAY, 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; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (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) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) + (concat "Diary entries generated " + (calendar-date-string (calendar-current-date)))) + (insert + (if (get-buffer fancy-diary-buffer) + (with-current-buffer fancy-diary-buffer (buffer-string)) + "No entries found")) + (call-interactively (get mail-user-agent 'sendfunc)))) + +(defun diary-name-pattern (string-array &optional abbrev-array paren) + "Return a regexp matching the strings in the array STRING-ARRAY. +If the optional argument ABBREV-ARRAY is present, then the function +`calendar-abbrev-construct' is used to construct abbreviations from the +two supplied arrays. The returned regexp will then also match these +abbreviations, with or without final `.' characters. If the optional +argument PAREN is non-nil, the regexp is surrounded by parentheses." + (regexp-opt (append string-array + (if abbrev-array + (calendar-abbrev-construct abbrev-array + string-array)) + (if abbrev-array + (calendar-abbrev-construct abbrev-array + string-array + 'period)) + nil) + paren)) (defvar marking-diary-entries nil "True during the marking of diary entries, nil otherwise.") ＠＠ -665,126 +932,125 ＠＠ (defvar marking-diary-entry nil "True during the marking of diary entries, if current entry is marking.") -(defun mark-diary-entries () +(defun mark-diary-entries (&optional redraw) "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -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) - (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-no-properties - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring-no-properties - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring-no-properties - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring-no-properties - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring-no-properties - (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-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) - (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!")))) +Each entry in the diary file visible in the calendar window is +marked. After the entries are marked, the hooks +`nongregorian-diary-marking-hook' and `mark-diary-entries-hook' +are run. If the optional argument REDRAW is non-nil (which is +the case interactively, for example) then any existing diary +marks are first removed. This is intended to deal with deleted +diary entries." + (interactive "p") + ;; To remove any deleted diary entries. Do not redraw when: + ;; i) processing #include diary files (else only get the marks from + ;; the last #include file processed). + ;; ii) called via calendar-redraw (since calendar has already been + ;; erased). + ;; Use of REDRAW handles both of these cases. + (when (and redraw mark-diary-entries-in-calendar) + (setq mark-diary-entries-in-calendar nil) + (redraw-calendar)) + (let ((marking-diary-entries t) + file-glob-attrs marks) + (with-current-buffer (find-file-noselect (diary-check-diary-file) t) + (save-excursion + (when (eq major-mode default-major-mode) (diary-mode)) + (setq mark-diary-entries-in-calendar t) + (message "Marking diary entries...") + (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) + (with-syntax-table diary-syntax-table + (dolist (date-form diary-date-forms) + (if (eq (car date-form) 'backup) + (setq date-form (cdr date-form))) ;; ignore 'backup directive + (let* ((dayname + (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) + (monthname + (format "%s\\|\\*" + (diary-name-pattern calendar-month-name-array + calendar-month-abbrev-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 + (match-string-no-properties d-name-pos))) + (mm-name + (if m-name-pos + (match-string-no-properties m-name-pos))) + (mm (string-to-number + (if m-pos + (match-string-no-properties m-pos) + ""))) + (dd (string-to-number + (if d-pos + (match-string-no-properties d-pos) + ""))) + (y-str (if y-pos + (match-string-no-properties 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-number y-str) + (* 100 + (/ current-y 100))))) + (if (> (- y current-y) 50) + (- y 100) + (if (> (- current-y y) 50) + (+ y 100) + y))) + (string-to-number y-str))))) + (let ((tmp (diary-pull-attrs (buffer-substring-no-properties + (point) (line-end-position)) + file-glob-attrs))) + (setq entry (nth 0 tmp) + marks (nth 1 tmp))) + (if dd-name + (mark-calendar-days-named + ;; XEmacs change, we don't have assoc-string + (cdr (cal-assoc-string + dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array) t)) marks) + (if mm-name + (setq mm + (if (string-equal mm-name "*") 0 + ;; XEmacs change, we don't have assoc-string + (cdr (cal-assoc-string + mm-name + (calendar-make-alist + calendar-month-name-array + 1 nil calendar-month-abbrev-array) t))))) + (mark-calendar-date-pattern mm dd yy marks)))))) + (mark-sexp-diary-entries) + (run-hooks 'nongregorian-diary-marking-hook + 'mark-diary-entries-hook)) + (message "Marking diary entries...done"))))) (defun mark-sexp-diary-entries () "Mark days in the calendar window that have sexp diary entries. ＠＠ -792,16 +1058,12 ＠＠ is marked. See the documentation for the function `list-sexp-diary-entries'." (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\(" - (regexp-quote sexp-mark) "(\\)\\|\\(" + sexp-mark "(\\)\\|\\(" (regexp-quote diary-nonmarking-symbol) - (regexp-quote sexp-mark) "(diary-remind\\)")) - (m) - (y) - (first-date) - (last-date) - (mark)) - (save-excursion - (set-buffer calendar-buffer) + sexp-mark "(diary-remind\\)")) + (file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) + m y first-date last-date mark file-glob-attrs) + (with-current-buffer calendar-buffer (setq m displayed-month) (setq y displayed-year)) (increment-calendar-month m y -1) ＠＠ -813,15 +1075,10 ＠＠ (list m (calendar-last-day-of-month m y) y))) (goto-char (point-min)) (while (re-search-forward s-entry nil t) - (if (char-equal (preceding-char) ?\() - (setq marking-diary-entry t) - (setq marking-diary-entry nil)) + (setq marking-diary-entry (char-equal (preceding-char) ?\()) (re-search-backward "(") (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) + sexp entry entry-start line-start marks) (forward-sexp) (setq sexp (buffer-substring-no-properties sexp-start (point))) (save-excursion ＠＠ -838,21 +1095,26 ＠＠ ;; Find end of entry (re-search-forward "\^M\\|\n" nil t) (while (looking-at " \\|\^I") - (or (re-search-forward "\^M\\|\n" nil t) - (re-search-forward "$" nil t))) + (or (re-search-forward "\^M\\|\n" nil t) + (re-search-forward "$" nil t))) (if (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (backward-char 1)) + (char-equal (preceding-char) ?\n)) + (backward-char 1)) (setq entry (buffer-substring-no-properties entry-start (point))) (while (string-match "[\^M]" entry) (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))))))))) + (progn + (setq marks (diary-pull-attrs entry file-glob-attrs) + marks (nth 1 (diary-pull-attrs entry file-glob-attrs))) + (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. ＠＠ -866,19 +1128,20 ＠＠ (goto-char (point-min)) (while (re-search-forward (concat - "\\(\\`\\|\^M\\|\n\\)" + "\\(?:\\`\\|\^M\\|\n\\)" (regexp-quote diary-include-string) " \"\\([^\"]*\\)\"") nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring-no-properties - (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) + (let* ((diary-file (substitute-in-file-name + (match-string-no-properties 1))) + (mark-diary-entries-hook 'mark-included-diary-files) + (dbuff (find-buffer-visiting diary-file))) (if (file-exists-p diary-file) (if (file-readable-p diary-file) (progn (mark-diary-entries) - (kill-buffer (find-buffer-visiting diary-file))) + (unless dbuff + (kill-buffer (find-buffer-visiting diary-file)))) (beep) (message "Can't read included diary file %s" diary-file) (sleep-for 2)) ＠＠ -887,11 +1150,10 ＠＠ (sleep-for 2)))) (goto-char (point-min))) -(defun mark-calendar-days-named (dayname) +(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) + (with-current-buffer calendar-buffer (let ((prev-month displayed-month) (prev-year displayed-year) (succ-month displayed-month) ＠＠ -905,22 +1167,21 ＠＠ (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)) + (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color) (setq day (+ day 7)))))) -(defun mark-calendar-date-pattern (month day year) +(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) + (with-current-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) + (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) +(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) ＠＠ -930,8 +1191,8 ＠＠ (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))))) + (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." ＠＠ -941,47 +1202,48 ＠＠ "Returns t if E1 is earlier than E2." (or (calendar-date-compare e1 e2) (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) + (let* ((ts1 (cadr e1)) (t1 (diary-entry-time ts1)) + (ts2 (cadr e2)) (t2 (diary-entry-time ts2))) + (or (< t1 t2) + (and (= t1 t2) + (string-lessp ts1 ts2))))))) (defcustom diary-unknown-time -9999 - "*Value returned by diary-entry-time when no time is found. + "Value returned by diary-entry-time when no time is found. The default value -9999 causes entries with no recognizable time to be placed before those with times; 9999 would place entries with no recognizable time after those with times." :type 'integer :group 'diary -:version "20.3") +:version "20.3") (defun diary-entry-time (s) "Return time at the beginning of the string S as a military-style integer. For example, returns 1325 for 1:25pm. -Returns `diary-unknown-time' (default value -9999) if no time is recognized. The recognized forms are XXXX, X:XX, or -XX:XX (military time), and XXam, XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, -or XX:XXPM." + +Returns `diary-unknown-time' (default value -9999) if no time is recognized. +The recognized forms are XXXX, X:XX, or XX:XX (military time), and XXam, +XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, or XX:XXPM. A period (.) can +be used instead of a colon (:) to separate the hour and minute parts." (let ((case-fold-search nil)) - (cond ((string-match;; Military time - "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (equal ?a (downcase (aref s (match-beginning 2)))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (equal ?a (downcase (aref s (match-beginning 3)))) - 0 1200))) - (t diary-unknown-time))));; Unrecognizable + (cond ((string-match ; Military time + "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" + s) + (+ (* 100 (string-to-number (match-string 1 s))) + (string-to-number (match-string 2 s)))) + ((string-match ; Hour only XXam or XXpm + "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) + (+ (* 100 (% (string-to-number (match-string 1 s)) 12)) + (if (equal ?a (downcase (aref s (match-beginning 2)))) + 0 1200))) + ((string-match ; Hour and minute XX:XXam or XX:XXpm + "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) + (+ (* 100 (% (string-to-number (match-string 1 s)) 12)) + (string-to-number (match-string 2 s)) + (if (equal ?a (downcase (aref s (match-beginning 3)))) + 0 1200))) + (t diary-unknown-time)))) ; Unrecognizable ;; Unrecognizable ＠＠ -1017,11 +1279,10 ＠＠ `european-calendar-style' is nil, and DAY, MONTH, YEAR if `european-calendar-style' is t. DAY, MONTH, and YEAR can be lists of integers, the constant t, or an integer. - The constant t means all values. An optional parameter + The constant t means all values. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar. - %%(diary-float MONTH DAYNAME N &optional DAY MARK) text Entry will appear on the Nth DAYNAME of MONTH. (DAYNAME=0 means Sunday, 1 means Monday, and so on; ＠＠ -1029,18 +1290,19 ＠＠ the month. MONTH can be a list of months, a single month, or t to specify all months. Optional DAY means Nth DAYNAME of MONTH on or after/before DAY. DAY defaults - to 1 if N>0 and the last day of the month if N<0. An - optional parameter MARK specifies a face or single-character + to 1 if N>0 and the last day of the month if N<0. An + optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar. %%(diary-block M1 D1 Y1 M2 D2 Y2 &optional MARK) text Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, inclusive. (If `european-calendar-style' is t, the order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) An optional parameter MARK specifies a face - or single-character string to use when highlighting the + D2, M2, Y2.) An optional parameter MARK specifies a face + or single-character string to use when highlighting the day in the calendar. + ;; XEmacs only %%(diary-countdown BEFORE AFTER M1 D1 Y1) text Entry will appear on dates between BEFORE days before and AFTER days after specified date. (If ＠＠ -1056,8 +1318,8 ＠＠ of years since the MONTH DAY, YEAR and %s will be replaced by the ordinal ending of that number (that is, `st', `nd', `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. An - optional parameter MARK specifies a face or single-character + 29 is considered to be March 1 in a non-leap year. An + optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar. %%(diary-cyclic N MONTH DAY YEAR &optional MARK) text ＠＠ -1067,8 +1329,8 ＠＠ can contain %d or %d%s; %d will be replaced by the number of repetitions since the MONTH DAY, YEAR and %s will be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. An optional - parameter MARK specifies a face or single-character string + `st', `nd', `rd' or `th', as appropriate. An optional + parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar. %%(diary-remind SEXP DAYS &optional MARKING) text ＠＠ -1138,7 +1400,7 ＠＠ will appear on the proper Hebrew-date anniversary and on the day before. (If `european-calendar-style' is t, the order of the parameters should be changed to DAY, MONTH, YEAR.) - + %%(diary-rosh-hodesh) Diary entries will be made on the dates of Rosh Hodesh on the Hebrew calendar. Note that since there is no text, it ＠＠ -1156,26 +1418,27 ＠＠ Marking these entries is *extremely* time consuming, so these entries are 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)) + (let ((s-entry (concat "\\(\\`\\|\^M\\|\n\\)" + (regexp-quote diary-nonmarking-symbol) + "?" + (regexp-quote sexp-diary-entry-symbol) + "(")) + entry-found file-glob-attrs marks) (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) - (entry) - (specifier) - (entry-start) - (line-start)) + sexp entry specifier entry-start line-start) (forward-sexp) (setq sexp (buffer-substring-no-properties sexp-start (point))) (save-excursion (re-search-backward "\^M\\|\n\\|\\`") (setq line-start (point))) (setq specifier - (buffer-substring-no-properties (1+ line-start) (point))) + (buffer-substring-no-properties (1+ line-start) (point)) + entry-start (1+ line-start)) (forward-char 1) (if (and (or (char-equal (preceding-char) ?\^M) (char-equal (preceding-char) ?\n)) ＠＠ -1191,35 +1454,41 ＠＠ (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))) + (let ((diary-entry (diary-sexp-entry sexp entry date)) + temp literal) + (setq literal entry ; before evaluation + entry (if (consp diary-entry) + (cdr diary-entry) + diary-entry)) (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) + (progn + ;; XEmacs change. Mimic remove-overlays + (cal-remove-extents line-start (point) 'invisible 'diary) + (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 + literal) (setq entry-found (or entry-found diary-entry))))) entry-found)) (defun diary-sexp-entry (sexp entry date) "Process a SEXP diary ENTRY for DATE." (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) + (let ((stack-trace-on-error t)) + (eval (car (read-from-string sexp)))) (condition-case nil (eval (car (read-from-string sexp))) (error (beep) (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) + (count-lines (point-min) (point)) diary-file sexp) (sleep-for 2)))))) (cond ((stringp result) result) ＠＠ -1228,7 +1497,6 ＠＠ (result entry) (t nil)))) - (defun diary-date (month day year &optional mark) "Specific date(s) diary entry. Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil, ＠＠ -1236,17 +1504,17 ＠＠ can be lists of integers, the constant t, or an integer. The constant t means all values. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." - (let* ((dd (if european-calendar-style + (let ((dd (if european-calendar-style month day)) - (mm (if european-calendar-style + (mm (if european-calendar-style day month)) - (m (extract-calendar-month date)) - (y (extract-calendar-year date)) - (d (extract-calendar-day date))) + (m (extract-calendar-month date)) + (y (extract-calendar-year date)) + (d (extract-calendar-day date))) (if (and (or (and (listp dd) (memq d dd)) (equal d dd) ＠＠ -1257,16 +1525,16 ＠＠ (or (and (listp year) (memq y year)) (equal y year) (eq year t))) - entry))) + (cons mark entry)))) -(defun diary-block (m1 d1 y1 m2 d2 y2 &optional mark ) +(defun diary-block (m1 d1 y1 m2 d2 y2 &optional mark) "Block diary entry. Entry applies if date is between, or on one of, two dates. The order of the parameters is M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let ((date1 (calendar-absolute-from-gregorian ＠＠ -1279,8 +1547,10 ＠＠ (list m2 d2 y2)))) (d (calendar-absolute-from-gregorian date))) (if (and (<= date1 d) (<= d date2)) - (cons mark entry)))) + (cons mark entry)))) + +;; XEmacs, this function exist in XEmacs only (defun diary-countdown (before after m1 d1 y1) "Countdown diary entry. Entry applies if date is between BEFORE days before and AFTER days after ＠＠ -1295,11 +1565,11 ＠＠ (diff (- d date1))) (cond ((and (<= (- before) diff) (< diff 0)) - (concat (format "It is %d day%s before " + (concat (format "It is %d day%s before " (- diff) (if (= diff -1) "" "s")) entry)) ((= diff 0) (concat (format "TODAY: " diff) entry)) - ((and (<= diff after) (> diff 0)) - (concat (format "It is %d day%s after " + ((and (<= diff after) (> diff 0)) + (concat (format "It is %d day%s after " diff (if (= diff 1) "" "s")) entry)) (t nil)))) ＠＠ -1310,7 +1580,7 ＠＠ backward from the end of the month. An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY. -Optional MARK specifies a face or single-character string to use when +Optional MARK specifies a face or single-character string to use when highlighting the day in the calendar." ;; This is messy because the diary entry may apply, but the date on which it ;; is based can be in a different month/year. For example, asking for the ＠＠ -1334,41 +1604,41 ＠＠ (m2 (extract-calendar-month last)) (d2 (extract-calendar-day last)) (y2 (extract-calendar-year last))) - (if (or (and (= m1 m2) ; only possible base dates in one month - (or (eq month t) - (if (listp month) - (memq m1 month) - (= m1 month))) - (let ((d (or day (if (> n 0) - 1 - (calendar-last-day-of-month m1 y1))))) - (and (<= d1 d) (<= d d2)))) - ;; only possible base dates straddle two months - (and (or (< y1 y2) - (and (= y1 y2) (< m1 m2))) - (or - ;; m1, d1 works as a base date - (and - (or (eq month t) - (if (listp month) + (if (or (and (= m1 m2) ; only possible base dates in one month + (or (eq month t) + (if (listp month) + (memq m1 month) + (= m1 month))) + (let ((d (or day (if (> n 0) + 1 + (calendar-last-day-of-month m1 y1))))) + (and (<= d1 d) (<= d d2)))) + ;; only possible base dates straddle two months + (and (or (< y1 y2) + (and (= y1 y2) (< m1 m2))) + (or + ;; m1, d1 works as a base date + (and + (or (eq month t) + (if (listp month) (memq m1 month) - (= m1 month))) - (<= d1 (or day (if (> n 0) - 1 - (calendar-last-day-of-month m1 y1))))) - ;; m2, d2 works as a base date - (and (or (eq month t) - (if (listp month) - (memq m2 month) - (= m2 month))) - (<= (or day (if (> n 0) - 1 - (calendar-last-day-of-month m2 y2))) - d2))))) - (cons mark entry))))) + (= m1 month))) + (<= d1 (or day (if (> n 0) + 1 + (calendar-last-day-of-month m1 y1))))) + ;; m2, d2 works as a base date + (and (or (eq month t) + (if (listp month) + (memq m2 month) + (= m2 month))) + (<= (or day (if (> n 0) + 1 + (calendar-last-day-of-month m2 y2))) + d2))))) + (cons mark entry))))) -(defun diary-anniversary (month day year &optional mark) +(defun diary-anniversary (month day &optional year mark) "Anniversary diary entry. Entry applies if date is the anniversary of MONTH, DAY, YEAR if `european-calendar-style' is nil, and DAY, MONTH, YEAR if ＠＠ -1378,7 +1648,7 ＠＠ `rd' or `th', as appropriate. The anniversary of February 29 is considered to be March 1 in non-leap years. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((d (if european-calendar-style month ＠＠ -1387,12 +1657,12 ＠＠ day month)) (y (extract-calendar-year date)) - (diff (- y year))) + (diff (if year (- y year) 100))) (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) (setq m 3 d 1)) (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (cons mark (format entry diff (diary-ordinal-suffix diff)))))) + (cons mark (format entry diff (diary-ordinal-suffix diff)))))) (defun diary-cyclic (n month day year &optional mark) "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. ＠＠ -1400,9 +1670,9 ＠＠ ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of repetitions since the MONTH DAY, YEAR and %s will be replaced by the ordinal ending of that number (that is, `st', `nd', `rd' or `th', as -appropriate. +appropriate. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((d (if european-calendar-style month ＠＠ -1415,7 +1685,7 ＠＠ (list m d year)))) (cycle (/ diff n))) (if (and (>= diff 0) (zerop (% diff n))) - (cons mark (format entry cycle (diary-ordinal-suffix cycle)))))) + (cons mark (format entry cycle (diary-ordinal-suffix cycle)))))) (defun diary-ordinal-suffix (n) "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" ＠＠ -1435,15 +1705,15 ＠＠ (concat (int-to-string days) (if (= 1 days) " day" " days"))) " until " diary-entry) - "*Pseudo-pattern giving form of reminder messages in the fancy diary + "Pseudo-pattern giving form of reminder messages in the fancy diary display. - + Used by the function `diary-remind', a pseudo-pattern is a list of expressions that can involve the keywords `days' (a number), `date' (a list of month, day, year), and `diary-entry' (a string)." :type 'sexp :group 'diary) - + (defun diary-remind (sexp days &optional marking) "Provide a reminder of a diary entry. SEXP is a diary-sexp. DAYS is either a single number or a list of numbers ＠＠ -1453,15 +1723,15 ＠＠ returned. In addition to the reminders beforehand, the diary entry also appears on the - date itself. - +date itself. + A `diary-nonmarking-symbol' at the beginning of the line of the diary-remind entry specifies that the diary entry (not the reminder) is non-marking. Marking of reminders is independent of whether the entry itself is a marking or nonmarking; if optional parameter MARKING is non-nil then the reminders are marked on the calendar." (let ((diary-entry (eval sexp))) - (cond + (cond ;; Diary entry applies on date ((and diary-entry (or (not marking-diary-entries) marking-diary-entry)) ＠＠ -1470,28 +1740,34 ＠＠ ((and (integerp days) (not diary-entry); Diary entry does not apply to date (or (not marking-diary-entries) marking)) - (let ((date (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian date) days)))) - (if (setq diary-entry (eval sexp)) - (mapconcat 'eval diary-remind-message "")))) + (let ((date (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian date) days)))) + (when (setq diary-entry (eval sexp)) ; re-evaluate with adjusted date + ;; Discard any mark portion from diary-anniversary, etc. + (if (consp diary-entry) (setq diary-entry (cdr diary-entry))) + (mapconcat 'eval diary-remind-message "")))) ;; Diary entry may apply to one of a list of days before date - ((and (listp days) days) + ((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) - "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)))))) +(defun diary-redraw-calendar () + "If `calendar-buffer' is live and diary entries are marked, redraw it." + (and mark-diary-entries-in-calendar + (save-excursion + (redraw-calendar))) + ;; Return value suitable for `write-contents-hooks'. + nil) (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." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) +If omitted, NONMARKING defaults to nil and FILE defaults to +`diary-file'." + (let ((pop-up-frames (window-dedicated-p (selected-window)))) + (find-file-other-window (substitute-in-file-name (or file diary-file)))) + (when (eq major-mode default-major-mode) (diary-mode)) (widen) + (diary-unhide-everything) (goto-char (point-max)) (when (let ((case-fold-search t)) (search-backward "Local Variables:" ＠＠ -1499,7 +1775,7 ＠＠ t)) (beginning-of-line) (insert "\n") - (previous-line 1)) + (forward-line -1)) (insert (if (bolp) "" "\n") (if nonmarking diary-nonmarking-symbol "") ＠＠ -1523,10 +1799,10 ＠＠ "Insert a monthly diary entry for the day of the month indicated by point. Prefix arg will make the entry nonmarking." (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) + (let ((calendar-date-display-form + (if european-calendar-style + '(day " * ") + '("* " day)))) (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) arg))) ＠＠ -1534,10 +1810,10 ＠＠ "Insert an annual diary entry for the day of the year indicated by point. Prefix arg will make the entry nonmarking." (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) + (let ((calendar-date-display-form + (if european-calendar-style + '(day " " monthname) + '(monthname " " day)))) (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) arg))) ＠＠ -1545,10 +1821,10 ＠＠ "Insert an anniversary diary entry for the date given by point. Prefix arg will make the entry nonmarking." (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) + (let ((calendar-date-display-form + (if european-calendar-style + '(day " " month " " year) + '(month " " day " " year)))) (make-diary-entry (format "%s(diary-anniversary %s)" sexp-diary-entry-symbol ＠＠ -1559,15 +1835,14 ＠＠ "Insert a block diary entry for the days between the point and marked date. Prefix arg will make the entry nonmarking." (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) + (let ((calendar-date-display-form + (if european-calendar-style + '(day " " month " " year) + '(month " " day " " year))) (cursor (calendar-cursor-to-date t)) (mark (or (car calendar-mark-ring) (error "No mark set in this buffer"))) - (start) - (end)) + start end) (if (< (calendar-absolute-from-gregorian mark) (calendar-absolute-from-gregorian cursor)) (setq start mark ＠＠ -1585,10 +1860,10 ＠＠ "Insert a cyclic diary entry starting at the date given by point. Prefix arg will make the entry nonmarking." (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) + (let ((calendar-date-display-form + (if european-calendar-style + '(day " " month " " year) + '(month " " day " " year)))) (make-diary-entry (format "%s(diary-cyclic %d %s)" sexp-diary-entry-symbol ＠＠ -1597,6 +1872,375 ＠＠ (calendar-date-string (calendar-cursor-to-date t) nil t)) arg))) +(defvar diary-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-s" 'diary-show-all-entries) + ;; XEmacs change, we'll use bury-buffer. + (define-key map "\C-c\C-q" (if (fboundp 'quit-window) + 'quit-window + 'bury-buffer)) + map) + "Keymap for `diary-mode'.") + +;;;###autoload +(define-derived-mode diary-mode fundamental-mode "Diary" + "Major mode for editing the diary file." + (set (make-local-variable 'font-lock-defaults) + '(diary-font-lock-keywords t)) + (add-to-invisibility-spec '(diary . nil)) + (add-hook 'after-save-hook 'diary-redraw-calendar nil t) + (if diary-header-line-flag + (setq header-line-format diary-header-line-format))) + + +(defvar diary-fancy-date-pattern + (concat + (let ((dayname (diary-name-pattern calendar-day-name-array nil t)) + (monthname (diary-name-pattern calendar-month-name-array nil t)) + (day "[0-9]+") + (month "[0-9]+") + (year "-?[0-9]+")) + (mapconcat 'eval calendar-date-display-form "")) + ;; Optional ": holiday name" after the date. + "\\(: .*\\)?") + "Regular expression matching a date header in Fancy Diary.") + +(defconst diary-time-regexp + ;; Accepted formats: 10:00 10.00 10h00 10h 10am 10:00am 10.00am + ;; Use of "." as a separator annoyingly matches numbers, eg "123.45". + ;; Hence often prefix this with "\\(^\\|\\s-\\)." + (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\(" + "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]" + "\\)\\([AaPp][Mm]\\)?\\)") + "Regular expression matching a time of day.") + + +;; XEmacs change, our defface can't inherit, so just define the face. +(defface diary-anniversary + '((((class color) (background light)) + (:foreground "red4")) + (((class color) (background dark)) + (:foreground "cyan")) + (t + (:weight bold t))) + "Face used for anniversaries in the diary." +:group 'diary) + +;; XEmacs change, our defface can't inherit, so just define the face. +(defface diary-time + '((((class color) (background light)) + (:foreground "magenta4")) + (((class color) (background dark)) + (:foreground "cyan3")) + (t + (:weight bold t))) + "Face used for times of day in the diary." +:group 'diary) + +(defvar fancy-diary-font-lock-keywords + (list + (list + ;; Any number of " other holiday name" lines, followed by "==" line. + (concat diary-fancy-date-pattern "\\(\n +.*\\)*\n=+$") + '(0 (progn (put-text-property (match-beginning 0) (match-end 0) + 'font-lock-multiline t) + 'diary))) + '("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . diary-anniversary) + '("^.*Yahrzeit.*$" . font-lock-reference-face) + '("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face) + '("^Day.*omer.*$" . font-lock-builtin-face) + '("^Parashat.*$" . font-lock-comment-face) + `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp + diary-time-regexp) . diary-time)) + "Keywords to highlight in fancy diary display") + +;; If region looks like it might start or end in the middle of a +;; multiline pattern, extend the region to encompass the whole pattern. +(defun diary-fancy-font-lock-fontify-region-function (beg end &optional verbose) + "Function to use for `font-lock-fontify-region-function' in Fancy Diary. +Needed to handle multiline keyword in `fancy-diary-font-lock-keywords'." + (goto-char beg) + (forward-line 0) + (if (looking-at "=+$") (forward-line -1)) + (while (and (looking-at " +[^ ]") + (zerop (forward-line -1)))) + ;; This check not essential. + (if (looking-at diary-fancy-date-pattern) + (setq beg (line-beginning-position))) + (goto-char end) + (forward-line 0) + (while (and (looking-at " +[^ ]") + (zerop (forward-line 1)))) + (if (looking-at "=+$") + (setq end (line-beginning-position 2))) + (font-lock-default-fontify-region beg end verbose)) + +(define-derived-mode fancy-diary-display-mode fundamental-mode + "Diary" + "Major mode used while displaying diary entries using Fancy Display." + (set (make-local-variable 'font-lock-defaults) + '(fancy-diary-font-lock-keywords + t nil nil nil + (font-lock-fontify-region-function + . diary-fancy-font-lock-fontify-region-function))) + ;; XEmacs change, we don't have quit-window, bury-buffer will suffice + (local-set-key "q" (if (fboundp 'quit-window) + 'quit-window + 'bury-buffer))) + + +(defun diary-font-lock-sexps (limit) + "Recognize sexp diary entry for font-locking." + (if (re-search-forward + (concat "^" (regexp-quote diary-nonmarking-symbol) + "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)") + limit t) + (condition-case nil + (save-restriction + (narrow-to-region (point-min) limit) + (let ((start (point))) + (forward-sexp 1) + (store-match-data (list start (point))) + t)) + (error t)))) + +(defun diary-font-lock-date-forms (month-array &optional symbol abbrev-array) + "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY. +If given, optional SYMBOL must be a prefix to entries. +If optional ABBREV-ARRAY is present, the abbreviations constructed +from this array by the function `calendar-abbrev-construct' are +matched (with or without a final `.'), in addition to the full month +names." + (let ((dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array t)) + (monthname (format "\\(%s\\|\\*\\)" + (diary-name-pattern month-array abbrev-array))) + (month "\\([0-9]+\\|\\*\\)") + (day "\\([0-9]+\\|\\*\\)") + (year "-?\\([0-9]+\\|\\*\\)")) + (mapcar (lambda (x) + (cons + (concat "^" (regexp-quote diary-nonmarking-symbol) "?" + (if symbol (regexp-quote symbol) "") "\\(" + (mapconcat 'eval + ;; If backup, omit first item (backup) + ;; and last item (not part of date) + (if (equal (car x) 'backup) + (nreverse (cdr (reverse (cdr x)))) + x) + "") + ;; With backup, last item is not part of date + (if (equal (car x) 'backup) + (concat "\\)" (eval (car (reverse x)))) + "\\)")) + ;; XEmacs - we don't understand face-aliases. + '(1 diary))) + diary-date-forms))) + +(eval-when-compile (require 'cal-hebrew) + (require 'cal-islam)) + +(defvar diary-font-lock-keywords + (append + (diary-font-lock-date-forms calendar-month-name-array + nil calendar-month-abbrev-array) + (when (or (memq 'mark-hebrew-diary-entries + nongregorian-diary-marking-hook) + (memq 'list-hebrew-diary-entries + nongregorian-diary-listing-hook)) + (require 'cal-hebrew) + (diary-font-lock-date-forms + calendar-hebrew-month-name-array-leap-year + hebrew-diary-entry-symbol)) + (when (or (memq 'mark-islamic-diary-entries + nongregorian-diary-marking-hook) + (memq 'list-islamic-diary-entries + nongregorian-diary-listing-hook)) + (require 'cal-islam) + (diary-font-lock-date-forms + calendar-islamic-month-name-array + islamic-diary-entry-symbol)) + (list + (cons + (concat "^" (regexp-quote diary-include-string) ".*$") + 'font-lock-keyword-face) + (cons + (concat "^" (regexp-quote diary-nonmarking-symbol) + "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)") + '(1 font-lock-reference-face)) + (cons + (concat "^" (regexp-quote diary-nonmarking-symbol)) + 'font-lock-reference-face) + (cons + (concat "^" (regexp-quote diary-nonmarking-symbol) + "?\\(" (regexp-quote hebrew-diary-entry-symbol) "\\)") + '(1 font-lock-reference-face)) + (cons + (concat "^" (regexp-quote diary-nonmarking-symbol) + "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)") + '(1 font-lock-reference-face)) + '(diary-font-lock-sexps . font-lock-keyword-face) + `(,(concat "\\(^\\|\\s-\\)" + diary-time-regexp "\\(-" diary-time-regexp "\\)?") + . diary-time))) + "Forms to highlight in `diary-mode'.") + + +;; Following code from Dave Love <fx(a)gnu.org&gt;. +;; Import Outlook-format appointments from mail messages in Gnus or +;; Rmail using command `diary-from-outlook'. This, or the specialized +;; functions `diary-from-outlook-gnus' and `diary-from-outlook-rmail', +;; could be run from hooks to notice appointments automatically (in +;; which case they will prompt about adding to the diary). The +;; message formats recognized are customizable through +;; `diary-outlook-formats'. + +(defcustom diary-outlook-formats + '( + ;; When: 11 October 2001 12:00-14:00 (GMT) Greenwich Mean Time : Dublin, ... + ;; [Current UK format? The timezone is meaningless. Sometimes the + ;; Where is missing.] + ("When: \\([0-9]+ [[:alpha:]]+ [0-9]+\\) \ +\\([^ ]+\\) [^\n]+ +\[^\n]+ +\\(?:Where: \\([^\n]+\\)\n+\\)? +\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*" + . "\\1\n \\2 %s, \\3") + ;; When: Tuesday, April 30, 2002 03:00 PM-03:30 PM (GMT) Greenwich Mean ... + ;; [Old UK format?] + ("^When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \\([0-9]\\{4\\}\\) \ +\\([^ ]+\\) [^\n]+ +\[^\n]+ +\\(?:Where: \\([^\n]+\\)\\)?\n+" + . "\\2 \\1 \\3\n \\4 %s, \\5") + ( + ;; German format, apparently. + "^Zeit: [^ ]+, +\\([0-9]+\\)\. +\\([[:upper:]][[:lower:]][[:lower:]]\\)[^ ]* +\\([0-9]+\\) +\\([^ ]+\\).*$" + . "\\1 \\2 \\3\n \\4 %s")) + "Alist of regexps matching message text and replacement text. + +The regexp must match the start of the message text containing an +appointment, but need not include a leading `^'. If it matches the +current message, a diary entry is made from the corresponding +template. If the template is a string, it should be suitable for +passing to `replace-match', and so will have occurrences of `\\D' to +substitute the match for the Dth subexpression. It must also contain +a single `%s' which will be replaced with the text of the message's +Subject field. Any other `%' characters must be doubled, so that the +template can be passed to `format'. + +If the template is actually a function, it is called with the message +body text as argument, and may use `match-string' etc. to make a +template following the rules above." +:type '(alist :key-type (regexp :tag "Regexp matching time/place") + :value-type (choice + (string :tag "Template for entry") + (function :tag "Unary function providing template"))) +:version "22.1" +:group 'diary) + + +;; Dynamically bound. +(defvar body) +(defvar subject) + +(defun diary-from-outlook-internal (&optional test-only) + "Snarf a diary entry from a message assumed to be from MS Outlook. +Assumes `body' is bound to a string comprising the body of the message and +`subject' is bound to a string comprising its subject. +Arg TEST-ONLY non-nil means return non-nil if and only if the +message contains an appointment, don't make a diary entry." + (catch 'finished + (let (format-string) + (dotimes (i (length diary-outlook-formats)) + (when (eq 0 (string-match (car (nth i diary-outlook-formats)) + body)) + (unless test-only + (setq format-string (cdr (nth i diary-outlook-formats))) + (save-excursion + (save-window-excursion + ;; Fixme: References to optional fields in the format + ;; are treated literally, not replaced by the empty + ;; string. I think this is an Emacs bug. + (make-diary-entry + (format (replace-match (if (functionp format-string) + (funcall format-string body) + format-string) + t nil (match-string 0 body)) + subject)) + (save-buffer)))) + (throw 'finished t)))) + nil)) + +(defun diary-from-outlook (&optional noconfirm) + "Maybe snarf diary entry from current Outlook-generated message. +Currently knows about Gnus and Rmail modes. Unless the optional +argument NOCONFIRM is non-nil (which is the case when this +function is called interactively), then if an entry is found the +user is asked to confirm its addition." + (interactive "p") + (let ((func (cond + ((eq major-mode 'rmail-mode) + #'diary-from-outlook-rmail) + ((memq major-mode '(gnus-summary-mode gnus-article-mode)) + #'diary-from-outlook-gnus) + (t (error "Don't know how to snarf in `%s'" major-mode))))) + (funcall func noconfirm))) + + +(defvar gnus-article-mime-handles) +(defvar gnus-article-buffer) + +(autoload 'gnus-fetch-field "gnus-util") +(autoload 'gnus-narrow-to-body "gnus") +(autoload 'mm-get-part "mm-decode") + +(defun diary-from-outlook-gnus (&optional noconfirm) + "Maybe snarf diary entry from Outlook-generated message in Gnus. +Unless the optional argument NOCONFIRM is non-nil (which is the case when +this function is called interactively), then if an entry is found the +user is asked to confirm its addition. +Add this function to `gnus-article-prepare-hook' to notice appointments +automatically." + (interactive "p") + (with-current-buffer gnus-article-buffer + (let ((subject (gnus-fetch-field "subject")) + (body (if gnus-article-mime-handles + ;; We're multipart. Don't get confused by part + ;; buttons &c. Assume info is in first part. + (mm-get-part (nth 1 gnus-article-mime-handles)) + (save-restriction + (gnus-narrow-to-body) + (buffer-string))))) + (when (diary-from-outlook-internal t) + (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) + (diary-from-outlook-internal) + (message "Diary entry added")))))) + +(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus) + + +(defvar rmail-buffer) + +(defun diary-from-outlook-rmail (&optional noconfirm) + "Maybe snarf diary entry from Outlook-generated message in Rmail. +Unless the optional argument NOCONFIRM is non-nil (which is the case when +this function is called interactively), then if an entry is found the +user is asked to confirm its addition." + (interactive "p") + (with-current-buffer rmail-buffer + (let ((subject (mail-fetch-field "subject")) + (body (buffer-substring (save-excursion + (rfc822-goto-eoh) + (point)) + (point-max)))) + (when (diary-from-outlook-internal t) + (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) + (diary-from-outlook-internal) + (message "Diary entry added")))))) + + (provide 'diary-lib) +;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010 ;;; diary-lib.el ends here Index: holidays.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/holidays.el,v retrieving revision 1.6 diff -u -u -r1.6 holidays.el --- holidays.el 2006/07/31 02:15:24 1.6 +++ holidays.el 2006/10/20 21:46:46 ＠＠ -1,8 +1,10 ＠＠ ;;; holidays.el --- holiday functions for the calendar package -;; Copyright (C) 1989, 90, 92, 93, 94, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1997, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: holidays, calendar ;; This file is part of XEmacs. ＠＠ -19,10 +21,10 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -30,8 +32,8 ＠＠ ;; in calendar.el. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; An earlier version of the technical details appeared in ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, ＠＠ -53,6 +55,9 ＠＠ ;;; Code: +(defvar displayed-month) +(defvar displayed-year) + (require 'calendar) (autoload 'holiday-julian "cal-julian" ＠＠ -83,6 +88,10 ＠＠ "Holiday on MONTH, DAY (Islamic) called STRING." t) +(autoload 'holiday-bahai "cal-bahai" + "Holiday on MONTH, DAY (Baha'i) called STRING." + t) + (autoload 'holiday-chinese-new-year "cal-china" "Date of Chinese New Year." t) ＠＠ -112,8 +121,21 ＠＠ (defun list-holidays (y1 y2 &optional l label) "Display holidays for years Y1 to Y2 (inclusive). -The optional list of holidays L defaults to `calendar-holidays'. See the -documentation for that variable for a description of holiday lists. +The optional list of holidays L defaults to `calendar-holidays'. +If you want to control what holidays are displayed, use a +different list. For example, + + (list-holidays 2006 2006 + (append general-holidays local-holidays other-holidays)) + +will display holidays for the year 2006 defined in the 3 +mentioned lists, and nothing else. + +When called interactively, this command offers a choice of +holidays, based on the variables `solar-holidays' etc. See the +documentation of `calendar-holidays' for a list of the variables +that control the choices, as well as a description of the format +of a holiday list. The optional LABEL is used to label the buffer created." (interactive ＠＠ -128,7 +150,7 ＠＠ '(lambda (x) (>= x start-year)) (int-to-string start-year))) (completion-ignore-case t) - (lists + (lists (list (cons "All" calendar-holidays) (if (fboundp 'atan) ＠＠ -140,6 +162,7 ＠＠ (if christian-holidays (cons "Christian" christian-holidays)) (if hebrew-holidays (cons "Hebrew" hebrew-holidays)) (if islamic-holidays (cons "Islamic" islamic-holidays)) + (if bahai-holidays (cons "Baha'i" bahai-holidays)) (if oriental-holidays (cons "Oriental" oriental-holidays)) (if solar-holidays (cons "Solar" solar-holidays)) (cons "Ask" nil))) ＠＠ -151,7 +174,7 ＠＠ (name (if (string-equal choice "Equinoxes/Solstices") choice (if (member choice '("Ask" "")) - "Holidays" + "Holidays" (format "%s Holidays" choice))))) (list start-year end-year which name))) (message "Computing holidays...") ＠＠ -191,6 +214,7 ＠＠ (display-buffer holiday-buffer) (message "Computing holidays...done")))) +;; XEmacs change ;;;###autoload (defun check-calendar-holidays (date) "Check the list of holidays for any that occur on DATE. ＠＠ -392,86 +416,88 ＠＠ (string (if date (eval string)))) (list (list date string))))))) -(defun holiday-advent () - "Date of Advent, if visible in calendar window." - (let ((year displayed-year) - (month displayed-month)) - (increment-calendar-month month year -1) - (let ((advent (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 - (calendar-absolute-from-gregorian - (list 12 3 year)))))) - (if (calendar-date-is-visible-p advent) - (list (list advent "Advent")))))) - -(defun holiday-easter-etc () - "List of dates related to Easter, as visible in calendar window." - (if (and (> displayed-month 5) (not all-christian-calendar-holidays)) - nil;; Ash Wednesday, Good Friday, and Easter are not visible. - (let* ((century (1+ (/ displayed-year 100))) - (shifted-epact ;; Age of moon for April 5... - (% (+ 14 (* 11 (% displayed-year 19));; ...by Nicaean rule - (- ;; ...corrected for the Gregorian century rule - (/ (* 3 century) 4)) - (/ ;; ...corrected for Metonic cycle inaccuracy. - (+ 5 (* 8 century)) 25) - (* 30 century));; Keeps value positive. - 30)) - (adjusted-epact ;; Adjust for 29.5 day month. - (if (or (= shifted-epact 0) - (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) - (1+ shifted-epact) - shifted-epact)) - (paschal-moon ;; Day after the full moon on or after March 21. - (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) - adjusted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-easter) - "Easter Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 2)) - "Good Friday") - (list (calendar-gregorian-from-absolute (- abs-easter 46)) - "Ash Wednesday"))) - (optional - (list - (list (calendar-gregorian-from-absolute (- abs-easter 63)) - "Septuagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 56)) - "Sexagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 49)) - "Shrove Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 48)) - "Shrove Monday") - (list (calendar-gregorian-from-absolute (- abs-easter 47)) - "Shrove Tuesday") - (list (calendar-gregorian-from-absolute (- abs-easter 14)) - "Passion Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 7)) - "Palm Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 3)) - "Maundy Thursday") - (list (calendar-gregorian-from-absolute (+ abs-easter 35)) - "Rogation Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 39)) - "Ascension Day") - (list (calendar-gregorian-from-absolute (+ abs-easter 49)) - "Pentecost (Whitsunday)") - (list (calendar-gregorian-from-absolute (+ abs-easter 50)) - "Whitmonday") - (list (calendar-gregorian-from-absolute (+ abs-easter 56)) - "Trinity Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 60)) - "Corpus Christi"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-christian-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) +(defun holiday-advent (&optional n string) + "Date of Nth day after advent (named STRING), if visible in calendar window. +Negative values of N are interpreted as days before advent. +STRING is used purely for display purposes. The return value has +the form ((MONTH DAY YEAR) STRING), where the date is that of the +Nth day before or after advent. + +For backwards compatibility, if this function is called with no +arguments, then it returns the value appropriate for advent itself." + ;; Backwards compatibility layer. + (if (not n) + (holiday-advent 0 "Advent") + (let ((year displayed-year) + (month displayed-month)) + (increment-calendar-month month year -1) + (let ((advent (calendar-gregorian-from-absolute + (+ n + (calendar-dayname-on-or-before + 0 + (calendar-absolute-from-gregorian + (list 12 3 year))))))) + (if (calendar-date-is-visible-p advent) + (list (list advent string))))))) + +(defun holiday-easter-etc (&optional n string) + "Date of Nth day after Easter (named STRING), if visible in calendar window. +Negative values of N are interpreted as days before Easter. +STRING is used purely for display purposes. The return value has +the form ((MONTH DAY YEAR) STRING), where the date is that of the +Nth day before or after Easter. + +For backwards compatibility, if this function is called with no +arguments, then it returns a list of \"standard\" Easter-related +holidays (with more entries if `all-christian-calendar-holidays' +is non-nil)." + ;; Backwards compatibility layer. + (if (not n) + (let (res-list res) + (dolist (elem (append + (if all-christian-calendar-holidays + '((-63 . "Septuagesima Sunday") + (-56 . "Sexagesima Sunday") + (-49 . "Shrove Sunday") + (-48 . "Shrove Monday") + (-47 . "Shrove Tuesday") + (-14 . "Passion Sunday") + (-7 . "Palm Sunday") + (-3 . "Maundy Thursday") + (35 . "Rogation Sunday") + (39 . "Ascension Day") + (49 . "Pentecost (Whitsunday)") + (50 . "Whitmonday") + (56 . "Trinity Sunday") + (60 . "Corpus Christi"))) + '((0 . "Easter Sunday") + (-2 . "Good Friday") + (-46 . "Ash Wednesday"))) + res-list) + ;; Filter out nil (not visible) values. + (if (setq res (holiday-easter-etc (car elem) (cdr elem))) + (setq res-list (append res res-list))))) + (let* ((century (1+ (/ displayed-year 100))) + (shifted-epact ;; Age of moon for April 5... + (% (+ 14 (* 11 (% displayed-year 19)) ;; ...by Nicaean rule + (- ;; ...corrected for the Gregorian century rule + (/ (* 3 century) 4)) + (/ ;; ...corrected for Metonic cycle inaccuracy. + (+ 5 (* 8 century)) 25) + (* 30 century)) ;; Keeps value positive. + 30)) + (adjusted-epact ;; Adjust for 29.5 day month. + (if (or (zerop shifted-epact) + (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) + (1+ shifted-epact) + shifted-epact)) + (paschal-moon ;; Day after the full moon on or after March 21. + (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) + adjusted-epact)) + (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))) + (filter-visible-calendar-holidays + (list (list (calendar-gregorian-from-absolute (+ abs-easter n)) + string)))))) (defun holiday-greek-orthodox-easter () "Date of Easter according to the rule of the Council of Nicaea." ＠＠ -509,4 +535,5 ＠＠ (provide 'holidays) +;;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37 ;;; holidays.el ends here Index: icalendar.el =================================================================== RCS file: icalendar.el diff -N icalendar.el --- /dev/null Fri Oct 20 23:46:47 2006 +++ icalendar.el Fri Oct 20 23:46:46 2006 ＠＠ -0,0 +1,1942 ＠＠ +;;; icalendar.el --- iCalendar implementation -*-coding: utf-8 -*- + +;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. + +;; Author: Ulf Jasper <ulf.jasper(a)web.de&gt; +;; Created: August 2002 +;; Keywords: calendar +;; Human-Keywords: calendar, diary, iCalendar, vCalendar + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 + +;;; Commentary: + +;; This package is documented in the Emacs Manual. + +;; Please note: +;; - Diary entries which have a start time but no end time are assumed to +;; last for one hour when they are exported. +;; - Weekly diary entries are assumed to occur the first time in the first +;; week of the year 2000 when they are exported. +;; - Yearly diary entries are assumed to occur the first time in the year +;; 1900 when they are exported. + +;;; History: + +;; 0.07 onwards: see lisp/ChangeLog + +;; 0.06: Bugfixes regarding icalendar-import-format-*. +;; Fix in icalendar-convert-diary-to-ical -- thanks to Philipp +;; Grau. + +;; 0.05: New import format scheme: Replaced icalendar-import-prefix-*, +;; icalendar-import-ignored-properties, and +;; icalendar-import-separator with icalendar-import-format(-*). +;; icalendar-import-file and icalendar-convert-diary-to-ical +;; have an extra parameter which should prevent them from +;; erasing their target files (untested!). +;; Tested with Emacs 21.3.2 + +;; 0.04: Bugfix: import: double quoted param values did not work +;; Read DURATION property when importing. +;; Added parameter icalendar-duration-correction. + +;; 0.03: Export takes care of european-calendar-style. +;; Tested with Emacs 21.3.2 and XEmacs 21.4.12 + +;; 0.02: Should work in XEmacs now. Thanks to Len Trigg for the +;; XEmacs patches! +;; Added exporting from Emacs diary to ical. +;; Some bugfixes, after testing with calendars from +;; http://icalshare.com. +;; Tested with Emacs 21.3.2 and XEmacs 21.4.12 + +;; 0.01: First published version. Trial version. Alpha version. + +;; ====================================================================== +;; To Do: + +;; * Import from ical to diary: +;; + Need more properties for icalendar-import-format +;; + check vcalendar version +;; + check (unknown) elements +;; + recurring events! +;; + works for european style calendars only! Does it? +;; + alarm +;; + exceptions in recurring events +;; + the parser is too soft +;; + error log is incomplete +;; + nice to have: #include "webcal://foo.com/some-calendar.ics" +;; + timezones, currently all times are local! + +;; * Export from diary to ical +;; + diary-date, diary-float, and self-made sexp entries are not +;; understood + +;; * Other things +;; + clean up all those date/time parsing functions +;; + Handle todo items? +;; + Check iso 8601 for datetime and period +;; + Which chars to (un)escape? + + +;;; Code: + +(defconst icalendar-version "0.13" + "Version number of icalendar.el.") + +;; ====================================================================== +;; Customizables +;; ====================================================================== +(defgroup icalendar nil + "Icalendar support." +:prefix "icalendar-" +:group 'calendar) + +(defcustom icalendar-import-format + "%s%d%l%o" + "Format string for importing events from iCalendar into Emacs diary. +This string defines how iCalendar events are inserted into diary +file. Meaning of the specifiers: +%c Class, see `icalendar-import-format-class' +%d Description, see `icalendar-import-format-description' +%l Location, see `icalendar-import-format-location' +%o Organizer, see `icalendar-import-format-organizer' +%s Summary, see `icalendar-import-format-summary' +%t Status, see `icalendar-import-format-status' +%u URL, see `icalendar-import-format-url'" +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-summary + "%s" + "Format string defining how the summary element is formatted. +This applies only if the summary is not empty! `%s' is replaced +by the summary." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-description + "\n Desc: %s" + "Format string defining how the description element is formatted. +This applies only if the description is not empty! `%s' is +replaced by the description." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-location + "\n Location: %s" + "Format string defining how the location element is formatted. +This applies only if the location is not empty! `%s' is replaced +by the location." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-organizer + "\n Organizer: %s" + "Format string defining how the organizer element is formatted. +This applies only if the organizer is not empty! `%s' is +replaced by the organizer." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-url + "\n URL: %s" + "Format string defining how the URL element is formatted. +This applies only if the URL is not empty! `%s' is replaced by +the URL." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-status + "\n Status: %s" + "Format string defining how the status element is formatted. +This applies only if the status is not empty! `%s' is replaced by +the status." +:type 'string +:group 'icalendar) + +(defcustom icalendar-import-format-class + "\n Class: %s" + "Format string defining how the class element is formatted. +This applies only if the class is not empty! `%s' is replaced by +the class." +:type 'string +:group 'icalendar) + +(defvar icalendar-debug nil + "Enable icalendar debug messages.") + +;; ====================================================================== +;; NO USER SERVICABLE PARTS BELOW THIS LINE +;; ====================================================================== + +(defconst icalendar--weekday-array ["SU" "MO" "TU" "WE" "TH" "FR" "SA"]) + +;; ====================================================================== +;; all the other libs we need +;; ====================================================================== +(require 'calendar) + +;; ====================================================================== +;; misc +;; ====================================================================== +(defun icalendar--dmsg (&rest args) + "Print message ARGS if `icalendar-debug' is non-nil." + (if icalendar-debug + (apply 'message args))) + +;; ====================================================================== +;; Core functionality +;; Functions for parsing icalendars, importing and so on +;; ====================================================================== + +(defun icalendar--get-unfolded-buffer (folded-ical-buffer) + "Return a new buffer containing the unfolded contents of a buffer. +Folding is the iCalendar way of wrapping long lines. In the +created buffer all occurrences of CR LF BLANK are replaced by the +empty string. Argument FOLDED-ICAL-BUFFER is the unfolded input +buffer." + (let ((unfolded-buffer (get-buffer-create " *icalendar-work*"))) + (save-current-buffer + (set-buffer unfolded-buffer) + (erase-buffer) + (insert-buffer-substring folded-ical-buffer) + (goto-char (point-min)) + (while (re-search-forward "\r?\n[ \t]" nil t) + (replace-match "" nil nil))) + unfolded-buffer)) + +(defsubst icalendar--rris (&rest args) + "Replace regular expression in string. +Pass ARGS to `replace-regexp-in-string' (Emacs) or to +`replace-in-string' (XEmacs)." + ;; XEmacs: + (if (fboundp 'replace-in-string) + (save-match-data ;; apparently XEmacs needs save-match-data + (apply 'replace-in-string args)) + ;; Emacs: + (apply 'replace-regexp-in-string args))) + +(defun icalendar--read-element (invalue inparams) + "Recursively read the next iCalendar element in the current buffer. +INVALUE gives the current iCalendar element we are reading. +INPARAMS gives the current parameters..... +This function calls itself recursively for each nested calendar element +it finds" + (let (element children line name params param param-name param-value + value + (continue t)) + (setq children '()) + (while (and continue + (re-search-forward "^\\([A-Za-z0-9-]+\\)[;:]" nil t)) + (setq name (intern (match-string 1))) + (backward-char 1) + (setq params '()) + (setq line '()) + (while (looking-at ";") + (re-search-forward ";\\([A-Za-z0-9-]+\\)=" nil nil) + (setq param-name (intern (match-string 1))) + (re-search-forward "\\(\\([^;,:\"]+\\)\\|\"\\([^\"]+\\)\"\\)[;:]" + nil t) + (backward-char 1) + (setq param-value (or (match-string 2) (match-string 3))) + (setq param (list param-name param-value)) + (while (looking-at ",") + (re-search-forward "\\(\\([^;,:]+\\)\\|\"\\([^\"]+\\)\"\\)" + nil t) + (if (match-string 2) + (setq param-value (match-string 2)) + (setq param-value (match-string 3))) + (setq param (append param param-value))) + (setq params (append params param))) + (unless (looking-at ":") + (error "Oops")) + (forward-char 1) + (re-search-forward "\\(.*\\)\\(\r?\n[ \t].*\\)*" nil t) + (setq value (icalendar--rris "\r?\n[ \t]" "" (match-string 0))) + (setq line (list name params value)) + (cond ((eq name 'BEGIN) + (setq children + (append children + (list (icalendar--read-element (intern value) + params))))) + ((eq name 'END) + (setq continue nil)) + (t + (setq element (append element (list line)))))) + (if invalue + (list invalue inparams element children) + children))) + +;; ====================================================================== +;; helper functions for examining events +;; ====================================================================== + +;;(defsubst icalendar--get-all-event-properties (event) +;; "Return the list of properties in this EVENT." +;; (car (cddr event))) + +(defun icalendar--get-event-property (event prop) + "For the given EVENT return the value of the first occurrence of PROP." + (catch 'found + (let ((props (car (cddr event))) pp) + (while props + (setq pp (car props)) + (if (eq (car pp) prop) + (throw 'found (car (cddr pp)))) + (setq props (cdr props)))) + nil)) + +(defun icalendar--get-event-property-attributes (event prop) + "For the given EVENT return attributes of the first occurrence of PROP." + (catch 'found + (let ((props (car (cddr event))) pp) + (while props + (setq pp (car props)) + (if (eq (car pp) prop) + (throw 'found (cadr pp))) + (setq props (cdr props)))) + nil)) + +(defun icalendar--get-event-properties (event prop) + "For the given EVENT return a list of all values of the property PROP." + (let ((props (car (cddr event))) pp result) + (while props + (setq pp (car props)) + (if (eq (car pp) prop) + (setq result (append (split-string (car (cddr pp)) ",") result))) + (setq props (cdr props))) + result)) + +;; (defun icalendar--set-event-property (event prop new-value) +;; "For the given EVENT set the property PROP to the value NEW-VALUE." +;; (catch 'found +;; (let ((props (car (cddr event))) pp) +;; (while props +;; (setq pp (car props)) +;; (when (eq (car pp) prop) +;; (setcdr (cdr pp) new-value) +;; (throw 'found (car (cddr pp)))) +;; (setq props (cdr props))) +;; (setq props (car (cddr event))) +;; (setcar (cddr event) +;; (append props (list (list prop nil new-value))))))) + +(defun icalendar--get-children (node name) + "Return all children of the given NODE which have a name NAME. +For instance the VCALENDAR node can have VEVENT children as well as VTODO +children." + (let ((result nil) + (children (cadr (cddr node)))) + (when (eq (car node) name) + (setq result node)) + ;;(message "%s" node) + (when children + (let ((subresult + (delq nil + (mapcar (lambda (n) + (icalendar--get-children n name)) + children)))) + (if subresult + (if result + (setq result (append result subresult)) + (setq result subresult))))) + result)) + + ; private +(defun icalendar--all-events (icalendar) + "Return the list of all existing events in the given ICALENDAR." + (icalendar--get-children (car icalendar) 'VEVENT)) + +(defun icalendar--split-value (value-string) + "Split VALUE-STRING at ';='." + (let ((result '()) + param-name param-value) + (when value-string + (save-current-buffer + (set-buffer (get-buffer-create " *icalendar-work*")) + (set-buffer-modified-p nil) + (erase-buffer) + (insert value-string) + (goto-char (point-min)) + (while + (re-search-forward + "\\([A-Za-z0-9-]+\\)=\\(\\([^;,:]+\\)\\|\"\\([^\"]+\\)\"\\);?" + nil t) + (setq param-name (intern (match-string 1))) + (setq param-value (match-string 2)) + (setq result + (append result (list (list param-name param-value))))))) + result)) + +(defun icalendar--decode-isodatetime (isodatetimestring &optional day-shift) + "Return ISODATETIMESTRING in format like `decode-time'. +Converts from ISO-8601 to Emacs representation. If +ISODATETIMESTRING specifies UTC time (trailing letter Z) the +decoded time is given in the local time zone! If optional +parameter DAY-SHIFT is non-nil the result is shifted by DAY-SHIFT +days. + +FIXME: TZID-attributes are ignored....! +FIXME: multiple comma-separated values should be allowed!" + (icalendar--dmsg isodatetimestring) + (if isodatetimestring + ;; day/month/year must be present + (let ((year (read (substring isodatetimestring 0 4))) + (month (read (substring isodatetimestring 4 6))) + (day (read (substring isodatetimestring 6 8))) + (hour 0) + (minute 0) + (second 0)) + (when (> (length isodatetimestring) 12) + ;; hour/minute present + (setq hour (read (substring isodatetimestring 9 11))) + (setq minute (read (substring isodatetimestring 11 13)))) + (when (> (length isodatetimestring) 14) + ;; seconds present + (setq second (read (substring isodatetimestring 13 15)))) + (when (and (> (length isodatetimestring) 15) + ;; UTC specifier present + (char-equal ?Z (aref isodatetimestring 15))) + ;; if not UTC add current-time-zone offset + (setq second (+ (car (current-time-zone)) second))) + ;; shift if necessary + (if day-shift + (let ((mdy (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian + (list month day year)) + day-shift)))) + (setq month (nth 0 mdy)) + (setq day (nth 1 mdy)) + (setq year (nth 2 mdy)))) + ;; create the decoded date-time + ;; FIXME!?! + (condition-case nil + (decode-time (encode-time second minute hour day month year)) + (error + (message "Cannot decode \"%s\"" isodatetimestring) + ;; hope for the best... + (list second minute hour day month year 0 nil 0)))) + ;; isodatetimestring == nil + nil)) + +(defun icalendar--decode-isoduration (isodurationstring + &optional duration-correction) + "Convert ISODURATIONSTRING into format provided by `decode-time'. +Converts from ISO-8601 to Emacs representation. If ISODURATIONSTRING +specifies UTC time (trailing letter Z) the decoded time is given in +the local time zone! + +Optional argument DURATION-CORRECTION shortens result by one day. + +FIXME: TZID-attributes are ignored....! +FIXME: multiple comma-separated values should be allowed!" + (if isodurationstring + (save-match-data + (string-match + (concat + "^P[+-]?\\(" + "\\(\\([0-9]+\\)D\\)" ; days only + "\\|" + "\\(\\(\\([0-9]+\\)D\\)?T\\(\\([0-9]+\\)H\\)?" ; opt days + "\\(\\([0-9]+\\)M\\)?\\(\\([0-9]+\\)S\\)?\\)" ; mand. time + "\\|" + "\\(\\([0-9]+\\)W\\)" ; weeks only + "\\)$") isodurationstring) + (let ((seconds 0) + (minutes 0) + (hours 0) + (days 0) + (months 0) + (years 0)) + (cond + ((match-beginning 2) ;days only + (setq days (read (substring isodurationstring + (match-beginning 3) + (match-end 3)))) + (when duration-correction + (setq days (1- days)))) + ((match-beginning 4) ;days and time + (if (match-beginning 5) + (setq days (* 7 (read (substring isodurationstring + (match-beginning 6) + (match-end 6)))))) + (if (match-beginning 7) + (setq hours (read (substring isodurationstring + (match-beginning 8) + (match-end 8))))) + (if (match-beginning 9) + (setq minutes (read (substring isodurationstring + (match-beginning 10) + (match-end 10))))) + (if (match-beginning 11) + (setq seconds (read (substring isodurationstring + (match-beginning 12) + (match-end 12)))))) + ((match-beginning 13) ;weeks only + (setq days (* 7 (read (substring isodurationstring + (match-beginning 14) + (match-end 14))))))) + (list seconds minutes hours days months years))) + ;; isodatetimestring == nil + nil)) + +(defun icalendar--add-decoded-times (time1 time2) + "Add TIME1 to TIME2. +Both times must be given in decoded form. One of these times must be +valid (year > 1900 or something)." + ;; FIXME: does this function exist already? + (decode-time (encode-time + (+ (nth 0 time1) (nth 0 time2)) + (+ (nth 1 time1) (nth 1 time2)) + (+ (nth 2 time1) (nth 2 time2)) + (+ (nth 3 time1) (nth 3 time2)) + (+ (nth 4 time1) (nth 4 time2)) + (+ (nth 5 time1) (nth 5 time2)) + nil + nil + ;;(or (nth 6 time1) (nth 6 time2)) ;; FIXME? + ))) + +(defun icalendar--datetime-to-noneuropean-date (datetime &optional separator) + "Convert the decoded DATETIME to non-european-style format. +Optional argument SEPARATOR gives the separator between month, +day, and year. If nil a blank character is used as separator. +Non-European format: \"month day year\"." + (if datetime + (format "%d%s%d%s%d" (nth 4 datetime) ;month + (or separator " ") + (nth 3 datetime) ;day + (or separator " ") + (nth 5 datetime)) ;year + ;; datetime == nil + nil)) + +(defun icalendar--datetime-to-european-date (datetime &optional separator) + "Convert the decoded DATETIME to European format. +Optional argument SEPARATOR gives the separator between month, +day, and year. If nil a blank character is used as separator. +European format: (day month year). +FIXME" + (if datetime + (format "%d%s%d%s%d" (nth 3 datetime) ;day + (or separator " ") + (nth 4 datetime) ;month + (or separator " ") + (nth 5 datetime)) ;year + ;; datetime == nil + nil)) + +(defun icalendar--datetime-to-diary-date (datetime &optional separator) + "Convert the decoded DATETIME to diary format. +Optional argument SEPARATOR gives the separator between month, +day, and year. If nil a blank character is used as separator. +Call icalendar--datetime-to-(non)-european-date according to +value of `european-calendar-style'." + (if european-calendar-style + (icalendar--datetime-to-european-date datetime separator) + (icalendar--datetime-to-noneuropean-date datetime separator))) + +(defun icalendar--datetime-to-colontime (datetime) + "Extract the time part of a decoded DATETIME into 24-hour format. +Note that this silently ignores seconds." + (format "%02d:%02d" (nth 2 datetime) (nth 1 datetime))) + +(defun icalendar--get-month-number (monthname) + "Return the month number for the given MONTHNAME." + (catch 'found + (let ((num 1) + (m (downcase monthname))) + (mapc (lambda (month) + (let ((mm (downcase month))) + (if (or (string-equal mm m) + (string-equal (substring mm 0 3) m)) + (throw 'found num)) + (setq num (1+ num)))) + calendar-month-name-array)) + ;; Error: + -1)) + +(defun icalendar--get-weekday-number (abbrevweekday) + "Return the number for the ABBREVWEEKDAY." + (if abbrevweekday + (catch 'found + (let ((num 0) + (aw (downcase abbrevweekday))) + (mapc (lambda (day) + (let ((d (downcase day))) + (if (string-equal d aw) + (throw 'found num)) + (setq num (1+ num)))) + icalendar--weekday-array))) + ;; Error: + -1)) + +(defun icalendar--get-weekday-abbrev (weekday) + "Return the abbreviated WEEKDAY." + (catch 'found + (let ((num 0) + (w (downcase weekday))) + (mapc (lambda (day) + (let ((d (downcase day))) + (if (or (string-equal d w) + (string-equal (substring d 0 3) w)) + (throw 'found (aref icalendar--weekday-array num))) + (setq num (1+ num)))) + calendar-day-name-array)) + ;; Error: + nil)) + +(defun icalendar--date-to-isodate (date &optional day-shift) + "Convert DATE to iso-style date. +DATE must be a list of the form (month day year). +If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days." + (let ((mdy (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian date) + (or day-shift 0))))) + (format "%04d%02d%02d" (nth 2 mdy) (nth 0 mdy) (nth 1 mdy)))) + + +(defun icalendar--datestring-to-isodate (datestring &optional day-shift) + "Convert diary-style DATESTRING to iso-style date. +If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days +-- DAY-SHIFT must be either nil or an integer. This function +takes care of european-style." + (let ((day -1) month year) + (save-match-data + (cond ( ;; numeric date + (string-match (concat "\\s-*" + "0?\\([1-9][0-9]?\\)[ \t/]\\s-*" + "0?\\([1-9][0-9]?\\),?[ \t/]\\s-*" + "\\([0-9]\\{4\\}\\)") + datestring) + (setq day (read (substring datestring (match-beginning 1) + (match-end 1)))) + (setq month (read (substring datestring (match-beginning 2) + (match-end 2)))) + (setq year (read (substring datestring (match-beginning 3) + (match-end 3)))) + (unless european-calendar-style + (let ((x month)) + (setq month day) + (setq day x)))) + ( ;; date contains month names -- european-style + (string-match (concat "\\s-*" + "0?\\([123]?[0-9]\\)[ \t/]\\s-*" + "\\([A-Za-z][^ ]+\\)[ \t/]\\s-*" + "\\([0-9]\\{4\\}\\)") + datestring) + (setq day (read (substring datestring (match-beginning 1) + (match-end 1)))) + (setq month (icalendar--get-month-number + (substring datestring (match-beginning 2) + (match-end 2)))) + (setq year (read (substring datestring (match-beginning 3) + (match-end 3))))) + ( ;; date contains month names -- non-european-style + (string-match (concat "\\s-*" + "\\([A-Za-z][^ ]+\\)[ \t/]\\s-*" + "0?\\([123]?[0-9]\\),?[ \t/]\\s-*" + "\\([0-9]\\{4\\}\\)") + datestring) + (setq day (read (substring datestring (match-beginning 2) + (match-end 2)))) + (setq month (icalendar--get-month-number + (substring datestring (match-beginning 1) + (match-end 1)))) + (setq year (read (substring datestring (match-beginning 3) + (match-end 3))))) + (t + nil))) + (if (> day 0) + (let ((mdy (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian (list month day + year)) + (or day-shift 0))))) + (format "%04d%02d%02d" (nth 2 mdy) (nth 0 mdy) (nth 1 mdy))) + nil))) + +(defun icalendar--diarytime-to-isotime (timestring ampmstring) + "Convert a a time like 9:30pm to an iso-conform string like T213000. +In this example the TIMESTRING would be \"9:30\" and the AMPMSTRING +would be \"pm\"." + (if timestring + (let ((starttimenum (read (icalendar--rris ":" "" timestring)))) + ;; take care of am/pm style + (if (and ampmstring (string= "pm" ampmstring)) + (setq starttimenum (+ starttimenum 1200))) + (format "T%04d00" starttimenum)) + nil)) + +(defun icalendar--convert-string-for-export (string) + "Escape comma and other critical characters in STRING." + (icalendar--rris "," "\\\\," string)) + +(defun icalendar--convert-string-for-import (string) + "Remove escape chars for comma, semicolon etc. from STRING." + (icalendar--rris + "\\\\n" "\n " (icalendar--rris + "\\\\\"" "\"" (icalendar--rris + "\\\\;" ";" (icalendar--rris + "\\\\," "," string))))) + +;; ====================================================================== +;; Export -- convert emacs-diary to icalendar +;; ====================================================================== + +;;;###autoload +(defun icalendar-export-file (diary-filename ical-filename) + "Export diary file to iCalendar format. +All diary entries in the file DIARY-FILENAME are converted to iCalendar +format. The result is appended to the file ICAL-FILENAME." + (interactive "FExport diary data from file: +Finto iCalendar file: ") + (save-current-buffer + (set-buffer (find-file diary-filename)) + (icalendar-export-region (point-min) (point-max) ical-filename))) + +(defalias 'icalendar-convert-diary-to-ical 'icalendar-export-file) +(make-obsolete 'icalendar-convert-diary-to-ical 'icalendar-export-file) + +;;;###autoload +(defun icalendar-export-region (min max ical-filename) + "Export region in diary file to iCalendar format. +All diary entries in the region from MIN to MAX in the current buffer are +converted to iCalendar format. The result is appended to the file +ICAL-FILENAME. +This function attempts to return t if something goes wrong. In this +case an error string which describes all the errors and problems is +written into the buffer `*icalendar-errors*'." + (interactive "r +FExport diary data into iCalendar file: ") + (let ((result "") + (start 0) + (entry-main "") + (entry-rest "") + (header "") + (contents-n-summary) + (contents) + (found-error nil) + (nonmarker (concat "^" (regexp-quote diary-nonmarking-symbol) + "?")) + (other-elements nil)) + ;; prepare buffer with error messages + (save-current-buffer + (set-buffer (get-buffer-create "*icalendar-errors*")) + (erase-buffer)) + + ;; here we go + (save-excursion + (goto-char min) + (while (re-search-forward + "^\\([^ \t\n].+\\)\\(\\(\n[ \t].*\\)*\\)" max t) + (setq entry-main (match-string 1)) + (if (match-beginning 2) + (setq entry-rest (match-string 2)) + (setq entry-rest "")) + (setq header (format "\nBEGIN:VEVENT\nUID:emacs%d%d%d" + (car (current-time)) + (cadr (current-time)) + (car (cddr (current-time))))) + (condition-case error-val + (progn + (setq contents-n-summary + (icalendar--convert-to-ical nonmarker entry-main)) + (setq other-elements (icalendar--parse-summary-and-rest + (concat entry-main entry-rest))) + (setq contents (concat (car contents-n-summary) + "\nSUMMARY:" (cadr contents-n-summary))) + (let ((cla (cdr (assoc 'cla other-elements))) + (des (cdr (assoc 'des other-elements))) + (loc (cdr (assoc 'loc other-elements))) + (org (cdr (assoc 'org other-elements))) + (sta (cdr (assoc 'sta other-elements))) + (sum (cdr (assoc 'sum other-elements))) + (url (cdr (assoc 'url other-elements)))) + (if cla + (setq contents (concat contents "\nCLASS:" cla))) + (if des + (setq contents (concat contents "\nDESCRIPTION:" des))) + (if loc + (setq contents (concat contents "\nLOCATION:" loc))) + (if org + (setq contents (concat contents "\nORGANIZER:" org))) + (if sta + (setq contents (concat contents "\nSTATUS:" sta))) + ;;(if sum + ;; (setq contents (concat contents "\nSUMMARY:" sum))) + (if url + (setq contents (concat contents "\nURL:" url)))) + (setq result (concat result header contents "\nEND:VEVENT"))) + ;; handle errors + (error + (setq found-error t) + (save-current-buffer + (set-buffer (get-buffer-create "*icalendar-errors*")) + (insert (format "Error in line %d -- %s: `%s'\n" + (count-lines (point-min) (point)) + (cadr error-val) + entry-main)))))) + + ;; we're done, insert everything into the file + (save-current-buffer + (let ((coding-system-for-write 'utf-8)) + (set-buffer (find-file ical-filename)) + (goto-char (point-max)) + (insert "BEGIN:VCALENDAR") + (insert "\nPRODID:-//Emacs//NONSGML icalendar.el//EN") + (insert "\nVERSION:2.0") + (insert result) + (insert "\nEND:VCALENDAR\n") + ;; save the diary file + (save-buffer) + (unless found-error + (bury-buffer))))) + found-error)) + +(defun icalendar--convert-to-ical (nonmarker entry-main) + "Convert a diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (or + ;; anniversaries -- %%(diary-anniversary ...) + (icalendar--convert-anniversary-to-ical nonmarker entry-main) + ;; cyclic events -- %%(diary-cyclic ...) + (icalendar--convert-cyclic-to-ical nonmarker entry-main) + ;; diary-date -- %%(diary-date ...) + (icalendar--convert-date-to-ical nonmarker entry-main) + ;; float events -- %%(diary-float ...) + (icalendar--convert-float-to-ical nonmarker entry-main) + ;; block events -- %%(diary-block ...) + (icalendar--convert-block-to-ical nonmarker entry-main) + ;; other sexp diary entries + (icalendar--convert-sexp-to-ical nonmarker entry-main) + ;; weekly by day -- Monday 8:30 Team meeting + (icalendar--convert-weekly-to-ical nonmarker entry-main) + ;; yearly by day -- 1 May Tag der Arbeit + (icalendar--convert-yearly-to-ical nonmarker entry-main) + ;; "ordinary" events, start and end time given + ;; 1 Feb 2003 blah + (icalendar--convert-ordinary-to-ical nonmarker entry-main) + ;; everything else + ;; Oops! what's that? + (error "Could not parse entry"))) + +(defun icalendar--parse-summary-and-rest (summary-and-rest) + "Parse SUMMARY-AND-REST from a diary to fill iCalendar properties." + (save-match-data + (let* ((s icalendar-import-format) + (p-cla (or (string-match "%c" icalendar-import-format) -1)) + (p-des (or (string-match "%d" icalendar-import-format) -1)) + (p-loc (or (string-match "%l" icalendar-import-format) -1)) + (p-org (or (string-match "%o" icalendar-import-format) -1)) + (p-sum (or (string-match "%s" icalendar-import-format) -1)) + (p-sta (or (string-match "%t" icalendar-import-format) -1)) + (p-url (or (string-match "%u" icalendar-import-format) -1)) + (p-list (sort (list p-cla p-des p-loc p-org p-sta p-sum p-url) '<)) + pos-cla pos-des pos-loc pos-org pos-sta pos-sum pos-url) + (dotimes (i (length p-list)) + (cond ((and (>= p-cla 0) (= (nth i p-list) p-cla)) + (setq pos-cla (+ 2 (* 2 i)))) + ((and (>= p-des 0) (= (nth i p-list) p-des)) + (setq pos-des (+ 2 (* 2 i)))) + ((and (>= p-loc 0) (= (nth i p-list) p-loc)) + (setq pos-loc (+ 2 (* 2 i)))) + ((and (>= p-org 0) (= (nth i p-list) p-org)) + (setq pos-org (+ 2 (* 2 i)))) + ((and (>= p-sta 0) (= (nth i p-list) p-sta)) + (setq pos-sta (+ 2 (* 2 i)))) + ((and (>= p-sum 0) (= (nth i p-list) p-sum)) + (setq pos-sum (+ 2 (* 2 i)))) + ((and (>= p-url 0) (= (nth i p-list) p-url)) + (setq pos-url (+ 2 (* 2 i)))))) + (mapc (lambda (ij) + (setq s (icalendar--rris (car ij) (cadr ij) s t t))) + (list + ;; summary must be first! because of %s + (list "%s" + (concat "\\(" icalendar-import-format-summary "\\)?")) + (list "%c" + (concat "\\(" icalendar-import-format-class "\\)?")) + (list "%d" + (concat "\\(" icalendar-import-format-description "\\)?")) + (list "%l" + (concat "\\(" icalendar-import-format-location "\\)?")) + (list "%o" + (concat "\\(" icalendar-import-format-organizer "\\)?")) + (list "%t" + (concat "\\(" icalendar-import-format-status "\\)?")) + (list "%u" + (concat "\\(" icalendar-import-format-url "\\)?")))) + (setq s (concat (icalendar--rris "%s" "\\(.*\\)" s nil t) " ")) + (if (string-match s summary-and-rest) + (let (cla des loc org sta sum url) + (if (and pos-sum (match-beginning pos-sum)) + (setq sum (substring summary-and-rest + (match-beginning pos-sum) + (match-end pos-sum)))) + (if (and pos-cla (match-beginning pos-cla)) + (setq cla (substring summary-and-rest + (match-beginning pos-cla) + (match-end pos-cla)))) + (if (and pos-des (match-beginning pos-des)) + (setq des (substring summary-and-rest + (match-beginning pos-des) + (match-end pos-des)))) + (if (and pos-loc (match-beginning pos-loc)) + (setq loc (substring summary-and-rest + (match-beginning pos-loc) + (match-end pos-loc)))) + (if (and pos-org (match-beginning pos-org)) + (setq org (substring summary-and-rest + (match-beginning pos-org) + (match-end pos-org)))) + (if (and pos-sta (match-beginning pos-sta)) + (setq sta (substring summary-and-rest + (match-beginning pos-sta) + (match-end pos-sta)))) + (if (and pos-url (match-beginning pos-url)) + (setq url (substring summary-and-rest + (match-beginning pos-url) + (match-end pos-url)))) + (list (if cla (cons 'cla cla) nil) + (if des (cons 'des des) nil) + (if loc (cons 'loc loc) nil) + (if org (cons 'org org) nil) + (if sta (cons 'sta sta) nil) + ;;(if sum (cons 'sum sum) nil) + (if url (cons 'url url) nil))))))) + +;; subroutines for icalendar-export-region +(defun icalendar--convert-ordinary-to-ical (nonmarker entry-main) + "Convert \"ordinary\" diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\)\\s-*" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" + "\\(" + "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\(.*?\\) ?$") + entry-main) + (let* ((datetime (substring entry-main (match-beginning 1) + (match-end 1))) + (startisostring (icalendar--datestring-to-isodate + datetime)) + (endisostring (icalendar--datestring-to-isodate + datetime 1)) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 3) + (substring entry-main + (match-beginning 3) + (match-end 3)) + nil) + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 6) + (substring entry-main + (match-beginning 6) + (match-end 6)) + nil) + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 8) + (match-end 8))))) + (icalendar--dmsg "ordinary %s" entry-main) + + (unless startisostring + (error "Could not parse date")) + (when starttimestring + (unless endtimestring + (let ((time + (read (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (list (concat "\nDTSTART;" + (if starttimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + startisostring + (or starttimestring "") + "\nDTEND;" + (if endtimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + (if starttimestring + startisostring + endisostring) + (or endtimestring "")) + summary)) + ;; no match + nil)) + +(defun icalendar--convert-weekly-to-ical (nonmarker entry-main) + "Convert weekly diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (and (string-match (concat nonmarker + "\\([a-z]+\\)\\s-+" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)" + "\\([ap]m\\)?" + "\\(-0?" + "\\([1-9][0-9]?:[0-9][0-9]\\)" + "\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\(.*?\\) ?$") + entry-main) + (icalendar--get-weekday-abbrev + (substring entry-main (match-beginning 1) + (match-end 1)))) + (let* ((day (icalendar--get-weekday-abbrev + (substring entry-main (match-beginning 1) + (match-end 1)))) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 3) + (substring entry-main + (match-beginning 3) + (match-end 3)) + nil) + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 6) + (substring entry-main + (match-beginning 6) + (match-end 6)) + nil) + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 8) + (match-end 8))))) + (icalendar--dmsg "weekly %s" entry-main) + + (when starttimestring + (unless endtimestring + (let ((time (read + (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (list (concat "\nDTSTART;" + (if starttimestring + "VALUE=DATE-TIME:" + "VALUE=DATE:") + ;; find the correct week day, + ;; 1st january 2000 was a saturday + (format + "200001%02d" + (+ (icalendar--get-weekday-number day) 2)) + (or starttimestring "") + "\nDTEND;" + (if endtimestring + "VALUE=DATE-TIME:" + "VALUE=DATE:") + (format + "200001%02d" + ;; end is non-inclusive! + (+ (icalendar--get-weekday-number day) + (if endtimestring 2 3))) + (or endtimestring "") + "\nRRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=" + day) + summary)) + ;; no match + nil)) + +(defun icalendar--convert-yearly-to-ical (nonmarker entry-main) + "Convert yearly diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + (if european-calendar-style + "0?\\([1-9]+[0-9]?\\)\\s-+\\([a-z]+\\)\\s-+" + "\\([a-z]+\\)\\s-+0?\\([1-9]+[0-9]?\\)\\s-+") + "\\*?\\s-*" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" + "\\(" + "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\([^0-9]+.*?\\) ?$" ; must not match years + ) + entry-main) + (let* ((daypos (if european-calendar-style 1 2)) + (monpos (if european-calendar-style 2 1)) + (day (read (substring entry-main + (match-beginning daypos) + (match-end daypos)))) + (month (icalendar--get-month-number + (substring entry-main + (match-beginning monpos) + (match-end monpos)))) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil) + (if (match-beginning 5) + (substring entry-main + (match-beginning 5) + (match-end 5)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil) + (if (match-beginning 8) + (substring entry-main + (match-beginning 8) + (match-end 8)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 9) + (match-end 9))))) + (icalendar--dmsg "yearly %s" entry-main) + + (when starttimestring + (unless endtimestring + (let ((time (read + (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (list (concat "\nDTSTART;" + (if starttimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + (format "1900%02d%02d" month day) + (or starttimestring "") + "\nDTEND;" + (if endtimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + ;; end is not included! shift by one day + (icalendar--date-to-isodate + (list month day 1900) + (if endtimestring 0 1)) + (or endtimestring "") + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=" + (format "%2d" month) + ";BYMONTHDAY=" + (format "%2d" day)) + summary)) + ;; no match + nil)) + +(defun icalendar--convert-sexp-to-ical (nonmarker entry-main) + "Convert complex sexp diary entry to icalendar format -- unsupported! + +FIXME! + +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (cond ((string-match (concat nonmarker + "%%(and \\(([^)]+)\\))\\(\\s-*.*?\\) ?$") + entry-main) + ;; simple sexp entry as generated by icalendar.el: strip off the + ;; unnecessary (and) + (icalendar--dmsg "diary-sexp from icalendar.el %s" entry-main) + (icalendar--convert-to-ical + nonmarker + (concat "%%" + (substring entry-main (match-beginning 1) (match-end 1)) + (substring entry-main (match-beginning 2) (match-end 2))))) + ((string-match (concat nonmarker + "%%([^)]+)\\s-*.*") + entry-main) + (icalendar--dmsg "diary-sexp %s" entry-main) + (error "Sexp-entries are not supported yet")) + (t + ;; no match + nil))) + +(defun icalendar--convert-block-to-ical (nonmarker entry-main) + "Convert block diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "%%(diary-block \\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\)" + " +\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" + "\\(" + "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\(.*?\\) ?$") + entry-main) + (let* ((startstring (substring entry-main + (match-beginning 1) + (match-end 1))) + (endstring (substring entry-main + (match-beginning 2) + (match-end 2))) + (startisostring (icalendar--datestring-to-isodate + startstring)) + (endisostring (icalendar--datestring-to-isodate + endstring)) + (endisostring+1 (icalendar--datestring-to-isodate + endstring 1)) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil) + (if (match-beginning 5) + (substring entry-main + (match-beginning 5) + (match-end 5)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil) + (if (match-beginning 8) + (substring entry-main + (match-beginning 8) + (match-end 8)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 9) + (match-end 9))))) + (icalendar--dmsg "diary-block %s" entry-main) + (when starttimestring + (unless endtimestring + (let ((time + (read (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (if starttimestring + ;; with time -> write rrule + (list (concat "\nDTSTART;VALUE=DATE-TIME:" + startisostring + starttimestring + "\nDTEND;VALUE=DATE-TIME:" + startisostring + endtimestring + "\nRRULE:FREQ=DAILY;INTERVAL=1;UNTIL=" + endisostring) + summary) + ;; no time -> write long event + (list (concat "\nDTSTART;VALUE=DATE:" startisostring + "\nDTEND;VALUE=DATE:" endisostring+1) + summary))) + ;; no match + nil)) + +(defun icalendar--convert-float-to-ical (nonmarker entry-main) + "Convert float diary entry to icalendar format -- unsupported! + +FIXME! + +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "%%(diary-float \\([^)]+\\))\\s-*\\(.*?\\) ?$") + entry-main) + (progn + (icalendar--dmsg "diary-float %s" entry-main) + (error "`diary-float' is not supported yet")) + ;; no match + nil)) + +(defun icalendar--convert-date-to-ical (nonmarker entry-main) + "Convert `diary-date' diary entry to icalendar format -- unsupported! + +FIXME! + +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "%%(diary-date \\([^)]+\\))\\s-*\\(.*?\\) ?$") + entry-main) + (progn + (icalendar--dmsg "diary-date %s" entry-main) + (error "`diary-date' is not supported yet")) + ;; no match + nil)) + +(defun icalendar--convert-cyclic-to-ical (nonmarker entry-main) + "Convert `diary-cyclic' diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "%%(diary-cyclic \\([^ ]+\\) +" + "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" + "\\(" + "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\(.*?\\) ?$") + entry-main) + (let* ((frequency (substring entry-main (match-beginning 1) + (match-end 1))) + (datetime (substring entry-main (match-beginning 2) + (match-end 2))) + (startisostring (icalendar--datestring-to-isodate + datetime)) + (endisostring (icalendar--datestring-to-isodate + datetime)) + (endisostring+1 (icalendar--datestring-to-isodate + datetime 1)) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil) + (if (match-beginning 5) + (substring entry-main + (match-beginning 5) + (match-end 5)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil) + (if (match-beginning 8) + (substring entry-main + (match-beginning 8) + (match-end 8)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 9) + (match-end 9))))) + (icalendar--dmsg "diary-cyclic %s" entry-main) + (when starttimestring + (unless endtimestring + (let ((time + (read (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (list (concat "\nDTSTART;" + (if starttimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + startisostring + (or starttimestring "") + "\nDTEND;" + (if endtimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + (if endtimestring endisostring endisostring+1) + (or endtimestring "") + "\nRRULE:FREQ=DAILY;INTERVAL=" frequency + ;; strange: korganizer does not expect + ;; BYSOMETHING here... + ) + summary)) + ;; no match + nil)) + +(defun icalendar--convert-anniversary-to-ical (nonmarker entry-main) + "Convert `diary-anniversary' diary entry to icalendar format. +NONMARKER is a regular expression matching the start of non-marking +entries. ENTRY-MAIN is the first line of the diary entry." + (if (string-match (concat nonmarker + "%%(diary-anniversary \\([^)]+\\))\\s-*" + "\\(0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" + "\\(" + "-0?\\([1-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?\\)?" + "\\)?" + "\\s-*\\(.*?\\) ?$") + entry-main) + (let* ((datetime (substring entry-main (match-beginning 1) + (match-end 1))) + (startisostring (icalendar--datestring-to-isodate + datetime)) + (endisostring (icalendar--datestring-to-isodate + datetime 1)) + (starttimestring (icalendar--diarytime-to-isotime + (if (match-beginning 3) + (substring entry-main + (match-beginning 3) + (match-end 3)) + nil) + (if (match-beginning 4) + (substring entry-main + (match-beginning 4) + (match-end 4)) + nil))) + (endtimestring (icalendar--diarytime-to-isotime + (if (match-beginning 6) + (substring entry-main + (match-beginning 6) + (match-end 6)) + nil) + (if (match-beginning 7) + (substring entry-main + (match-beginning 7) + (match-end 7)) + nil))) + (summary (icalendar--convert-string-for-export + (substring entry-main (match-beginning 8) + (match-end 8))))) + (icalendar--dmsg "diary-anniversary %s" entry-main) + (when starttimestring + (unless endtimestring + (let ((time + (read (icalendar--rris "^T0?" "" + starttimestring)))) + (setq endtimestring (format "T%06d" + (+ 10000 time)))))) + (list (concat "\nDTSTART;" + (if starttimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + startisostring + (or starttimestring "") + "\nDTEND;" + (if endtimestring "VALUE=DATE-TIME:" + "VALUE=DATE:") + endisostring + (or endtimestring "") + "\nRRULE:FREQ=YEARLY;INTERVAL=1" + ;; the following is redundant, + ;; but korganizer seems to expect this... ;( + ;; and evolution doesn't understand it... :( + ;; so... who is wrong?! + ";BYMONTH=" + (substring startisostring 4 6) + ";BYMONTHDAY=" + (substring startisostring 6 8)) + summary)) + ;; no match + nil)) + +;; ====================================================================== +;; Import -- convert icalendar to emacs-diary +;; ====================================================================== + +;;;###autoload +(defun icalendar-import-file (ical-filename diary-filename + &optional non-marking) + "Import an iCalendar file and append to a diary file. +Argument ICAL-FILENAME output iCalendar file. +Argument DIARY-FILENAME input `diary-file'. +Optional argument NON-MARKING determines whether events are created as +non-marking or not." + (interactive "fImport iCalendar data from file: +Finto diary file: +p") + ;; clean up the diary file + (save-current-buffer + ;; now load and convert from the ical file + (set-buffer (find-file ical-filename)) + (icalendar-import-buffer diary-filename t non-marking))) + +;;;###autoload +(defun icalendar-import-buffer (&optional diary-file do-not-ask + non-marking) + "Extract iCalendar events from current buffer. + +This function searches the current buffer for the first iCalendar +object, reads it and adds all VEVENT elements to the diary +DIARY-FILE. + +It will ask for each appointment whether to add it to the diary +when DO-NOT-ASK is non-nil. When called interactively, +DO-NOT-ASK is set to t, so that you are asked fore each event. + +NON-MARKING determines whether diary events are created as +non-marking. + +Return code t means that importing worked well, return code nil +means that an error has occured. Error messages will be in the +buffer `*icalendar-errors*'." + (interactive) + (save-current-buffer + ;; prepare ical + (message "Preparing icalendar...") + (set-buffer (icalendar--get-unfolded-buffer (current-buffer))) + (goto-char (point-min)) + (message "Preparing icalendar...done") + (if (re-search-forward "^BEGIN:VCALENDAR\\s-*$" nil t) + (let (ical-contents ical-errors) + ;; read ical + (message "Reading icalendar...") + (beginning-of-line) + (setq ical-contents (icalendar--read-element nil nil)) + (message "Reading icalendar...done") + ;; convert ical + (message "Converting icalendar...") + (setq ical-errors (icalendar--convert-ical-to-diary + ical-contents + diary-file do-not-ask non-marking)) + (when diary-file + ;; save the diary file if it is visited already + (let ((b (find-buffer-visiting diary-file))) + (when b + (save-current-buffer + (set-buffer b) + (save-buffer))))) + (message "Converting icalendar...done") + ;; return t if no error occured + (not ical-errors)) + (message + "Current buffer does not contain icalendar contents!") + ;; return nil, i.e. import did not work + nil))) + +(defalias 'icalendar-extract-ical-from-buffer 'icalendar-import-buffer) +(make-obsolete 'icalendar-extract-ical-from-buffer 'icalendar-import-buffer) + +(defun icalendar--format-ical-event (event) + "Create a string representation of an iCalendar EVENT." + (let ((string icalendar-import-format) + (conversion-list + '(("%c" CLASS icalendar-import-format-class) + ("%d" DESCRIPTION icalendar-import-format-description) + ("%l" LOCATION icalendar-import-format-location) + ("%o" ORGANIZER icalendar-import-format-organizer) + ("%s" SUMMARY icalendar-import-format-summary) + ("%t" STATUS icalendar-import-format-status) + ("%u" URL icalendar-import-format-url)))) + ;; convert the specifiers in the format string + (mapcar (lambda (i) + (let* ((spec (car i)) + (prop (cadr i)) + (format (car (cddr i))) + (contents (icalendar--get-event-property event prop)) + (formatted-contents "")) + (when (and contents (> (length contents) 0)) + (setq formatted-contents + (icalendar--rris "%s" + (icalendar--convert-string-for-import + contents) + (symbol-value format) + t t))) + (setq string (icalendar--rris spec + formatted-contents + string + t t)))) + conversion-list) + string)) + +(defun icalendar--convert-ical-to-diary (ical-list diary-file + &optional do-not-ask + non-marking) + "Convert Calendar data to an Emacs diary file. +Import VEVENTS from the iCalendar object ICAL-LIST and saves them to a +DIARY-FILE. If DO-NOT-ASK is nil the user is asked for each event +whether to actually import it. NON-MARKING determines whether diary +events are created as non-marking. +This function attempts to return t if something goes wrong. In this +case an error string which describes all the errors and problems is +written into the buffer `*icalendar-errors*'." + (let* ((ev (icalendar--all-events ical-list)) + (error-string "") + (event-ok t) + (found-error nil) + e diary-string) + ;; step through all events/appointments + (while ev + (setq e (car ev)) + (setq ev (cdr ev)) + (setq event-ok nil) + (condition-case error-val + (let* ((dtstart (icalendar--get-event-property e 'DTSTART)) + (dtstart-dec (icalendar--decode-isodatetime dtstart)) + (start-d (icalendar--datetime-to-diary-date + dtstart-dec)) + (start-t (icalendar--datetime-to-colontime dtstart-dec)) + (dtend (icalendar--get-event-property e 'DTEND)) + (dtend-dec (icalendar--decode-isodatetime dtend)) + (dtend-1-dec (icalendar--decode-isodatetime dtend -1)) + end-d + end-1-d + end-t + (summary (icalendar--convert-string-for-import + (or (icalendar--get-event-property e 'SUMMARY) + "No summary"))) + (rrule (icalendar--get-event-property e 'RRULE)) + (rdate (icalendar--get-event-property e 'RDATE)) + (duration (icalendar--get-event-property e 'DURATION))) + (icalendar--dmsg "%s: `%s'" start-d summary) + ;; check whether start-time is missing + (if (and dtstart + (string= + (cadr (icalendar--get-event-property-attributes + e 'DTSTART)) + "DATE")) + (setq start-t nil)) + (when duration + (let ((dtend-dec-d (icalendar--add-decoded-times + dtstart-dec + (icalendar--decode-isoduration duration))) + (dtend-1-dec-d (icalendar--add-decoded-times + dtstart-dec + (icalendar--decode-isoduration duration + t)))) + (if (and dtend-dec (not (eq dtend-dec dtend-dec-d))) + (message "Inconsistent endtime and duration for %s" + summary)) + (setq dtend-dec dtend-dec-d) + (setq dtend-1-dec dtend-1-dec-d))) + (setq end-d (if dtend-dec + (icalendar--datetime-to-diary-date dtend-dec) + start-d)) + (setq end-1-d (if dtend-1-dec + (icalendar--datetime-to-diary-date dtend-1-dec) + start-d)) + (setq end-t (if (and + dtend-dec + (not (string= + (cadr + (icalendar--get-event-property-attributes + e 'DTEND)) + "DATE"))) + (icalendar--datetime-to-colontime dtend-dec) + start-t)) + (icalendar--dmsg "start-d: %s, end-d: %s" start-d end-d) + (cond + ;; recurring event + (rrule + (setq diary-string + (icalendar--convert-recurring-to-diary e dtstart-dec start-t + end-t)) + (setq event-ok t)) + (rdate + (icalendar--dmsg "rdate event") + (setq diary-string "") + (mapcar (lambda (datestring) + (setq diary-string + (concat diary-string + (format "......")))) + (icalendar--split-value rdate))) + ;; non-recurring event + ;; all-day event + ((not (string= start-d end-d)) + (setq diary-string + (icalendar--convert-non-recurring-all-day-to-diary + e start-d end-1-d)) + (setq event-ok t)) + ;; not all-day + ((and start-t (or (not end-t) + (not (string= start-t end-t)))) + (setq diary-string + (icalendar--convert-non-recurring-not-all-day-to-diary + e dtstart-dec dtend-dec start-t end-t)) + (setq event-ok t)) + ;; all-day event + (t + (icalendar--dmsg "all day event") + (setq diary-string (icalendar--datetime-to-diary-date + dtstart-dec "/")) + (setq event-ok t))) + ;; add all other elements unless the user doesn't want to have + ;; them + (if event-ok + (progn + (setq diary-string + (concat diary-string " " + (icalendar--format-ical-event e))) + (if do-not-ask (setq summary nil)) + (icalendar--add-diary-entry diary-string diary-file + non-marking summary)) + ;; event was not ok + (setq found-error t) + (setq error-string + (format "%s\nCannot handle this event:%s" + error-string e)))) + ;; FIXME: inform user about ignored event properties + ;; handle errors + (error + (message "Ignoring event \"%s\"" e) + (setq found-error t) + (setq error-string (format "%s\n%s\nCannot handle this event: %s" + error-val error-string e)) + (message "%s" error-string)))) + (if found-error + (save-current-buffer + (set-buffer (get-buffer-create "*icalendar-errors*")) + (erase-buffer) + (insert error-string))) + (message "Converting icalendar...done") + found-error)) + +;; subroutines for importing +(defun icalendar--convert-recurring-to-diary (e dtstart-dec start-t end-t) + "Convert recurring icalendar event E to diary format. + +DTSTART-DEC is the DTSTART property of E. +START-T is the event's start time in diary format. +END-T is the event's end time in diary format." + (icalendar--dmsg "recurring event") + (let* ((rrule (icalendar--get-event-property e 'RRULE)) + (rrule-props (icalendar--split-value rrule)) + (frequency (cadr (assoc 'FREQ rrule-props))) + (until (cadr (assoc 'UNTIL rrule-props))) + (count (cadr (assoc 'COUNT rrule-props))) + (interval (read (or (cadr (assoc 'INTERVAL rrule-props)) "1"))) + (dtstart-conv (icalendar--datetime-to-diary-date dtstart-dec)) + (until-conv (icalendar--datetime-to-diary-date + (icalendar--decode-isodatetime until))) + (until-1-conv (icalendar--datetime-to-diary-date + (icalendar--decode-isodatetime until -1))) + (result "")) + + ;; FIXME FIXME interval!!!!!!!!!!!!! + + (when count + (if until + (message "Must not have UNTIL and COUNT -- ignoring COUNT element!") + (let ((until-1 0)) + (cond ((string-equal frequency "DAILY") + (setq until (icalendar--add-decoded-times + dtstart-dec + (list 0 0 0 (* (read count) interval) 0 0))) + (setq until-1 (icalendar--add-decoded-times + dtstart-dec + (list 0 0 0 (* (- (read count) 1) interval) + 0 0))) + ) + ((string-equal frequency "WEEKLY") + (setq until (icalendar--add-decoded-times + dtstart-dec + (list 0 0 0 (* (read count) 7 interval) 0 0))) + (setq until-1 (icalendar--add-decoded-times + dtstart-dec + (list 0 0 0 (* (- (read count) 1) 7 + interval) 0 0))) + ) + ((string-equal frequency "MONTHLY") + (setq until (icalendar--add-decoded-times + dtstart-dec (list 0 0 0 0 (* (- (read count) 1) + interval) 0))) + (setq until-1 (icalendar--add-decoded-times + dtstart-dec (list 0 0 0 0 (* (- (read count) 1) + interval) 0))) + ) + ((string-equal frequency "YEARLY") + (setq until (icalendar--add-decoded-times + dtstart-dec (list 0 0 0 0 0 (* (- (read count) 1) + interval)))) + (setq until-1 (icalendar--add-decoded-times + dtstart-dec + (list 0 0 0 0 0 (* (- (read count) 1) + interval)))) + ) + (t + (message "Cannot handle COUNT attribute for `%s' events." + frequency))) + (setq until-conv (icalendar--datetime-to-diary-date until)) + (setq until-1-conv (icalendar--datetime-to-diary-date until-1)) + )) + ) + (cond ((string-equal frequency "WEEKLY") + (if (not start-t) + (progn + ;; weekly and all-day + (icalendar--dmsg "weekly all-day") + (if until + (setq result + (format + (concat "%%%%(and " + "(diary-cyclic %d %s) " + "(diary-block %s %s))") + (* interval 7) + dtstart-conv + dtstart-conv + (if count until-1-conv until-conv) + )) + (setq result + (format "%%%%(and (diary-cyclic %d %s))" + (* interval 7) + dtstart-conv)))) + ;; weekly and not all-day + (let* ((byday (cadr (assoc 'BYDAY rrule-props))) + (weekday + (icalendar--get-weekday-number byday))) + (icalendar--dmsg "weekly not-all-day") + (if until + (setq result + (format + (concat "%%%%(and " + "(diary-cyclic %d %s) " + "(diary-block %s %s)) " + "%s%s%s") + (* interval 7) + dtstart-conv + dtstart-conv + until-conv + (or start-t "") + (if end-t "-" "") (or end-t ""))) + ;; no limit + ;; FIXME!!!! + ;; DTSTART;VALUE=DATE-TIME:20030919T090000 + ;; DTEND;VALUE=DATE-TIME:20030919T113000 + (setq result + (format + "%%%%(and (diary-cyclic %s %s)) %s%s%s" + (* interval 7) + dtstart-conv + (or start-t "") + (if end-t "-" "") (or end-t ""))))))) + ;; yearly + ((string-equal frequency "YEARLY") + (icalendar--dmsg "yearly") + (if until + (setq result (format + (concat "%%%%(and (diary-date %s %s t) " + "(diary-block %s %s)) %s%s%s") + (if european-calendar-style (nth 3 dtstart-dec) + (nth 4 dtstart-dec)) + (if european-calendar-style (nth 4 dtstart-dec) + (nth 3 dtstart-dec)) + dtstart-conv + until-conv + (or start-t "") + (if end-t "-" "") (or end-t ""))) + (setq result (format + "%%%%(and (diary-anniversary %s)) %s%s%s" + dtstart-conv + (or start-t "") + (if end-t "-" "") (or end-t ""))))) + ;; monthly + ((string-equal frequency "MONTHLY") + (icalendar--dmsg "monthly") + (setq result + (format + "%%%%(and (diary-date %s %s %s) (diary-block %s %s)) %s%s%s" + (if european-calendar-style (nth 3 dtstart-dec) "t") + (if european-calendar-style "t" (nth 3 dtstart-dec)) + "t" + dtstart-conv + (if until + until-conv + "1 1 9999") ;; FIXME: should be unlimited + (or start-t "") + (if end-t "-" "") (or end-t "")))) + ;; daily + ((and (string-equal frequency "DAILY")) + (if until + (setq result + (format + (concat "%%%%(and (diary-cyclic %s %s) " + "(diary-block %s %s)) %s%s%s") + interval dtstart-conv dtstart-conv + (if count until-1-conv until-conv) + (or start-t "") + (if end-t "-" "") (or end-t ""))) + (setq result + (format + "%%%%(and (diary-cyclic %s %s)) %s%s%s" + interval + dtstart-conv + (or start-t "") + (if end-t "-" "") (or end-t "")))))) + ;; Handle exceptions from recurrence rules + (let ((ex-dates (icalendar--get-event-properties e 'EXDATE))) + (while ex-dates + (let* ((ex-start (icalendar--decode-isodatetime + (car ex-dates))) + (ex-d (icalendar--datetime-to-diary-date + ex-start))) + (setq result + (icalendar--rris "^%%(\\(and \\)?" + (format + "%%%%(and (not (diary-date %s)) " + ex-d) + result))) + (setq ex-dates (cdr ex-dates)))) + ;; FIXME: exception rules are not recognized + (if (icalendar--get-event-property e 'EXRULE) + (setq result + (concat result + "\n Exception rules: " + (icalendar--get-event-properties + e 'EXRULE)))) + result)) + +(defun icalendar--convert-non-recurring-all-day-to-diary (event start-d end-d) + "Convert non-recurring icalendar EVENT to diary format. + +DTSTART is the decoded DTSTART property of E. +Argument START-D gives the first day. +Argument END-D gives the last day." + (icalendar--dmsg "non-recurring all-day event") + (format "%%%%(and (diary-block %s %s))" start-d end-d)) + +(defun icalendar--convert-non-recurring-not-all-day-to-diary (event dtstart-dec + dtend-dec + start-t + end-t) + "Convert recurring icalendar EVENT to diary format. + +DTSTART-DEC is the decoded DTSTART property of E. +DTEND-DEC is the decoded DTEND property of E. +START-T is the event's start time in diary format. +END-T is the event's end time in diary format." + (icalendar--dmsg "not all day event") + (cond (end-t + (format "%s %s-%s" + (icalendar--datetime-to-diary-date + dtstart-dec "/") + start-t end-t)) + (t + (format "%s %s" + (icalendar--datetime-to-diary-date + dtstart-dec "/") + start-t)))) + +(defun icalendar--add-diary-entry (string diary-file non-marking + &optional summary) + "Add STRING to the diary file DIARY-FILE. +STRING must be a properly formatted valid diary entry. NON-MARKING +determines whether diary events are created as non-marking. If +SUMMARY is not nil it must be a string that gives the summary of the +entry. In this case the user will be asked whether he wants to insert +the entry." + (when (or (not summary) + (y-or-n-p (format "Add appointment for `%s' to diary? " + summary))) + (when summary + (setq non-marking + (y-or-n-p (format "Make appointment non-marking? ")))) + (save-window-excursion + (unless diary-file + (setq diary-file + (read-file-name "Add appointment to this diary file: "))) + ;; Note: make-diary-entry will add a trailing blank char.... :( + (make-diary-entry string non-marking diary-file)))) + +(provide 'icalendar) + +;; arch-tag: 74fdbe8e-0451-4e38-bb61-4416e822f4fc +;;; icalendar.el ends here Index: lunar.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/lunar.el,v retrieving revision 1.6 diff -u -u -r1.6 lunar.el --- lunar.el 2006/08/20 03:39:41 1.6 +++ lunar.el 2006/10/20 21:46:46 ＠＠ -1,8 +1,10 ＠＠ ;;; lunar.el --- calendar functions for phases of the moon -;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: moon, lunar phases, calendar, diary ＠＠ -20,11 +22,11 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF-21.4 +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 + ;;; Commentary: ;; This collection of functions implements lunar phases for calendar.el and ＠＠ -40,8 +42,8 ＠＠ ;; person rewrite the code for the lunar calculations in this file! ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -51,6 +53,10 ＠＠ ;;; Code: +(defvar date) +(defvar displayed-month) +(defvar displayed-year) + (if (fboundp 'atan) (require 'lisp-float-type) (error "Lunar calculations impossible since floating point is unavailable")) ＠＠ -66,7 +72,7 ＠＠ (increment-calendar-month end-month end-year 3) (increment-calendar-month start-month start-year -1) (let* ((end-date (list (list end-month 1 end-year))) - (start-date (list (list start-month + (start-date (list (list start-month (calendar-last-day-of-month start-month start-year) start-year))) ＠＠ -239,9 +245,9 ＠＠ (calendar-phases-of-moon)))) (defun diary-phases-of-moon (&optional mark) - "Moon phases diary entry. +"Moon phases diary entry. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((index (* 4 (truncate ＠＠ -397,4 +403,5 ＠＠ (provide 'lunar) +;;; arch-tag: 72f0b8a4-7bcc-4a1b-b67a-ff53c4a1d222 ;;; lunar.el ends here Index: solar.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/solar.el,v retrieving revision 1.8 diff -u -u -r1.8 solar.el --- solar.el 2006/08/20 03:39:41 1.8 +++ solar.el 2006/10/20 21:46:46 ＠＠ -1,31 +1,33 ＠＠ ;;; solar.el --- calendar functions for solar events -;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold(a)cs.uiuc.edu&gt; -;; Denis B. Roegel <Denis.Roegel(a)loria.fr&gt; +;; Denis B. Roegel <Denis.Roegel(a)loria.fr&gt; +;; Maintainer: Glenn Morris <rgm(a)gnu.org&gt; ;; Keywords: calendar ;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, ;; holidays ;; This file is part of XEmacs. -;; XEmacs is free software; you can redistribute it and/or modify +;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; XEmacs is distributed in the hope that it will be useful, +;; XEmacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Synched up with: FSF 21.4 +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 ;;; Commentary: ＠＠ -50,8 +52,8 ＠＠ ;; 1951--2050. For other years the times will be within +/- 1 minute. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science ＠＠ -61,6 +63,10 ＠＠ ;;; Code: +(defvar date) +(defvar displayed-month) +(defvar displayed-year) + (if (fboundp 'atan) (require 'lisp-float-type) (error "Solar/lunar calculations impossible since floating point is unavailable")) ＠＠ -75,8 +81,8 ＠＠ "*The pseudo-pattern that governs the way a time of day is formatted. A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. +`12-hours', `24-hours', and `minutes', all numbers in string form, +and `am-pm' and `time-zone', both alphabetic strings. For example, the form ＠＠ -98,14 +104,14 ＠＠ This variable should be set in `site-start'.el." :type '(choice (const nil) - (number :tag "Exact") - (vector :value [0 0 north] - (integer :tag "Degrees") - (integer :tag "Minutes") - (choice :tag "Position" - (const north) - (const south)))) -:group 'calendar) + (number :tag "Exact") + (vector :value [0 0 north] + (integer :tag "Degrees") + (integer :tag "Minutes") + (choice :tag "Position" + (const north) + (const south)))) +:group 'calendar) ;;;###autoload (defcustom calendar-longitude nil ＠＠ -118,13 +124,13 ＠＠ This variable should be set in `site-start'.el." :type '(choice (const nil) - (number :tag "Exact") - (vector :value [0 0 west] - (integer :tag "Degrees") - (integer :tag "Minutes") - (choice :tag "Position" - (const east) - (const west)))) + (number :tag "Exact") + (vector :value [0 0 west] + (integer :tag "Degrees") + (integer :tag "Minutes") + (choice :tag "Position" + (const east) + (const west)))) :group 'calendar) (defsubst calendar-latitude () ＠＠ -196,9 +202,9 ＠＠ '("Autumnal Equinox" "Winter Solstice" "Vernal Equinox" "Summer Solstice") "List of season changes for the southern hemisphere.") -(defvar solar-sidereal-time-greenwich-midnight - nil - "Sidereal time at Greenwich at midnight (universal time).") +(defvar solar-sidereal-time-greenwich-midnight + nil + "Sidereal time at Greenwich at midnight (universal time).") (defvar solar-northern-spring-or-summer-season nil "Non-nil if northern spring or summer and nil otherwise. ＠＠ -225,7 +231,7 ＠＠ Returns nil if nothing was entered." (let ((x (read-string prompt ""))) (if (not (string-equal x "")) - (string-to-int x)))) + (string-to-number x)))) ;; The condition-case stuff is needed to catch bogus arithmetic ;; exceptions that occur on some machines (like Sparcs) ＠＠ -264,23 +270,23 ＠＠ "Arctan of point X, Y." (if (= x 0) (if (> y 0) 90 270) - (solar-arctan (/ y x) x))) + (solar-arctan (/ y x) (solar-xy-to-quadrant x y)))) (defun solar-arccos (x) "Arcos of X." - (let ((y (sqrt (- 1 (* x x))))) + (let ((y (sqrt (- 1 (* x x))))) (solar-atn2 x y))) (defun solar-arcsin (y) "Arcsin of Y." - (let ((x (sqrt (- 1 (* y y))))) + (let ((x (sqrt (- 1 (* y y))))) (solar-atn2 x y) )) (defsubst solar-degrees-to-hours (degrees) "Convert DEGREES to hours." (/ degrees 15.0)) - + (defsubst solar-hours-to-days (hour) "Convert HOUR to decimal fraction of a day." (/ hour 24.0)) ＠＠ -297,11 +303,11 ＠＠ "Declination of the sun, in degrees, given LONGITUDE and OBLIQUITY. Both arguments are in degrees." (solar-arcsin - (* (solar-sin-degrees obliquity) - (solar-sin-degrees longitude)))) + (* (solar-sin-degrees obliquity) + (solar-sin-degrees longitude)))) (defun solar-sunrise-and-sunset (time latitude longitude height) - "Sunrise, sunset and length of day. + "Sunrise, sunset and length of day. Parameters are the midday TIME and the LATITUDE, LONGITUDE of the location. TIME is a pair with the first component being the number of Julian centuries ＠＠ -325,8 +331,8 ＠＠ (and (< latitude 0) (not solar-northern-spring-or-summer-season))) (setq day-length 24) - (setq day-length 0)) - (setq day-length (- set-time rise-time))) + (setq day-length 0)) + (setq day-length (- set-time rise-time))) (list (if rise-time (+ rise-time (/ calendar-time-zone 60.0)) nil) (if set-time (+ set-time (/ calendar-time-zone 60.0)) nil) day-length))) ＠＠ -349,31 +355,31 ＠＠ Uses binary search." (let* ((ut (car (cdr time))) (possible t) ; we assume that rise or set are possible - (utmin (+ ut (* direction 12.0))) + (utmin (+ ut (* direction 12.0))) (utmax ut) ; the time searched is between utmin and utmax ; utmin and utmax are in hours (utmoment-old 0.0) ; rise or set approximation (utmoment 1.0) ; rise or set approximation (hut 0) ; sun height at utmoment (t0 (car time)) - (hmin (car (cdr - (solar-horizontal-coordinates (list t0 utmin) + (hmin (car (cdr + (solar-horizontal-coordinates (list t0 utmin) latitude longitude t)))) - (hmax (car (cdr - (solar-horizontal-coordinates (list t0 utmax) + (hmax (car (cdr + (solar-horizontal-coordinates (list t0 utmax) latitude longitude t))))) ; -0.61 degrees is the height of the middle of the sun, when it rises ; or sets. - (if (< hmin height) + (if (< hmin height) (if (> hmax height) (while ;(< i 20) ; we perform a simple dichotomy - ;(> (abs (- hut height)) epsilon) + ; (> (abs (- hut height)) epsilon) (>= (abs (- utmoment utmoment-old)) (/ solar-error 60)) (setq utmoment-old utmoment) (setq utmoment (/ (+ utmin utmax) 2)) - (setq hut (car (cdr - (solar-horizontal-coordinates + (setq hut (car (cdr + (solar-horizontal-coordinates (list t0 utmoment) latitude longitude t)))) (if (< hut height) (setq utmin utmoment)) (if (> hut height) (setq utmax utmoment)) ＠＠ -381,7 +387,7 ＠＠ (setq possible nil)) ; the sun never rises (setq possible nil)) ; the sun never sets (if (not possible) nil utmoment))) - + (defun solar-time-string (time time-zone) "Printable form for decimal fraction TIME in TIME-ZONE. Format used is given by `calendar-time-display-form'." ＠＠ -401,7 +407,7 ＠＠ (floor (* 60 (- time (floor time)))))) (defun solar-exact-local-noon (date) - "Date and Universal Time of local noon at *local date* date. + "Date and Universal Time of local noon at *local date* date. The date may be different from the one asked for, but it will be the right local date. The second component of date should be an integer." ＠＠ -410,12 +416,12 ＠＠ (te (solar-time-equation date ut))) (setq ut (- ut te)) (if (>= ut 24) - (progn + (progn (setq nd (list (car date) (+ 1 (car (cdr date))) (car (cdr (cdr date))))) (setq ut (- ut 24)))) (if (< ut 0) - (progn + (progn (setq nd (list (car date) (- (car (cdr date)) 1) (car (cdr (cdr date))))) (setq ut (+ ut 24)))) ＠＠ -435,9 +441,9 ＠＠ ; store the sidereal time at Greenwich at midnight of UT time. ; find if summer or winter slightly above the equator (equator-rise-set - (progn (setq solar-sidereal-time-greenwich-midnight + (progn (setq solar-sidereal-time-greenwich-midnight (solar-sidereal-time t0)) - (solar-sunrise-and-sunset + (solar-sunrise-and-sunset (list t0 (car (cdr exact-local-noon))) 1.0 (calendar-longitude) 0))) ＠＠ -449,7 +455,7 ＠＠ (progn (setq solar-northern-spring-or-summer-season (if (> (car (cdr (cdr equator-rise-set))) 12) t nil)) - (solar-sunrise-and-sunset + (solar-sunrise-and-sunset (list t0 (car (cdr exact-local-noon))) (calendar-latitude) (calendar-longitude) -0.61))) ＠＠ -470,19 +476,19 ＠＠ "%s, %s at %s (%s hours daylight)" (if (car l) (concat "Sunrise " (apply 'solar-time-string (car l))) - "No sunrise") + "No sunrise") (if (car (cdr l)) (concat "sunset " (apply 'solar-time-string (car (cdr l)))) - "no sunset") + "no sunset") (eval calendar-location-name) (car (cdr (cdr l)))))) (defun solar-julian-ut-centuries (date) "Number of Julian centuries elapsed since 1 Jan, 2000 at noon U.T. for Gregorian DATE." - (/ (- (calendar-absolute-from-gregorian date) + (/ (- (calendar-absolute-from-gregorian date) (calendar-absolute-from-gregorian '(1 1.5 2000))) 36525.0)) - + (defun solar-ephemeris-time(time) "Ephemeris Time at moment TIME. ＠＠ -536,7 +542,7 ＠＠ (setq end-long long))) (/ (+ start end) 2.0))) -(defun solar-horizontal-coordinates +(defun solar-horizontal-coordinates (time latitude longitude for-sunrise-sunset) "Azimuth and height of the sun at TIME, LATITUDE, and LONGITUDE. ＠＠ -559,7 +565,7 ＠＠ (* (solar-tangent-degrees de) (solar-cosine-degrees latitude))) (solar-sin-degrees ah))) - (height (solar-arcsin + (height (solar-arcsin (+ (* (solar-sin-degrees latitude) (solar-sin-degrees de)) (* (solar-cosine-degrees latitude) (solar-cosine-degrees de) ＠＠ -575,7 +581,7 ＠＠ time. For instance, the pair corresponding to November 28, 1995 at 16 UT is \(-0.040945 16), -0.040945 being the number of julian centuries elapsed between Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT." - (let* ((tm (solar-ephemeris-time time)) + (let* ((tm (solar-ephemeris-time time)) (ec (solar-ecliptic-coordinates tm for-sunrise-sunset))) (list (solar-right-ascension (car ec) (car (cdr ec))) (solar-declination (car ec) (car (cdr ec)))))) ＠＠ -587,16 +593,16 ＠＠ since January 1st, 2000, at 12 ET." (let* ((l (+ 280.46645 (* 36000.76983 time) - (* 0.0003032 time time))) ; sun mean longitude + (* 0.0003032 time time))) ; sun mean longitude (ml (+ 218.3165 - (* 481267.8813 time))) ; moon mean longitude + (* 481267.8813 time))) ; moon mean longitude (m (+ 357.52910 (* 35999.05030 time) (* -0.0001559 time time) - (* -0.00000048 time time time))) ; sun mean anomaly + (* -0.00000048 time time time))) ; sun mean anomaly (i (+ 23.43929111 (* -0.013004167 time) (* -0.00000016389 time time) - (* 0.0000005036 time time time))); mean inclination + (* 0.0000005036 time time time))); mean inclination (c (+ (* (+ 1.914600 (* -0.004817 time) (* -0.000014 time time)) ＠＠ -604,8 +610,8 ＠＠ (* (+ 0.019993 (* -0.000101 time)) (solar-sin-degrees (* 2 m))) (* 0.000290 - (solar-sin-degrees (* 3 m))))) ; center equation - (L (+ l c)) ; total longitude + (solar-sin-degrees (* 3 m))))) ; center equation + (L (+ l c)) ; total longitude (omega (+ 125.04 (* -1934.136 time))) ; longitude of moon's ascending node ; on the ecliptic ＠＠ -626,13 +632,13 ＠＠ (* -0.00478 (solar-sin-degrees omega)))) ; apparent longitude of sun (y (if (not for-sunrise-sunset) - (* (solar-tangent-degrees (/ i 2)) + (* (solar-tangent-degrees (/ i 2)) (solar-tangent-degrees (/ i 2))) nil)) (time-eq (if (not for-sunrise-sunset) (/ (* 12 (+ (* y (solar-sin-degrees (* 2 l))) (* -2 ecc (solar-sin-degrees m)) - (* 4 ecc y (solar-sin-degrees m) + (* 4 ecc y (solar-sin-degrees m) (solar-cosine-degrees (* 2 l))) (* -0.5 y y (solar-sin-degrees (* 4 l))) (* -1.25 ecc ecc (solar-sin-degrees (* 2 m))))) ＠＠ -641,48 +647,6 ＠＠ ; equation of time, in hours (list app i time-eq nut))) -(defun solar-longitude (d) - "Longitude of sun on astronomical (Julian) day number D. -Accurary is about 0.0006 degree (about 365.25*24*60*0.0006/360 = 1 minutes). - -The values of calendar-daylight-savings-starts, -calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, -calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and -calendar-time-zone are used to interpret local time." - (let* ((a-d (calendar-absolute-from-astro d)) - ;; get Universal Time - (date (calendar-astro-from-absolute - (- a-d - (if (dst-in-effect a-d) - (/ calendar-daylight-time-offset 24.0 60.0) 0) - (/ calendar-time-zone 60.0 24.0)))) - ;; get Ephemeris Time - (date (+ date (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (floor - (calendar-absolute-from-astro - date))))))) - (U (/ (- date 2451545) 3652500)) - (longitude - (+ 4.9353929 - (* 62833.1961680 U) - (* 0.0000001 - (apply '+ - (mapcar '(lambda (x) - (* (car x) - (sin (mod - (+ (car (cdr x)) - (* (car (cdr (cdr x))) U)) - (* 2 pi))))) - solar-data-list))))) - (aberration - (* 0.0000001 (- (* 17 (cos (+ 3.10 (* 62830.14 U)))) 973))) - (A1 (mod (+ 2.18 (* U (+ -3375.70 (* 0.36 U)))) (* 2 pi))) - (A2 (mod (+ 3.51 (* U (+ 125666.39 (* 0.10 U)))) (* 2 pi))) - (nutation (* -0.0000001 (+ (* 834 (sin A1)) (* 64 (sin A2)))))) - (mod (radians-to-degrees (+ longitude aberration nutation)) 360.0))) - (defconst solar-data-list '((403406 4.721964 1.621043) (195207 5.937458 62830.348067) ＠＠ -735,6 +699,48 ＠＠ (10 1.50 21463.25) (10 2.55 157208.40))) +(defun solar-longitude (d) + "Longitude of sun on astronomical (Julian) day number D. +Accurary is about 0.0006 degree (about 365.25*24*60*0.0006/360 = 1 minutes). + +The values of calendar-daylight-savings-starts, +calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, +calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and +calendar-time-zone are used to interpret local time." + (let* ((a-d (calendar-absolute-from-astro d)) + ;; get Universal Time + (date (calendar-astro-from-absolute + (- a-d + (if (dst-in-effect a-d) + (/ calendar-daylight-time-offset 24.0 60.0) 0) + (/ calendar-time-zone 60.0 24.0)))) + ;; get Ephemeris Time + (date (+ date (solar-ephemeris-correction + (extract-calendar-year + (calendar-gregorian-from-absolute + (floor + (calendar-absolute-from-astro + date))))))) + (U (/ (- date 2451545) 3652500)) + (longitude + (+ 4.9353929 + (* 62833.1961680 U) + (* 0.0000001 + (apply '+ + (mapcar '(lambda (x) + (* (car x) + (sin (mod + (+ (car (cdr x)) + (* (car (cdr (cdr x))) U)) + (* 2 pi))))) + solar-data-list))))) + (aberration + (* 0.0000001 (- (* 17 (cos (+ 3.10 (* 62830.14 U)))) 973))) + (A1 (mod (+ 2.18 (* U (+ -3375.70 (* 0.36 U)))) (* 2 pi))) + (A2 (mod (+ 3.51 (* U (+ 125666.39 (* 0.10 U)))) (* 2 pi))) + (nutation (* -0.0000001 (+ (* 834 (sin A1)) (* 64 (sin A2)))))) + (mod (radians-to-degrees (+ longitude aberration nutation)) 360.0))) + (defun solar-ephemeris-correction (year) "Ephemeris time minus Universal Time during Gregorian year. Result is in days. ＠＠ -809,7 +815,7 ＠＠ (nut-i (solar-ecliptic-coordinates et nil)) (nut (car (cdr (cdr (cdr nut-i))))) ; nutation (i (car (cdr nut-i)))) ; inclination - (mod (+ (mod (+ mean-sid-time + (mod (+ (mod (+ mean-sid-time (/ (/ (* nut (solar-cosine-degrees i)) 15) 3600)) 24.0) 24.0) 24.0))) ＠＠ -825,7 +831,7 ＠＠ Expressed in julian centuries of Ephemeris Time." (let ((t0 (solar-julian-ut-centuries date))) (solar-ephemeris-time (list t0 ut)))) - + ;;;###autoload (defun sunrise-sunset (&optional arg) "Local time of sunrise and sunset for today. Accurate to a few seconds. ＠＠ -897,7 +903,7 ＠＠ "Type \\[delete-other-windows] to remove temp window." "Type \\[switch-to-buffer] RET to remove temp window.") "Type \\[switch-to-buffer-other-window] RET to restore old contents of temp window.")))))) - + (defun calendar-sunrise-sunset () "Local time of sunrise and sunset for date under cursor. Accurate to a few seconds." ＠＠ -918,33 +924,60 ＠＠ (defcustom diary-sabbath-candles-minutes 18 "*Number of minutes before sunset for sabbath candle lighting." -:group 'diary -:type 'integer -:version "21.1") +:group 'diary +:type 'integer +:version "21.1") (defun diary-sabbath-candles (&optional mark) "Local time of candle lighting diary entry--applies if date is a Friday. No diary entry if there is no sunset on that date. -An optional parameter MARK specifies a face or single-character string to +An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) (solar-setup)) (if (= (% (calendar-absolute-from-gregorian date) 7) 5);; Friday (let* ((sunset (car (cdr (solar-sunrise-sunset date)))) - (light (if sunset - (cons (- (car sunset) - (/ diary-sabbath-candles-minutes 60.0)) - (cdr sunset))))) + (light (if sunset + (cons (- (car sunset) + (/ diary-sabbath-candles-minutes 60.0)) + (cdr sunset))))) (if sunset - (cons mark + (cons mark (format "%s Sabbath candle lighting" - (apply 'solar-time-string light))))))) - + (apply 'solar-time-string light))))))) + +; from Meeus, 1991, page 167 +(defconst solar-seasons-data + '((485 324.96 1934.136) + (203 337.23 32964.467) + (199 342.08 20.186) + (182 27.85 445267.112) + (156 73.14 45036.886) + (136 171.52 22518.443) + (77 222.54 65928.934) + (74 296.72 3034.906) + (70 243.58 9037.513) + (58 119.81 33718.147) + (52 297.17 150.678) + (50 21.02 2281.226) + (45 247.54 29929.562) + (44 325.15 31555.956) + (29 60.93 4443.417) + (18 155.12 67555.328) + (17 288.79 4562.452) + (16 198.04 62894.029) + (14 199.76 31436.921) + (12 95.39 14577.848) + (12 287.11 31931.756) + (12 320.81 34777.259) + (9 227.73 1222.114) + (8 15.45 16859.074))) + (defun solar-equinoxes/solstices (k year) "Date of equinox/solstice K for YEAR. K=0, spring equinox; K=1, summer solstice; K=2, fall equinox; -K=3, winter solstice. +K=3, winter solstice. RESULT is a gregorian local date. Accurate to less than a minute between 1951 and 2050." ＠＠ -953,13 +986,13 ＠＠ (W (- (* 35999.373 T) 2.47)) (Delta-lambda (+ 1 (* 0.0334 (solar-cosine-degrees W)) (* 0.0007 (solar-cosine-degrees (* 2 W))))) - (S (apply '+ (mapcar '(lambda(x) - (* (car x) (solar-cosine-degrees + (S (apply '+ (mapcar '(lambda(x) + (* (car x) (solar-cosine-degrees (+ (* (car (cdr (cdr x))) T) - (car (cdr x)))))) + (car (cdr x)))))) solar-seasons-data))) (JDE (+ JDE0 (/ (* 0.00001 S) Delta-lambda))) - (correction (+ 102.3 (* 123.5 T) (* 32.5 T T))) + (correction (+ 102.3 (* 123.5 T) (* 32.5 T T))) ; ephemeris time correction (JD (- JDE (/ correction 86400))) (date (calendar-gregorian-from-absolute (floor (- JD 1721424.5)))) ＠＠ -971,7 +1004,7 ＠＠ ; from Meeus, 1991, page 166 (defun solar-mean-equinoxes/solstices (k year) - "Julian day of mean equinox/solstice K for YEAR. + "Julian day of mean equinox/solstice K for YEAR. K=0, spring equinox; K=1, summer solstice; K=2, fall equinox; K=3, winter solstice. These formulas are only to be used between 1000 BC and 3000 AD." (let ((y (/ year 1000.0)) ＠＠ -1019,33 +1052,6 ＠＠ (* -0.00823 z z z) (* 0.00032 z z z z))))))) -; from Meeus, 1991, page 167 -(defconst solar-seasons-data - '((485 324.96 1934.136) - (203 337.23 32964.467) - (199 342.08 20.186) - (182 27.85 445267.112) - (156 73.14 45036.886) - (136 171.52 22518.443) - (77 222.54 65928.934) - (74 296.72 3034.906) - (70 243.58 9037.513) - (58 119.81 33718.147) - (52 297.17 150.678) - (50 21.02 2281.226) - (45 247.54 29929.562) - (44 325.15 31555.956) - (29 60.93 4443.417) - (18 155.12 67555.328) - (17 288.79 4562.452) - (16 198.04 62894.029) - (14 199.76 31436.921) - (12 95.39 14577.848) - (12 287.11 31931.756) - (12 320.81 34777.259) - (9 227.73 1222.114) - (8 15.45 16859.074))) - ;;;###autoload (defun solar-equinoxes-solstices () "*local* date and time of equinoxes and solstices, if visible in the calendar window. ＠＠ -1063,16 +1069,16 ＠＠ (if calendar-time-zone calendar-daylight-savings-ends)) (calendar-time-zone (if calendar-time-zone calendar-time-zone 0)) (k (1- (/ m 3))) - (d0 (solar-equinoxes/solstices k y)) + (d0 (solar-equinoxes/solstices k y)) (d1 (list (car d0) (floor (car (cdr d0))) (car (cdr (cdr d0))))) (h0 (* 24 (- (car (cdr d0)) (floor (car (cdr d0)))))) (adj (dst-adjust-time d1 h0)) - (d (list (car (car adj)) - (+ (car (cdr (car adj))) - (/ (car (cdr adj)) 24.0)) + (d (list (car (car adj)) + (+ (car (cdr (car adj)) ) + (/ (car (cdr adj)) 24.0)) (car (cdr (cdr (car adj)))))) ; The following is nearly as accurate, but not quite: - ;(d0 (solar-date-next-longitude + ;(d0 (solar-date-next-longitude ; (calendar-astro-from-absolute ; (calendar-absolute-from-gregorian ; (list (+ 3 (* k 3)) 15 y))) ＠＠ -1080,19 +1086,20 ＠＠ ;(abs-day (calendar-absolute-from-astro d))) (abs-day (calendar-absolute-from-gregorian d))) (list - (list (calendar-gregorian-from-absolute (floor abs-day)) - (format "%s %s" + (list (calendar-gregorian-from-absolute (floor abs-day)) + (format "%s %s" (nth k (if (and calendar-latitude (< (calendar-latitude) 0)) solar-s-hemi-seasons - solar-n-hemi-seasons)) + solar-n-hemi-seasons)) (solar-time-string - (* 24 (- abs-day (floor abs-day))) - (if (dst-in-effect abs-day) + (* 24 (- abs-day (floor abs-day))) + (if (dst-in-effect abs-day) calendar-daylight-time-zone-name calendar-standard-time-zone-name)))))))) (provide 'solar) +;;; arch-tag: bc0ff693-df58-4666-bde4-2a7837ccb8fe ;;; solar.el ends here Index: timeclock.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/timeclock.el,v retrieving revision 1.3 diff -u -u -r1.3 timeclock.el --- timeclock.el 2006/08/20 03:39:41 1.3 +++ timeclock.el 2006/10/20 21:46:47 ＠＠ -1,6 +1,7 ＠＠ ;;; timeclock.el --- mode for keeping track of how much you work -;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: John Wiegley <johnw(a)gnu.org&gt; ;; Created: 25 Mar 1999 ＠＠ -21,9 +22,11 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 + ;;; Commentary: ;; This mode is for keeping track of time intervals. You can use it ＠＠ -33,11 +36,11 ＠＠ ;; Use `timeclock-in' when you start on a project, and `timeclock-out' ;; when you're done. Once you've collected some data, you can use ;; `timeclock-workday-remaining' to see how much time is left to be -;; worked today (assuming a typical average of 8 hours a day), and -;; `timeclock-when-to-leave' which will calculate when you're free. +;; worked today (where `timeclock-workday' specifies the length of the +;; working day), and `timeclock-when-to-leave' to calculate when you're free. ;; You'll probably want to bind the timeclock commands to some handy -;; keystrokes. At the moment, C-x t is unused in Emacs 20: +;; keystrokes. At the moment, C-x t is unused: ;; ;; (require 'timeclock) ;; ＠＠ -60,11 +63,11 ＠＠ ;; `timeclock-modeline-display' again. ;; You may also want XEmacs to ask you before exiting, if you are -;; current working on a project. This can be done either by setting +;; currently working on a project. This can be done either by setting ;; `timeclock-ask-before-exiting' to t using M-x customize (this is ;; the default), or by adding the following to your .emacs file: ;; -;; (add-hook 'kill-emacs-hook 'timeclock-query-out) +;; (add-hook 'kill-emacs-query-functions 'timeclock-query-out) ;; NOTE: If you change your .timelog file without using timeclock's ;; functions, or if you change the value of any of timeclock's ＠＠ -77,12 +80,13 ＠＠ ;;; Code: +;; XEmacs change (if (featurep 'xemacs) (defalias 'timeclock-cancel-timer 'delete-itimer) (defalias 'timeclock-cancel-timer 'cancel-timer)) (defgroup timeclock nil - "Keeping track time of the time that gets spent." + "Keeping track of the time that gets spent." :group 'data) ;;; User Variables: ＠＠ -98,20 +102,20 ＠＠ :group 'timeclock) (defcustom timeclock-relative t - "*When reporting time, make it relative to `timeclock-workday'? + "*Whether to make reported time relative to `timeclock-workday'. For example, if the length of a normal workday is eight hours, and you work four hours on Monday, then the amount of time \"remaining\" on Tuesday is twelve hours -- relative to an averaged work period of eight hours -- or eight hours, non-relative. So relative time takes -into account any discrepancy of time under-worked or overworked on -previous days." +into account any discrepancy of time under-worked or over-worked on +previous days. This only affects the timeclock modeline display." :type 'boolean :group 'timeclock) (defcustom timeclock-get-project-function 'timeclock-ask-for-project "*The function used to determine the name of the current project. When clocking in, and no project is specified, this function will be -called to determine what the current project to be worked on is. +called to determine what is the current project to be worked on. If this variable is nil, no questions will be asked." :type 'function :group 'timeclock) ＠＠ -119,7 +123,7 ＠＠ (defcustom timeclock-get-reason-function 'timeclock-ask-for-reason "*A function used to determine the reason for clocking out. When clocking out, and no reason is specified, this function will be -called to determine what the reason is. +called to determine what is the reason. If this variable is nil, no questions will be asked." :type 'function :group 'timeclock) ＠＠ -127,20 +131,21 ＠＠ (defcustom timeclock-get-workday-function nil "*A function used to determine the length of today's workday. The first time that a user clocks in each day, this function will be -called to determine what the length of the current workday is. If +called to determine what is the length of the current workday. If the return value is nil, or equal to `timeclock-workday', nothing special -will be done. If it is a quantity different from `timeclock-workday', +will be done. If it is a quantity different from `timeclock-workday', however, a record will be output to the timelog file to note the fact that -that day has a different length from the norm." +that day has a length that is different from the norm." :type '(choice (const nil) function) :group 'timeclock) (defcustom timeclock-ask-before-exiting t - "*If non-nil, ask if the user wants to clock out before exiting Emacs." + "*If non-nil, ask if the user wants to clock out before exiting Emacs. +This variable only has effect if set with \\[customize]." :set (lambda (symbol value) (if value - (add-hook 'kill-emacs-hook 'timeclock-query-out) - (remove-hook 'kill-emacs-hook 'timeclock-query-out)) + (add-hook 'kill-emacs-query-functions 'timeclock-query-out) + (remove-hook 'kill-emacs-query-functions 'timeclock-query-out)) (setq timeclock-ask-before-exiting value)) :type 'boolean :group 'timeclock) ＠＠ -148,15 +153,20 ＠＠ (defvar timeclock-update-timer nil "The timer used to update `timeclock-mode-string'.") +;; For byte-compiler. +(defvar display-time-hook) +(defvar timeclock-modeline-display) + (defcustom timeclock-use-display-time t "*If non-nil, use `display-time-hook' for doing modeline updates. -The advantage to this is that it means one less timer has to be set -running amok in Emacs' process space. The disadvantage is that it -requires you to have `display-time' running. If you don't want to use +The advantage of this is that one less timer has to be set running +amok in Emacs' process space. The disadvantage is that it requires +you to have `display-time' running. If you don't want to use `display-time', but still want the modeline to show how much time is -left, set this variable to nil. You will need to restart Emacs (or -toggle the value of `timeclock-modeline-display') for the change to -take effect." +left, set this variable to nil. Changing the value of this variable +while timeclock information is being displayed in the modeline has no +effect. You should call the function `timeclock-modeline-display' with +a positive argument to force an update." :set (lambda (symbol value) (let ((currently-displaying (and (boundp 'timeclock-modeline-display) ＠＠ -204,7 +214,7 ＠＠ (defcustom timeclock-day-over-hook nil "*A hook that is run when the workday has been completed. -This hook is only run if the current time remaining is being display +This hook is only run if the current time remaining is being displayed in the modeline. See the variable `timeclock-modeline-display'." :type 'hook :group 'timeclock) ＠＠ -238,7 +248,7 ＠＠ Normally, timeclock assumes that you intend to work for `timeclock-workday' seconds every day. Any days in which you work more or less than this amount is considered either a positive or -negative discrepancy. If you work in such a manner that the +a negative discrepancy. If you work in such a manner that the discrepancy is always brought back to zero, then you will by definition have worked an average amount equal to `timeclock-workday' each day.") ＠＠ -250,13 +260,17 ＠＠ worked so far today. Also, if `timeclock-relative' is nil, this value will be the same as `timeclock-discrepancy'.") +(defvar timeclock-use-elapsed nil + "Non-nil if the modeline should display time elapsed, not remaining.") + (defvar timeclock-last-period nil "Integer representing the number of seconds in the last period. -Note that you shouldn't access this value, but should use the function -`timeclock-last-period' instead.") +Note that you shouldn't access this value, but instead should use the +function `timeclock-last-period'.") (defvar timeclock-mode-string nil - "The timeclock string (optionally) displayed in the modeline.") + "The timeclock string (optionally) displayed in the modeline. +The time is bracketed by <> if you are clocked in, otherwise by [].") (defvar timeclock-day-over nil "The date of the last day when notified \"day over\" for.") ＠＠ -266,46 +280,60 ＠＠ ;;;###autoload (defun timeclock-modeline-display (&optional arg) "Toggle display of the amount of time left today in the modeline. -If `timeclock-use-display-time' is non-nil, the modeline will be -updated whenever the time display is updated. Otherwise, the -timeclock will use its own sixty second timer to do its updating. -With prefix ARG, turn modeline display on if and only if ARG is -positive. Returns the new status of timeclock modeline display -\(non-nil means on)." +If `timeclock-use-display-time' is non-nil (the default), then +the function `display-time-mode' must be active, and the modeline +will be updated whenever the time display is updated. Otherwise, +the timeclock will use its own sixty second timer to do its +updating. With prefix ARG, turn modeline display on if and only +if ARG is positive. Returns the new status of timeclock modeline +display (non-nil means on)." (interactive "P") + ;; cf display-time-mode. + (setq timeclock-mode-string "") + (or global-mode-string (setq global-mode-string '(""))) (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not timeclock-modeline-display)))) (if on-p - (let ((list-entry (or (memq 'global-mode-string mode-line-format) - ;; In Emacs 21.3 we must use assq - (assq 'global-mode-string mode-line-format)))) - (unless (or (null list-entry) - (memq 'timeclock-mode-string mode-line-format)) - (setcdr list-entry (cons 'timeclock-mode-string - (cdr list-entry)))) + (progn + (or (memq 'timeclock-mode-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(timeclock-mode-string)))) (unless (memq 'timeclock-update-modeline timeclock-event-hook) (add-hook 'timeclock-event-hook 'timeclock-update-modeline)) (when timeclock-update-timer + ;; XEmacs change, we don't have cancel-timer (timeclock-cancel-timer timeclock-update-timer) (setq timeclock-update-timer nil)) (if (boundp 'display-time-hook) (remove-hook 'display-time-hook 'timeclock-update-modeline)) (if timeclock-use-display-time - (add-hook 'display-time-hook 'timeclock-update-modeline) + (progn + ;; Update immediately so there is a visible change + ;; on calling this function. + ;; (if display-time-mode (timeclock-update-modeline)) + ;; XEmacs change, our display-time doesn't have display-time-mode + ;; So, we'll check display-time-string and see if it's nil + (if (and (boundp 'display-time-string) + display-time-string) + (timeclock-update-modeline) + (message "Activate `display-time-mode' to see \ +timeclock information")) + (add-hook 'display-time-hook 'timeclock-update-modeline)) (setq timeclock-update-timer (run-at-time nil 60 'timeclock-update-modeline)))) - (setq mode-line-format - (delq 'timeclock-mode-string mode-line-format)) + (setq global-mode-string + (delq 'timeclock-mode-string global-mode-string)) (remove-hook 'timeclock-event-hook 'timeclock-update-modeline) (if (boundp 'display-time-hook) (remove-hook 'display-time-hook 'timeclock-update-modeline)) (when timeclock-update-timer + ;; XEmacs change, we don't have cancel-timer (timeclock-cancel-timer timeclock-update-timer) (setq timeclock-update-timer nil))) (force-mode-line-update) - on-p)) + (setq timeclock-modeline-display on-p))) ;; This has to be here so that the function definition of ;; `timeclock-modeline-display' is known to the "set" function. ＠＠ -319,6 +347,10 ＠＠ :group 'timeclock :require 'timeclock) +(defsubst timeclock-time-to-date (time) + "Convert the TIME value to a textual date string." + (format-time-string "%Y/%m/%d" time)) + ;;;###autoload (defun timeclock-in (&optional arg project find-project) "Clock in, recording the current time moment in the timelog. ＠＠ -329,7 +361,7 ＠＠ _seconds_ worked today*. This feature only has effect the first time this function is called within a day. -PROJECT as the project being clocked into. If PROJECT is nil, and +PROJECT is the project being clocked into. If PROJECT is nil, and FIND-PROJECT is non-nil -- or the user calls `timeclock-in' interactively -- call the function `timeclock-get-project-function' to discover the name of the project." ＠＠ -345,8 +377,8 ＠＠ ;; Either no log file, or day has rolled over. (unless (and timeclock-last-event (equal (timeclock-time-to-date - (cadr timeclock-last-event)) - (timeclock-time-to-date (current-time)))) + (cadr timeclock-last-event)) + (timeclock-time-to-date (current-time)))) (let ((workday (or (and (numberp arg) arg) (and arg 0) (and timeclock-get-workday-function ＠＠ -390,13 +422,30 ＠＠ (if arg (run-hooks 'timeclock-done-hook)))) +;; Should today-only be removed in favour of timeclock-relative? - gm +(defsubst timeclock-workday-remaining (&optional today-only) + "Return the number of seconds until the workday is complete. +The amount returned is relative to the value of `timeclock-workday'. +If TODAY-ONLY is non-nil, the value returned will be relative only to +the time worked today, and not to past time." + (let ((discrep (timeclock-find-discrep))) + (if discrep + (- (if today-only (cadr discrep) + (car discrep))) + 0.0))) + ;;;###autoload (defun timeclock-status-string (&optional show-seconds today-only) - "Report the overall timeclock status at the present moment." + "Report the overall timeclock status at the present moment. +If SHOW-SECONDS is non-nil, display second resolution. +If TODAY-ONLY is non-nil, the display will be relative only to time +worked today, ignoring the time worked on previous days." (interactive "P") - (let* ((remainder (timeclock-workday-remaining)) - (last-in (equal (car timeclock-last-event) "i")) - status) + (let ((remainder (timeclock-workday-remaining + (or today-only + (not timeclock-relative)))) + (last-in (equal (car timeclock-last-event) "i")) + status) (setq status (format "Currently %s since %s (%s), %s %s, leave at %s" (if last-in "IN" "OUT") ＠＠ -412,26 +461,29 ＠＠ "remaining" "over") (timeclock-when-to-leave-string show-seconds today-only))) (if (interactive-p) - (message status) + (message "%s" status) status))) ;;;###autoload (defun timeclock-change (&optional arg project) - "Change to working on a different project, by clocking in then out. -With a prefix ARG, consider the previous project as having been -finished at the time of changeover. PROJECT is the name of the last -project you were working on." + "Change to working on a different project. +This clocks out of the current project, then clocks in on a new one. +With a prefix ARG, consider the previous project as finished at the +time of changeover. PROJECT is the name of the last project you were +working on." (interactive "P") (timeclock-out arg) (timeclock-in nil project (interactive-p))) ;;;###autoload (defun timeclock-query-out () - "Ask the user before clocking out. -This is a useful function for adding to `kill-emacs-hook'." - (if (and (equal (car timeclock-last-event) "i") - (y-or-n-p "You're currently clocking time, clock out? ")) - (timeclock-out))) + "Ask the user whether to clock out. +This is a useful function for adding to `kill-emacs-query-functions'." + (and (equal (car timeclock-last-event) "i") + (y-or-n-p "You're currently clocking time, clock out? ") + (timeclock-out)) + ;; Unconditionally return t for `kill-emacs-query-functions'. + t) ;;;###autoload (defun timeclock-reread-log () ＠＠ -463,19 +515,6 ＠＠ (truncate (/ (abs seconds) 60 60)) (% (truncate (/ (abs seconds) 60)) 60)))) -(defsubst timeclock-workday-remaining (&optional today-only) - "Return the number of seconds until the workday is complete. -The amount returned is relative to the value of `timeclock-workday'. -If TODAY-ONLY is non-nil, the value returned will be relative only to -the time worked today, and not to past time. This argument only makes -a difference if `timeclock-relative' is non-nil." - (let ((discrep (timeclock-find-discrep))) - (if discrep - (if today-only - (- (cadr discrep)) - (- (car discrep))) - 0.0))) - (defsubst timeclock-currently-in-p () "Return non-nil if the user is currently clocked in." (equal (car timeclock-last-event) "i")) ＠＠ -493,7 +532,7 ＠＠ (timeclock-workday-remaining today-only) show-seconds t))) (if (interactive-p) - (message string) + (message "%s" string) string))) (defsubst timeclock-workday-elapsed () ＠＠ -515,14 +554,26 ＠＠ (let ((string (timeclock-seconds-to-string (timeclock-workday-elapsed) show-seconds))) (if (interactive-p) - (message string) + (message "%s" string) string))) +(defsubst timeclock-time-to-seconds (time) + "Convert TIME to a floating point number." + (+ (* (car time) 65536.0) + (cadr time) + (/ (or (car (cdr (cdr time))) 0) 1000000.0))) + +(defsubst timeclock-seconds-to-time (seconds) + "Convert SECONDS (a floating point number) to an Emacs time structure." + (list (floor seconds 65536) + (floor (mod seconds 65536)) + (floor (* (- seconds (ffloor seconds)) 1000000)))) + +;; Should today-only be removed in favour of timeclock-relative? - gm (defsubst timeclock-when-to-leave (&optional today-only) - "Return a time value representing at when the workday ends today. + "Return a time value representing the end of today's workday. If TODAY-ONLY is non-nil, the value returned will be relative only to -the time worked today, and not to past time. This argument only makes -a difference if `timeclock-relative' is non-nil." +the time worked today, and not to past time." (timeclock-seconds-to-time (- (timeclock-time-to-seconds (current-time)) (let ((discrep (timeclock-find-discrep))) ＠＠ -535,14 +586,12 ＠＠ ;;;###autoload (defun timeclock-when-to-leave-string (&optional show-seconds today-only) - "Return a string representing at what time the workday ends today. + "Return a string representing the end of today's workday. This string is relative to the value of `timeclock-workday'. If -NO-MESSAGE is non-nil, no messages will be displayed in the -minibuffer. If SHOW-SECONDS is non-nil, the value printed/returned -will include seconds. If TODAY-ONLY is non-nil, the value returned -will be relative only to the time worked today, and not to past time. -This argument only makes a difference if `timeclock-relative' is -non-nil." +SHOW-SECONDS is non-nil, the value printed/returned will include +seconds. If TODAY-ONLY is non-nil, the value returned will be +relative only to the time worked today, and not to past time." + ;; Should today-only be removed in favour of timeclock-relative? - gm (interactive) (let* ((then (timeclock-when-to-leave today-only)) (string ＠＠ -550,7 +599,7 ＠＠ (format-time-string "%-I:%M:%S %p" then) (format-time-string "%-I:%M %p" then)))) (if (interactive-p) - (message string) + (message "%s" string) string))) ;;; Internal Functions: ＠＠ -570,7 +619,7 ＠＠ (defun timeclock-ask-for-project () "Ask the user for the project they are clocking into." (timeclock-completing-read - (format "Clock into which project (default \"%s\"): " + (format "Clock into which project (default %s): " (or timeclock-last-project (car timeclock-project-list))) (mapcar 'list timeclock-project-list) ＠＠ -585,10 +634,15 ＠＠ (mapcar 'list timeclock-reason-list))) (defun timeclock-update-modeline () - "Update the `timeclock-mode-string' displayed in the modeline." + "Update the `timeclock-mode-string' displayed in the modeline. +The value of `timeclock-relative' affects the display as described in +that variable's documentation." (interactive) - (let* ((remainder (timeclock-workday-remaining)) - (last-in (equal (car timeclock-last-event) "i"))) + (let ((remainder + (if timeclock-use-elapsed + (timeclock-workday-elapsed) + (timeclock-workday-remaining (not timeclock-relative)))) + (last-in (equal (car timeclock-last-event) "i"))) (when (and (< remainder 0) (not (and timeclock-day-over (equal timeclock-day-over ＠＠ -598,10 +652,14 ＠＠ (timeclock-time-to-date (current-time))) (run-hooks 'timeclock-day-over-hook)) (setq timeclock-mode-string - (format " %c%s%c" - (if last-in ?< ?[) - (timeclock-seconds-to-string remainder nil t) - (if last-in ?> ?]))))) + (propertize + (format " %c%s%c " + (if last-in ?< ?[) + (timeclock-seconds-to-string remainder nil t) + (if last-in ?> ?])) + 'help-echo "timeclock: time remaining")))) + +(put 'timeclock-mode-string 'risky-local-variable t) (defun timeclock-log (code &optional project) "Log the event CODE to the timeclock log, at the time of call. ＠＠ -651,22 +709,6 ＠＠ (project (match-string 8))) (list code (encode-time sec min hour mday mon year) project)))) -(defsubst timeclock-time-to-seconds (time) - "Convert TIME to a floating point number." - (+ (* (car time) 65536.0) - (cadr time) - (/ (or (car (cdr (cdr time))) 0) 1000000.0))) - -(defsubst timeclock-seconds-to-time (seconds) - "Convert SECONDS (a floating point number) to an Emacs time structure." - (list (floor seconds 65536) - (floor (mod seconds 65536)) - (floor (* (- seconds (ffloor seconds)) 1000000)))) - -(defsubst timeclock-time-to-date (time) - "Convert the TIME value to a textual date string." - (format-time-string "%Y/%m/%d" time)) - (defun timeclock-last-period (&optional moment) "Return the value of the last event period. If the last event was a clock-in, the period will be open ended, and ＠＠ -815,6 +857,11 ＠＠ (defun timeclock-log-data (&optional recent-only filename) "Return the contents of the timelog file, in a useful format. +If the optional argument RECENT-ONLY is non-nil, only show the contents +from the last point where the time debt (see below) was set. +If the optional argument FILENAME is non-nil, it is used instead of +the file specified by `timeclock-file.' + A timelog contains data in the form of a single entry per line. Each entry has the form: ＠＠ -829,8 +876,8 ＠＠ h Set the required working time for the given day. This must be the first entry for that day. The COMMENT in this case is - the number of hours that must be worked. Floating point - amounts are allowed. + the number of hours in this workday. Floating point amounts + are allowed. i Clock in. The COMMENT in this case should be the name of the project worked on. ＠＠ -1009,7 +1056,9 ＠＠ log-data))) (defun timeclock-find-discrep () - "Find overall discrepancy from `timeclock-workday' (in seconds)." + "Calculate time discrepancies, in seconds. +The result is a three element list, containing the total time +discrepancy, today's discrepancy, and the time worked today." ;; This is not implemented in terms of the functions above, because ;; it's a bit wasteful to read all of that data in, just to throw ;; away more than 90% of the information afterwards. ＠＠ -1025,7 +1074,8 ＠＠ ;; total) (let* ((now (current-time)) (todays-date (timeclock-time-to-date now)) - (first t) (accum 0) (elapsed 0) + ;; XEmacs change + (first t) (accum 0) (elapsed 0) (line 0) event beg last-date avg last-date-limited last-date-seconds) (unless timeclock-discrepancy ＠＠ -1040,6 +1090,8 ＠＠ (unless (re-search-backward "^b\\s-+" nil t) (goto-char (point-min))) (while (setq event (timeclock-read-moment)) + ;; XEmacs change + (setq line (1+ line)) (cond ((equal (car event) "b") (setq accum (string-to-number (nth 2 event)))) ((equal (car event) "h") ＠＠ -1063,14 +1115,16 ＠＠ (setq last-date date last-date-limited nil) (if beg - (error "Error in format of timelog file!") + ;; XEmacs change + (error "Error in format of timelog file, line %d" line) (setq beg (timeclock-time-to-seconds (cadr event)))))) ((equal (downcase (car event)) "o") (if (and (nth 2 event) (> (length (nth 2 event)) 0)) (add-to-list 'timeclock-reason-list (nth 2 event))) (if (not beg) - (error "Error in format of timelog file!") + ;; XEmacs change + (error "Error in format of timelog file, line %d" line) (setq timeclock-last-period (- (timeclock-time-to-seconds (cadr event)) beg) accum (+ timeclock-last-period accum) ＠＠ -1087,7 +1141,7 ＠＠ (setq timeclock-discrepancy accum)))) (unless timeclock-last-event-workday (setq timeclock-last-event-workday timeclock-workday)) - (setq accum timeclock-discrepancy + (setq accum (or timeclock-discrepancy 0) elapsed (or timeclock-elapsed elapsed)) (if timeclock-last-event (if (equal (car timeclock-last-event) "i") ＠＠ -1103,14 +1157,9 ＠＠ ;;; A reporting function that uses timeclock-log-data -(defun timeclock-time-less-p (t1 t2) - "Say whether time T1 is less than time T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - (defun timeclock-day-base (&optional time) - "Given a time within a day, return 0:0:0 within that day." + "Given a time within a day, return 0:0:0 within that day. +If optional argument TIME is non-nil, use that instead of the current time." (let ((decoded (decode-time (or time (current-time))))) (setcar (nthcdr 0 decoded) 0) (setcar (nthcdr 1 decoded) 0) ＠＠ -1118,7 +1167,7 ＠＠ (apply 'encode-time decoded))) (defun timeclock-geometric-mean (l) - "Compute the geometric mean of the list L." + "Compute the geometric mean of the values in the list L." (let ((total 0) (count 0)) (while l ＠＠ -1130,7 +1179,9 ＠＠ 0))) (defun timeclock-generate-report (&optional html-p) - "Generate a summary report based on the current timelog file." + "Generate a summary report based on the current timelog file. +By default, the report is in plain text, but if the optional argument +HTML-P is non-nil, HTML markup is added." (interactive) (let ((log (timeclock-log-data)) (today (timeclock-day-base))) ＠＠ -1161,12 +1212,12 ＠＠ (* 2 7 24 60 60)))) two-week-len today-len) (while proj-data - (if (not (timeclock-time-less-p + (if (not (time-less-p (timeclock-entry-begin (car proj-data)) today)) (setq today-len (timeclock-entry-list-length proj-data) proj-data nil) (if (and (null two-week-len) - (not (timeclock-time-less-p + (not (time-less-p (timeclock-entry-begin (car proj-data)) two-weeks-ago))) (setq two-week-len (timeclock-entry-list-length proj-data))) ＠＠ -1231,7 +1282,7 ＠＠ (while day-list (let ((i 0) (l 5)) (while (< i l) - (unless (timeclock-time-less-p + (unless (time-less-p (timeclock-day-begin (car day-list)) (aref lengths i)) (let ((base (timeclock-time-to-seconds ＠＠ -1322,7 +1373,7 ＠＠ ;;; A helpful little function (defun timeclock-visit-timelog () - "Open up the .timelog file in another window." + "Open the file named by `timeclock-file' in another window." (interactive) (find-file-other-window timeclock-file)) ＠＠ -1335,4 +1386,5 ＠＠ (if (file-readable-p timeclock-file) (timeclock-reread-log)) +;;; arch-tag: a0be3377-deb6-44ec-b9a2-a7be28436a40 ;;; timeclock.el ends here Index: todo-mode.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/calendar/todo-mode.el,v retrieving revision 1.1 diff -u -u -r1.1 todo-mode.el --- todo-mode.el 2006/07/31 02:15:24 1.1 +++ todo-mode.el 2006/10/20 21:46:47 ＠＠ -1,29 +1,29 ＠＠ ;;; todo-mode.el --- major mode for editing TODO list files -;; Copyright (C) 1997, 1999, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006 +;; Free Software Foundation, Inc. ;; Author: Oliver Seidel <os10000(a)seidel-space.de&gt; ;; [Not clear the above works, July 2000] ;; Created: 2 Aug 1997 -;; Version: $Id: todo-mode.el,v 1.1 2006/07/31 02:15:24 jmiller Exp $ ;; Keywords: calendar, todo -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; XEmacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; GNU Emacs is distributed in the hope that it will be useful, +;; XEmacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;; --------------------------------------------------------------------------- ＠＠ -93,12 +93,6 ＠＠ ;; extensions that are not explicitly listed in the above quick ;; installation. ;; -;; Version -;; -;; Which version of todo-mode.el does this documentation refer to? -;; -;; $Id: todo-mode.el,v 1.1 2006/07/31 02:15:24 jmiller Exp $ -;; ;; Pre-Requisites ;; ;; This package will require the following packages to be ＠＠ -262,9 +256,11 ＠＠ ;; Oliver Seidel ;; (Lessingstr. 8, 65760 Eschborn, Federal Republic of Germany) +;;; Synched up with: FSF Emacs 22.1 CVS 2006-09-15 + ;;; Code: -;; XEmacs +;; XEmacs change (eval-and-compile (unless (fboundp 'line-beginning-position) (defalias 'line-beginning-position 'point-at-bol)) ＠＠ -323,7 +319,7 ＠＠ lower bound will coincide at the end of the loop and you will insert your item just before that point. If you set the threshhold to, e.g. 8, it will stop as soon as the window size drops below that -amount and will insert the item in the approximate centre of that +amount and will insert the item in the approximate center of that window." :type 'integer :group 'todo) ＠＠ -504,9 +500,8 ＠＠ (interactive) (save-excursion (save-restriction - (save-buffer) - (if todo-save-top-priorities-too (todo-save-top-priorities)) - ))) + (save-buffer))) + (if todo-save-top-priorities-too (todo-save-top-priorities))) (defalias 'todo-cmd-save 'todo-save) (defun todo-quit () ＠＠ -919,11 +914,12 ＠＠ \\{todo-mode-map}" (interactive) + (kill-all-local-variables) (setq major-mode 'todo-mode) (setq mode-name "TODO") (use-local-map todo-mode-map) (easy-menu-add todo-menu) - (run-hooks 'todo-mode-hook)) + (run-mode-hooks 'todo-mode-hook)) (eval-when-compile (defvar date) ＠＠ -969,4 +965,5 ＠＠ (provide 'todo-mode) +;;; arch-tag: 6fd91be5-776e-4464-a109-da4ea0e4e497 ;;; todo-mode.el ends here _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches