X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ee3bb32f1b5e16ebacfb32f7690b5f913f4a5d52..94ce023059fcc9856a3914a70ea462e385551bed:/lisp/calendar/cal-menu.el diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index 9295c77d77..1bae5ce629 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -1,9 +1,11 @@ ;;; cal-menu.el --- calendar functions for menu bar and popup menu support -;; 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 ;; Lara Rios +;; Maintainer: Glenn Morris ;; Keywords: calendar ;; Human-Keywords: calendar, popup menus, menu bar @@ -21,8 +23,8 @@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -37,7 +39,12 @@ ;;; Code: -(eval-when-compile (require 'calendar)) +(defvar displayed-month) +(defvar displayed-year) + +;; Don't require calendar because calendar requires us. +;; (eval-when-compile (require 'calendar)) +(defvar calendar-mode-map) (define-key calendar-mode-map [menu-bar edit] 'undefined) (define-key calendar-mode-map [menu-bar search] 'undefined) @@ -47,7 +54,6 @@ (defvar calendar-mouse-3-map (make-sparse-keymap "Calendar")) (define-key calendar-mode-map [down-mouse-3] calendar-mouse-3-map) -(define-key calendar-mode-map [C-down-mouse-3] calendar-mouse-3-map) (define-key calendar-mode-map [menu-bar moon] (cons "Moon" (make-sparse-keymap "Moon"))) @@ -62,6 +68,8 @@ '("Insert Hebrew" . calendar-mouse-insert-hebrew-diary-entry)) (define-key calendar-mode-map [menu-bar diary isl] '("Insert Islamic" . calendar-mouse-insert-islamic-diary-entry)) +(define-key calendar-mode-map [menu-bar diary baha] + '("Insert Baha'i" . calendar-mouse-insert-bahai-diary-entry)) (define-key calendar-mode-map [menu-bar diary cyc] '("Insert Cyclic" . insert-cyclic-diary-entry)) (define-key calendar-mode-map [menu-bar diary blk] @@ -75,34 +83,19 @@ (define-key calendar-mode-map [menu-bar diary wk] '("Insert Weekly" . insert-weekly-diary-entry)) (define-key calendar-mode-map [menu-bar diary ent] - '("Insert Daily". insert-diary-entry)) + '("Insert Diary Entry" . insert-diary-entry)) (define-key calendar-mode-map [menu-bar diary all] - '("Show All" . show-all-diary-entries)) + '("Show All" . diary-show-all-entries)) (define-key calendar-mode-map [menu-bar diary mark] '("Mark All" . mark-diary-entries)) (define-key calendar-mode-map [menu-bar diary view] - '("Cursor Date" . view-diary-entries)) + '("Cursor Date" . diary-view-entries)) (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 previous-year] - '("Previous year" . cal-menu-list-holidays-previous-year)) -(define-key calendar-mode-map [menu-bar holidays following-year] - '("Following year" . cal-menu-list-holidays-following-year)) -(define-key calendar-mode-map [menu-bar holidays year] - '("Year" . cal-menu-list-holidays-year)) -(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"))) @@ -120,6 +113,8 @@ '("Julian Date" . calendar-goto-julian-date)) (define-key calendar-mode-map [menu-bar goto islamic] '("Islamic Date" . calendar-goto-islamic-date)) +(define-key calendar-mode-map [menu-bar goto persian] + '("Baha'i Date" . calendar-goto-bahai-date)) (define-key calendar-mode-map [menu-bar goto persian] '("Persian Date" . calendar-goto-persian-date)) (define-key calendar-mode-map [menu-bar goto hebrew] @@ -128,6 +123,10 @@ '("Astronomical Date" . calendar-goto-astro-day-number)) (define-key calendar-mode-map [menu-bar goto iso] '("ISO Date" . calendar-goto-iso-date)) +(define-key calendar-mode-map [menu-bar goto iso-week] + '("ISO Week" . calendar-goto-iso-week)) +(define-key calendar-mode-map [menu-bar goto day-of-year] + '("Day of Year" . calendar-goto-day-of-year)) (define-key calendar-mode-map [menu-bar goto gregorian] '("Other Date" . calendar-goto-date)) (define-key calendar-mode-map [menu-bar goto end-of-year] @@ -175,6 +174,22 @@ (define-key calendar-mode-map [menu-bar scroll fwd-1] '("Forward 1 Month" . scroll-calendar-left)) +(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-x-popup-menu (position menu) + "Like `x-popup-menu', but prints an error message if popup menus are +not available." + (if (display-popup-menus-p) + (x-popup-menu position menu) + (error "Popup menus are not available on this system"))) + (defun cal-menu-list-holidays-year () "Display a list of the holidays of the selected date's year." (interactive) @@ -193,6 +208,55 @@ (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)) + ;; 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 "--" l)))) + (define-key calendar-mode-map [menu-bar Holidays] + (cons "Holidays" (easy-menu-create-menu "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 ((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)))))) + (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 @@ -206,7 +270,7 @@ ERROR is t, otherwise just returns nil." "Pop up menu to insert a Hebrew-date diary entry." (interactive "e") (let ((hebrew-selection - (x-popup-menu + (cal-menu-x-popup-menu event (list "Hebrew insert menu" (list (calendar-hebrew-date-string (calendar-cursor-to-date)) @@ -219,7 +283,7 @@ ERROR is t, otherwise just returns nil." "Pop up menu to insert an Islamic-date diary entry." (interactive "e") (let ((islamic-selection - (x-popup-menu + (cal-menu-x-popup-menu event (list "Islamic insert menu" (list (calendar-islamic-date-string (calendar-cursor-to-date)) @@ -228,6 +292,19 @@ ERROR is t, otherwise just returns nil." '("Yearly" . insert-yearly-islamic-diary-entry)))))) (and islamic-selection (call-interactively islamic-selection)))) +(defun calendar-mouse-insert-bahai-diary-entry (event) + "Pop up menu to insert an Baha'i-date diary entry." + (interactive "e") + (let ((bahai-selection + (x-popup-menu + event + (list "Baha'i insert menu" + (list (calendar-bahai-date-string (calendar-cursor-to-date)) + '("One time" . insert-bahai-diary-entry) + '("Monthly" . insert-monthly-bahai-diary-entry) + '("Yearly" . insert-yearly-bahai-diary-entry)))))) + (and bahai-selection (call-interactively bahai-selection)))) + (defun calendar-mouse-sunrise/sunset () "Show sunrise/sunset times for mouse-selected date." (interactive) @@ -235,26 +312,70 @@ ERROR is t, otherwise just returns nil." (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-mouse-goto-date (calendar-event-to-date)) + (calendar-cursor-to-date (calendar-current-date)) (calendar-cursor-holidays))) -(defun calendar-mouse-view-diary-entries () - "View diary entries on mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (view-diary-entries 1))) +(autoload 'check-calendar-holidays "holidays") +(autoload 'diary-list-entries "diary-lib") + +(defun calendar-mouse-holidays (&optional event) + "Pop up menu of holidays for mouse selected date." + (interactive "e") + (let* ((date (calendar-event-to-date)) + (l (mapcar 'list (check-calendar-holidays date))) + (selection + (cal-menu-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 (&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 "i\ni\ne") + (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 + (check-calendar-holidays date))) + (title (concat "Diary entries " + (if diary (format "from %s " diary) "") + "for " + (calendar-date-string date))) + (selection + (cal-menu-x-popup-menu + event + (list title + (append + (list title) + (mapcar (lambda (x) (list (concat " " x))) holidays) + (if holidays + (list "--shadow-etched-in" "--shadow-etched-in")) + (if diary-entries + (mapcar 'list (calendar-flatten diary-entries)) + '("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-mouse-goto-date (calendar-event-to-date)) - (call-interactively 'view-other-diary-entries))) + (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." @@ -366,12 +487,12 @@ The output is in landscape format, one month to a page." (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) - (let ((date (calendar-event-to-date)) + (interactive "e") + (let* ((date (calendar-event-to-date)) (selection - (x-popup-menu + (cal-menu-x-popup-menu event (list (concat (calendar-date-string date) " (Gregorian)") @@ -386,20 +507,22 @@ The output is in landscape format, one month to a page." (format "Astronomical (Julian) day number (at noon UTC): %s.0" (calendar-astro-date-string date))) (list - (format "Fixed date: %s" + (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" - (calendar-persian-date-string date)))) + (calendar-persian-date-string date))) + (list (format "Baha'i date (before sunset): %s" + (calendar-bahai-date-string date)))) (let ((i (calendar-islamic-date-string date))) (if (not (string-equal i "")) (list (list (format "Islamic date (before sunset): %s" i))))) (list (list (format "Chinese date: %s" (calendar-chinese-date-string date)))) -; (list '("Chinese date (select to echo Chinese date)" -; . calendar-mouse-chinese-date)) + ;; (list '("Chinese date (select to echo Chinese date)" + ;; . calendar-mouse-chinese-date)) (let ((c (calendar-coptic-date-string date))) (if (not (string-equal c "")) (list (list (format "Coptic date: %s" c))))) @@ -431,7 +554,7 @@ The output is in landscape format, one month to a page." (interactive "e") (let* ((date (calendar-event-to-date t)) (selection - (x-popup-menu + (cal-menu-x-popup-menu event (list (calendar-date-string date t nil) (list @@ -452,9 +575,9 @@ The output is in landscape format, one month to a page." "Pop up submenu for Mouse-2 for cal-tex commands for selected date in the calendar window." (interactive "e") (let* ((selection - (x-popup-menu + (cal-menu-x-popup-menu event - (list (calendar-date-string date t nil) + (list (calendar-date-string (calendar-event-to-date t) t nil) (list "" '("Daily (1 page)" . cal-tex-mouse-day) @@ -475,9 +598,9 @@ The output is in landscape format, one month to a page." "Pop up sub-submenu for Mouse-2 for Filofax cal-tex commands for selected date." (interactive "e") (let* ((selection - (x-popup-menu + (cal-menu-x-popup-menu event - (list (calendar-date-string date t nil) + (list (calendar-date-string (calendar-event-to-date t) t nil) (list "" '("Filofax Daily (one-day-per-page)" . @@ -493,7 +616,7 @@ The output is in landscape format, one month to a page." (define-key calendar-mouse-3-map [exit-calendar] '("Exit calendar" . exit-calendar)) (define-key calendar-mouse-3-map [show-diary] - '("Show diary" . show-all-diary-entries)) + '("Show diary" . diary-show-all-entries)) (define-key calendar-mouse-3-map [lunar-phases] '("Lunar phases" . calendar-phases-of-moon)) (define-key calendar-mouse-3-map [unmark] @@ -513,4 +636,5 @@ The output is in landscape format, one month to a page." (provide 'cal-menu) +;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9 ;;; cal-menu.el ends here