X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/c21eb13de8bc9853f12aacb57a68fafa76f17e40..7e1e5cf14f7f19889ea52afd34244361bea6f9e8:/lisp/calendar/cal-menu.el diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index e058857a46..7c7056db7e 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -37,6 +37,9 @@ ;;; Code: +(eval-when-compile (require 'calendar)) +(require 'easymenu) + (define-key calendar-mode-map [menu-bar edit] 'undefined) (define-key calendar-mode-map [menu-bar search] 'undefined) @@ -83,18 +86,9 @@ (define-key calendar-mode-map [menu-bar diary view] '("Other File" . view-other-diary-entries)) -(define-key calendar-mode-map [menu-bar holidays] +(define-key calendar-mode-map [menu-bar Holidays] (cons "Holidays" (make-sparse-keymap "Holidays"))) -(define-key calendar-mode-map [menu-bar holidays unmark] - '("Unmark" . calendar-unmark)) -(define-key calendar-mode-map [menu-bar holidays mark] - '("Mark" . mark-calendar-holidays)) -(define-key calendar-mode-map [menu-bar holidays 3-mon] - '("3 Months" . list-calendar-holidays)) -(define-key calendar-mode-map [menu-bar holidays 1-day] - '("One Day" . calendar-cursor-holidays)) - (define-key calendar-mode-map [menu-bar goto] (cons "Goto" (make-sparse-keymap "Goto"))) @@ -167,56 +161,82 @@ (define-key calendar-mode-map [menu-bar scroll fwd-1] '("Forward 1 Month" . scroll-calendar-left)) -(put 'calendar-forward-day 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-day 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-mouse-print-dates 'menu-enable '(calendar-event-to-date)) -(put 'calendar-sunrise-sunset 'menu-enable '(calendar-event-to-date)) -(put 'calendar-cursor-holidays 'menu-enable '(calendar-cursor-to-date)) -(put 'view-diary-entries 'menu-enable '(calendar-cursor-to-date)) -(put 'view-other-diary-entries 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-mouse-insert-hebrew-diary-entry - 'menu-enable - '(calendar-cursor-to-date)) -(put 'calendar-mouse-insert-islamic-diary-entry - 'menu-enable - '(calendar-cursor-to-date)) -(put 'insert-cyclic-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-block-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-anniversary-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-yearly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-monthly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-weekly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-day 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week2 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week-iso 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week-monday 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-2week - 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-week 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-month 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-month-landscape 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-year 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-year 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-year-landscape 'menu-enable '(calendar-cursor-to-date)) +(defun cal-menu-list-holidays-year () + "Display a list of the holidays of the selected date's year." + (interactive) + (let ((year (extract-calendar-year (calendar-cursor-to-date)))) + (list-holidays year year))) + +(defun cal-menu-list-holidays-following-year () + "Display a list of the holidays of the following year." + (interactive) + (let ((year (1+ (extract-calendar-year (calendar-cursor-to-date))))) + (list-holidays year year))) + +(defun cal-menu-list-holidays-previous-year () + "Display a list of the holidays of the previous year." + (interactive) + (let ((year (1- (extract-calendar-year (calendar-cursor-to-date))))) + (list-holidays year year))) + +(defun cal-menu-update () + ;; Update the holiday part of calendar menu bar for the current display. + (condition-case nil + (if (eq major-mode 'calendar-mode) + (let ((l)) + (calendar-for-loop;; Show 11 years--5 before, 5 after year of + ;; middle month + 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))) + (setq l (cons ["Mark Holidays" mark-calendar-holidays t] + (cons ["Unmark Calendar" calendar-unmark t] + (cons ["--" '("--") t] l)))) + (easy-menu-change nil "Holidays" (nreverse l)) + (define-key calendar-mode-map [menu-bar Holidays separator] + '("--")) + (define-key calendar-mode-map [menu-bar Holidays today] + `(,(format "For Today (%s)" + (calendar-date-string (calendar-current-date) t t)) + . cal-menu-today-holidays)) + (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))))) + (define-key calendar-mode-map [menu-bar Holidays 3-month] + `(,(format "For Window (%s)" title) + . list-calendar-holidays))) + (let ((date (calendar-cursor-to-date))) + (if date + (define-key calendar-mode-map [menu-bar Holidays 1-day] + `(,(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) "Date of last event. If event is not on a specific date, signals an error if optional parameter ERROR is t, otherwise just returns nil." (save-excursion + (set-buffer (window-buffer (posn-window (event-start last-input-event)))) (goto-char (posn-point (event-start last-input-event))) (calendar-cursor-to-date error))) @@ -250,49 +270,94 @@ ERROR is t, otherwise just returns nil." "Show sunrise/sunset times for mouse-selected date." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (calendar-sunrise-sunset))) -(defun calendar-mouse-holidays () - "Show holidays for mouse-selected date." +(defun cal-menu-today-holidays () + "Show holidays for today's date." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-cursor-to-date (calendar-current-date)) (calendar-cursor-holidays))) +(defun calendar-mouse-holidays () + "Pop up menu of holidays for mouse selected date." + (interactive) + (let* ((date (calendar-event-to-date)) + (l (mapcar '(lambda (x) (list x)) + (check-calendar-holidays date))) + (selection + (x-popup-menu + event + (list + (format "Holidays for %s" (calendar-date-string date)) + (append + (list (format "Holidays for %s" (calendar-date-string date))) + (if l l '("None"))))))) + (and selection (call-interactively selection)))) + (defun calendar-mouse-view-diary-entries () - "View diary entries on mouse-selected date." + "Pop up menu of diary entries for mouse selected date." (interactive) - (save-excursion - (calendar-goto-date (calendar-event-to-date)) - (view-diary-entries 1))) + (let* ((date (calendar-event-to-date)) + (l (mapcar '(lambda (x) (list (car (cdr x)))) + (let ((diary-list-include-blanks nil) + (diary-display-hook 'ignore)) + (list-diary-entries date 1)))) + (selection + (x-popup-menu + event + (list + (format "Diary entries for %s" (calendar-date-string date)) + (append + (list (format "Diary entries for %s" (calendar-date-string date))) + (if l l '("None"))))))) + (and selection (call-interactively selection)))) (defun calendar-mouse-view-other-diary-entries () - "View diary entries from alternative file on mouse-selected date." + "Pop up menu of diary entries from alternative file on mouse-selected date." (interactive) - (save-excursion - (calendar-goto-date (calendar-event-to-date)) - (call-interactively 'view-other-diary-entries))) + (let* ((date (calendar-event-to-date)) + (l (mapcar '(lambda (x) (list (car (cdr x)))) + (let ((diary-list-include-blanks nil) + (diary-display-hook 'ignore) + (diary-file (read-file-name + "Enter diary file name: " + default-directory nil t))) + (list-diary-entries date 1)))) + (selection + (x-popup-menu + event + (list + (format "Diary entries from %s for %s" + diary-file + (calendar-date-string date)) + (append + (list (format "Diary entries from %s for %s" + diary-file + (calendar-date-string date))) + (if l l '("None"))))))) + (and selection (call-interactively selection)))) (defun calendar-mouse-insert-diary-entry () "Insert diary entry for mouse-selected date." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (insert-diary-entry nil))) (defun calendar-mouse-set-mark () "Mark the date under the cursor." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (calendar-set-mark nil))) (defun cal-tex-mouse-day () "Make a buffer with LaTeX commands for the day mouse is on." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-day nil))) (defun cal-tex-mouse-week () @@ -300,7 +365,7 @@ ERROR is t, otherwise just returns nil." Holidays are included if `cal-tex-holidays' is t." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-week nil))) (defun cal-tex-mouse-week2 () @@ -308,7 +373,7 @@ Holidays are included if `cal-tex-holidays' is t." The printed output will be on two pages." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-week2 nil))) (defun cal-tex-mouse-week-iso () @@ -316,28 +381,35 @@ The printed output will be on two pages." Holidays are included if `cal-tex-holidays' is t." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-week-iso nil))) (defun cal-tex-mouse-week-monday () "One page calendar for week indicated by cursor." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-week-monday nil))) +(defun cal-tex-mouse-filofax-daily () + "Day-per-page Filofax calendar for week indicated by cursor." + (interactive) + (save-excursion + (calendar-mouse-goto-date (calendar-event-to-date)) + (cal-tex-cursor-filofax-daily nil))) + (defun cal-tex-mouse-filofax-2week () "One page Filofax calendar for week indicated by cursor." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-filofax-2week nil))) (defun cal-tex-mouse-filofax-week () "Two page Filofax calendar for week indicated by cursor." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-filofax-week nil))) (defun cal-tex-mouse-month () @@ -345,7 +417,7 @@ Holidays are included if `cal-tex-holidays' is t." Calendar is condensed onto one page." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-month nil))) (defun cal-tex-mouse-month-landscape () @@ -353,28 +425,28 @@ Calendar is condensed onto one page." The output is in landscape format, one month to a page." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-month-landscape nil))) (defun cal-tex-mouse-year () "Make a buffer with LaTeX commands for the year cursor is on." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-year nil))) (defun cal-tex-mouse-filofax-year () "Make a buffer with LaTeX commands for Filofax calendar of year cursor is on." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-filofax-year nil))) (defun cal-tex-mouse-year-landscape () "Make a buffer with LaTeX commands for the year cursor is on." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (cal-tex-cursor-year-landscape nil))) (defun calendar-mouse-print-dates () @@ -394,8 +466,11 @@ The output is in landscape format, one month to a page." (list (format "Julian date: %s" (calendar-julian-date-string date))) (list - (format "Astronomical (Julian) day number (after noon UTC): %s" + (format "Astronomical (Julian) day number (at noon UTC): %s.0" (calendar-astro-date-string date))) + (list + (format "Fixed (RD) date: %s" + (calendar-absolute-from-gregorian date))) (list (format "Hebrew date (before sunset): %s" (calendar-hebrew-date-string date))) (list (format "Persian date: %s" @@ -427,9 +502,13 @@ The output is in landscape format, one month to a page." "Show Chinese equivalent for mouse-selected date." (interactive) (save-excursion - (calendar-goto-date (calendar-event-to-date)) + (calendar-mouse-goto-date (calendar-event-to-date)) (calendar-print-chinese-date))) +(defun calendar-mouse-goto-date (date) + (set-buffer (window-buffer (posn-window (event-start last-input-event)))) + (calendar-goto-date date)) + (defun calendar-mouse-2-date-menu (event) "Pop up menu for Mouse-2 for selected date in the calendar window." (interactive "e") @@ -484,6 +563,8 @@ The output is in landscape format, one month to a page." (list (calendar-date-string date t nil) (list "" + '("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)" .