Update for `calendar-date-style' replacing `european-calendar'.
[emacs.git] / lisp / calendar / cal-menu.el
blob2e2fcd766074050941dc0f6e6e5a327a96449430
1 ;;; cal-menu.el --- calendar functions for menu bar and popup menu support
3 ;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4 ;; 2008 Free Software Foundation, Inc.
6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7 ;; Lara Rios <lrios@coewl.cen.uiuc.edu>
8 ;; Maintainer: Glenn Morris <rgm@gnu.org>
9 ;; Keywords: calendar
10 ;; Human-Keywords: calendar, popup menus, menu bar
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 3, or (at your option)
17 ;; any later version.
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27 ;; Boston, MA 02110-1301, USA.
29 ;;; Commentary:
31 ;; This collection of functions implements menu bar and popup menu support for
32 ;; calendar.el.
34 ;;; Code:
36 (require 'calendar)
38 (defconst cal-menu-moon-menu
39 '("Moon"
40 ["Lunar Phases" calendar-phases-of-moon]))
42 (defconst cal-menu-diary-menu
43 '("Diary"
44 ["Other File" view-other-diary-entries]
45 ["Cursor Date" diary-view-entries]
46 ["Mark All" mark-diary-entries]
47 ["Show All" diary-show-all-entries]
48 ["Insert Diary Entry" insert-diary-entry]
49 ["Insert Weekly" insert-weekly-diary-entry]
50 ["Insert Monthly" insert-monthly-diary-entry]
51 ["Insert Yearly" insert-yearly-diary-entry]
52 ["Insert Anniversary" insert-anniversary-diary-entry]
53 ["Insert Block" insert-block-diary-entry]
54 ["Insert Cyclic" insert-cyclic-diary-entry]
55 ("Insert Baha'i"
56 ["One time" diary-bahai-insert-entry]
57 ["Monthly" diary-bahai-insert-monthly-entry]
58 ["Yearly" diary-bahai-insert-yearly-entry])
59 ("Insert Islamic"
60 ["One time" insert-islamic-diary-entry]
61 ["Monthly" insert-monthly-islamic-diary-entry]
62 ["Yearly" insert-yearly-islamic-diary-entry])
63 ("Insert Hebrew"
64 ["One time" insert-hebrew-diary-entry]
65 ["Monthly" insert-monthly-hebrew-diary-entry]
66 ["Yearly" insert-yearly-hebrew-diary-entry])))
68 (defun cal-menu-holiday-window-suffix ()
69 "Return a string suffix for the \"Window\" entry in `cal-menu-holidays-menu'."
70 (let ((my1 (calendar-increment-month -1))
71 (my2 (calendar-increment-month 1)))
72 (if (= (cdr my1) (cdr my2))
73 (format "%s-%s, %d"
74 (calendar-month-name (car my1) 'abbrev)
75 (calendar-month-name (car my2) 'abbrev)
76 (cdr my2))
77 (format "%s, %d-%s, %d"
78 (calendar-month-name (car my1) 'abbrev)
79 (cdr my1)
80 (calendar-month-name (car my2) 'abbrev)
81 (cdr my2)))))
83 (defvar displayed-year) ; from generate-calendar
85 (defconst cal-menu-holidays-menu
86 `("Holidays"
87 ["For Cursor Date -" calendar-cursor-holidays
88 :suffix (calendar-date-string (calendar-cursor-to-date) t t)
89 :visible (calendar-cursor-to-date)]
90 ["For Window -" calendar-list-holidays
91 :suffix (cal-menu-holiday-window-suffix)]
92 ["For Today -" cal-menu-today-holidays
93 :suffix (calendar-date-string (calendar-current-date) t t)]
94 "--"
95 ,@(let ((l ()))
96 ;; Show 11 years--5 before, 5 after year of middle month.
97 ;; We used to use :suffix rather than :label and bumped into
98 ;; an easymenu bug:
99 ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html
100 ;; The bug has since been fixed.
101 (dotimes (i 11)
102 (push (vector (format "hol-year-%d" i)
103 `(lambda ()
104 (interactive)
105 (holiday-list (+ displayed-year ,(- i 5))))
106 :label `(format "For Year %d"
107 (+ displayed-year ,(- i 5))))
109 (nreverse l))
110 "--"
111 ["Unmark Calendar" calendar-unmark]
112 ["Mark Holidays" mark-calendar-holidays]))
114 (defconst cal-menu-goto-menu
115 '("Go To"
116 ["Today" calendar-goto-today]
117 ["Beginning of Week" calendar-beginning-of-week]
118 ["End of Week" calendar-end-of-week]
119 ["Beginning of Month" calendar-beginning-of-month]
120 ["End of Month" calendar-end-of-month]
121 ["Beginning of Year" calendar-beginning-of-year]
122 ["End of Year" calendar-end-of-year]
123 ["Other Date" calendar-goto-date]
124 ["Day of Year" calendar-goto-day-of-year]
125 ["ISO Week" calendar-goto-iso-week]
126 ["ISO Date" calendar-goto-iso-date]
127 ["Astronomical Date" calendar-goto-astro-day-number]
128 ["Hebrew Date" calendar-goto-hebrew-date]
129 ["Persian Date" calendar-goto-persian-date]
130 ["Baha'i Date" calendar-bahai-goto-date]
131 ["Islamic Date" calendar-goto-islamic-date]
132 ["Julian Date" calendar-goto-julian-date]
133 ["Chinese Date" calendar-goto-chinese-date]
134 ["Coptic Date" calendar-goto-coptic-date]
135 ["Ethiopic Date" calendar-goto-ethiopic-date]
136 ("Mayan Date"
137 ["Next Tzolkin" calendar-next-tzolkin-date]
138 ["Previous Tzolkin" calendar-previous-tzolkin-date]
139 ["Next Haab" calendar-next-haab-date]
140 ["Previous Haab" calendar-previous-haab-date]
141 ["Next Round" calendar-next-calendar-round-date]
142 ["Previous Round" calendar-previous-calendar-round-date])
143 ["French Date" calendar-goto-french-date]))
145 (defconst cal-menu-scroll-menu
146 '("Scroll"
147 ["Forward 1 Month" calendar-scroll-left]
148 ["Forward 3 Months" calendar-scroll-left-three-months]
149 ["Forward 1 Year" "4\C-v"]
150 ["Backward 1 Month" calendar-scroll-right]
151 ["Backward 3 Months" calendar-scroll-right-three-months]
152 ["Backward 1 Year" "4\ev"]))
154 (defun cal-menu-x-popup-menu (position menu)
155 "Like `x-popup-menu', but print an error message if popups are unavailable.
156 POSITION and MENU are passed to `x-popup-menu'."
157 (if (display-popup-menus-p)
158 (x-popup-menu position menu)
159 (error "Popup menus are not available on this system")))
161 (defun cal-menu-list-holidays-year ()
162 "Display a list of the holidays of the selected date's year."
163 (interactive)
164 (holiday-list (extract-calendar-year (calendar-cursor-to-date))))
166 (defun cal-menu-list-holidays-following-year ()
167 "Display a list of the holidays of the following year."
168 (interactive)
169 (holiday-list (1+ (extract-calendar-year (calendar-cursor-to-date)))))
171 (defun cal-menu-list-holidays-previous-year ()
172 "Display a list of the holidays of the previous year."
173 (interactive)
174 (holiday-list (1- (extract-calendar-year (calendar-cursor-to-date)))))
176 (defun calendar-event-to-date (&optional error)
177 "Date of last event.
178 If event is not on a specific date, signals an error if optional parameter
179 ERROR is non-nil, otherwise just returns nil."
180 (with-current-buffer
181 (window-buffer (posn-window (event-start last-input-event)))
182 (goto-char (posn-point (event-start last-input-event)))
183 (calendar-cursor-to-date error)))
185 (defun calendar-mouse-goto-date (date)
186 "Go to DATE in the buffer specified by `last-input-event'."
187 (set-buffer (window-buffer (posn-window (event-start last-input-event))))
188 (calendar-goto-date date))
190 (defun calendar-mouse-sunrise/sunset ()
191 "Show sunrise/sunset times for mouse-selected date."
192 (interactive)
193 (save-excursion
194 (calendar-mouse-goto-date (calendar-event-to-date))
195 (calendar-sunrise-sunset)))
197 (defun cal-menu-today-holidays ()
198 "Show holidays for today's date."
199 (interactive)
200 (save-excursion
201 (calendar-cursor-to-date (calendar-current-date))
202 (calendar-cursor-holidays)))
204 (autoload 'calendar-check-holidays "holidays")
206 (defun calendar-mouse-holidays (&optional event)
207 "Pop up menu of holidays for mouse selected date.
208 EVENT is the event that invoked this command."
209 (interactive "e")
210 (let* ((date (calendar-event-to-date))
211 (title (format "Holidays for %s" (calendar-date-string date)))
212 (selection
213 (cal-menu-x-popup-menu
214 event
215 (list title
216 (append (list title)
217 (or (mapcar 'list (calendar-check-holidays date))
218 '("None")))))))
219 (and selection (call-interactively selection))))
221 (autoload 'diary-list-entries "diary-lib")
222 (defvar holidays-in-diary-buffer) ; only called from calendar.el
224 (defun calendar-mouse-view-diary-entries (&optional date diary event)
225 "Pop up menu of diary entries for mouse-selected date.
226 Use optional DATE and alternative file DIARY. EVENT is the event
227 that invoked this command. Shows holidays if `holidays-in-diary-buffer'
228 is non-nil."
229 (interactive "i\ni\ne")
230 (let* ((date (or date (calendar-event-to-date)))
231 (diary-file (or diary diary-file))
232 (diary-list-include-blanks nil)
233 (diary-display-hook 'ignore)
234 (diary-entries
235 (mapcar (lambda (x) (split-string (cadr x) "\n"))
236 (diary-list-entries date 1 'list-only)))
237 (holidays (if holidays-in-diary-buffer
238 (calendar-check-holidays date)))
239 (title (concat "Diary entries "
240 (if diary (format "from %s " diary) "")
241 "for "
242 (calendar-date-string date)))
243 (selection
244 (cal-menu-x-popup-menu
245 event
246 (list title
247 (append
248 (list title)
249 (mapcar (lambda (x) (list (concat " " x))) holidays)
250 (if holidays
251 (list "--shadow-etched-in" "--shadow-etched-in"))
252 (if diary-entries
253 (mapcar 'list (apply 'append diary-entries))
254 '("None")))))))
255 (and selection (call-interactively selection))))
257 (defun calendar-mouse-view-other-diary-entries ()
258 "Pop up menu of diary entries from alternative file on mouse-selected date."
259 (interactive)
260 (calendar-mouse-view-diary-entries
261 (calendar-event-to-date)
262 (read-file-name "Enter diary file name: " default-directory nil t)))
264 (defun calendar-mouse-insert-diary-entry ()
265 "Insert diary entry for mouse-selected date."
266 (interactive)
267 (save-excursion
268 (calendar-mouse-goto-date (calendar-event-to-date))
269 (insert-diary-entry nil)))
271 (defun calendar-mouse-set-mark ()
272 "Mark the date under the cursor."
273 (interactive)
274 (save-excursion
275 (calendar-mouse-goto-date (calendar-event-to-date))
276 (calendar-set-mark nil)))
278 (defun cal-tex-mouse-day ()
279 "Make a buffer with LaTeX commands for the day mouse is on."
280 (interactive)
281 (save-excursion
282 (calendar-mouse-goto-date (calendar-event-to-date))
283 (cal-tex-cursor-day nil)))
285 (defun cal-tex-mouse-week ()
286 "One page calendar for week indicated by cursor.
287 Holidays are included if `cal-tex-holidays' is non-nil."
288 (interactive)
289 (save-excursion
290 (calendar-mouse-goto-date (calendar-event-to-date))
291 (cal-tex-cursor-week nil)))
293 (defun cal-tex-mouse-week2 ()
294 "Make a buffer with LaTeX commands for the week cursor is on.
295 The printed output will be on two pages."
296 (interactive)
297 (save-excursion
298 (calendar-mouse-goto-date (calendar-event-to-date))
299 (cal-tex-cursor-week2 nil)))
301 (defun cal-tex-mouse-week-iso ()
302 "One page calendar for week indicated by cursor.
303 Holidays are included if `cal-tex-holidays' is non-nil."
304 (interactive)
305 (save-excursion
306 (calendar-mouse-goto-date (calendar-event-to-date))
307 (cal-tex-cursor-week-iso nil)))
309 (defun cal-tex-mouse-week-monday ()
310 "One page calendar for week indicated by cursor."
311 (interactive)
312 (save-excursion
313 (calendar-mouse-goto-date (calendar-event-to-date))
314 (cal-tex-cursor-week-monday nil)))
316 (defun cal-tex-mouse-filofax-daily ()
317 "Day-per-page Filofax calendar for week indicated by cursor."
318 (interactive)
319 (save-excursion
320 (calendar-mouse-goto-date (calendar-event-to-date))
321 (cal-tex-cursor-filofax-daily nil)))
323 (defun cal-tex-mouse-filofax-2week ()
324 "One page Filofax calendar for week indicated by cursor."
325 (interactive)
326 (save-excursion
327 (calendar-mouse-goto-date (calendar-event-to-date))
328 (cal-tex-cursor-filofax-2week nil)))
330 (defun cal-tex-mouse-filofax-week ()
331 "Two page Filofax calendar for week indicated by cursor."
332 (interactive)
333 (save-excursion
334 (calendar-mouse-goto-date (calendar-event-to-date))
335 (cal-tex-cursor-filofax-week nil)))
337 (defun cal-tex-mouse-month ()
338 "Make a buffer with LaTeX commands for the month cursor is on.
339 Calendar is condensed onto one page."
340 (interactive)
341 (save-excursion
342 (calendar-mouse-goto-date (calendar-event-to-date))
343 (cal-tex-cursor-month nil)))
345 (defun cal-tex-mouse-month-landscape ()
346 "Make a buffer with LaTeX commands for the month cursor is on.
347 The output is in landscape format, one month to a page."
348 (interactive)
349 (save-excursion
350 (calendar-mouse-goto-date (calendar-event-to-date))
351 (cal-tex-cursor-month-landscape nil)))
353 (defun cal-tex-mouse-year ()
354 "Make a buffer with LaTeX commands for the year cursor is on."
355 (interactive)
356 (save-excursion
357 (calendar-mouse-goto-date (calendar-event-to-date))
358 (cal-tex-cursor-year nil)))
360 (defun cal-tex-mouse-filofax-year ()
361 "Make a buffer with LaTeX commands for Filofax calendar of year cursor is on."
362 (interactive)
363 (save-excursion
364 (calendar-mouse-goto-date (calendar-event-to-date))
365 (cal-tex-cursor-filofax-year nil)))
367 (defun cal-tex-mouse-year-landscape ()
368 "Make a buffer with LaTeX commands for the year cursor is on."
369 (interactive)
370 (save-excursion
371 (calendar-mouse-goto-date (calendar-event-to-date))
372 (cal-tex-cursor-year-landscape nil)))
374 (defun calendar-mouse-print-dates (&optional event)
375 "Pop up menu of equivalent dates to mouse selected date.
376 EVENT is the event that invoked this command."
377 (interactive "e")
378 (let* ((date (calendar-event-to-date))
379 (title (format "%s (Gregorian)" (calendar-date-string date)))
380 (selection
381 (cal-menu-x-popup-menu
382 event
383 (list title
384 (append (list title)
385 (mapcar 'list (calendar-other-dates date)))))))
386 (and selection (call-interactively selection))))
388 (defun cal-menu-set-date-title (menu)
389 "Convert date of last event to title suitable for MENU."
390 (easy-menu-filter-return
391 menu (calendar-date-string (calendar-event-to-date t) t nil)))
393 (easy-menu-define cal-menu-context-mouse-menu nil
394 "Pop up menu for Mouse-2 for selected date in the calendar window."
395 '("foo" :filter cal-menu-set-date-title
396 "--"
397 ["Holidays" calendar-mouse-holidays]
398 ["Mark date" calendar-mouse-set-mark]
399 ["Sunrise/sunset" calendar-mouse-sunrise/sunset]
400 ["Other calendars" calendar-mouse-print-dates]
401 ("Prepare LaTeX buffer"
402 ["Daily (1 page)" cal-tex-mouse-day]
403 ["Weekly (1 page)" cal-tex-mouse-week]
404 ["Weekly (2 pages)" cal-tex-mouse-week2]
405 ["Weekly (other style; 1 page)" cal-tex-mouse-week-iso]
406 ["Weekly (yet another style; 1 page)" cal-tex-mouse-week-monday]
407 ["Monthly" cal-tex-mouse-month]
408 ["Monthly (landscape)" cal-tex-mouse-month-landscape]
409 ["Yearly" cal-tex-mouse-year]
410 ["Yearly (landscape)" cal-tex-mouse-year-landscape]
411 ("Filofax styles"
412 ["Filofax Daily (one-day-per-page)" cal-tex-mouse-filofax-daily]
413 ["Filofax Weekly (2-weeks-at-a-glance)" cal-tex-mouse-filofax-2week]
414 ["Filofax Weekly (week-at-a-glance)" cal-tex-mouse-filofax-week]
415 ["Filofax Yearly" cal-tex-mouse-filofax-year]))
416 ["Diary entries" calendar-mouse-view-diary-entries]
417 ["Insert diary entry" calendar-mouse-insert-diary-entry]
418 ["Other diary file entries" calendar-mouse-view-other-diary-entries]))
420 (easy-menu-define cal-menu-global-mouse-menu nil
421 "Menu bound to a mouse event, not specific to the mouse-click location."
422 '("Calendar"
423 ["Scroll forward" calendar-scroll-left-three-months]
424 ["Scroll backward" calendar-scroll-right-three-months]
425 ["Mark diary entries" mark-diary-entries]
426 ["List holidays" calendar-list-holidays]
427 ["Mark holidays" calendar-mark-holidays]
428 ["Unmark" calendar-unmark]
429 ["Lunar phases" calendar-phases-of-moon]
430 ["Show diary" diary-show-all-entries]
431 ["Exit calendar" exit-calendar]))
433 ;; Undocumented and probably useless.
434 (defvar cal-menu-load-hook nil
435 "Hook run on loading of the `cal-menu' package.")
436 (make-obsolete-variable 'cal-menu-load-hook
437 "it will be removed in future." "23.1")
439 (run-hooks 'cal-menu-load-hook)
441 (provide 'cal-menu)
443 ;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9
444 ;;; cal-menu.el ends here