cal-menu.el 16.4 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1 2
;;; cal-menu.el --- calendar functions for menu bar and popup menu support

3 4
;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;;   2008  Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
5 6

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
Glenn Morris's avatar
Glenn Morris committed
7
;;         Lara Rios <lrios@coewl.cen.uiuc.edu>
8
;; Maintainer: Glenn Morris <rgm@gnu.org>
Richard M. Stallman's avatar
Richard M. Stallman committed
9 10 11 12 13
;; Keywords: calendar
;; Human-Keywords: calendar, popup menus, menu bar

;; This file is part of GNU Emacs.

14 15
;; GNU Emacs is free software; you can redistribute it and/or modify
;; 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 18
;; any later version.

Richard M. Stallman's avatar
Richard M. Stallman committed
19
;; GNU Emacs is distributed in the hope that it will be useful,
20 21 22 23 24
;; 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
Erik Naggum's avatar
Erik Naggum committed
25
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
26 27
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
28 29 30

;;; Commentary:

31
;; See calendar.el.
Richard M. Stallman's avatar
Richard M. Stallman committed
32 33 34

;;; Code:

35
(require 'calendar)
Glenn Morris's avatar
Glenn Morris committed
36

37 38 39 40 41 42
(defconst cal-menu-moon-menu
  '("Moon"
    ["Lunar Phases" calendar-phases-of-moon]))

(defconst cal-menu-diary-menu
  '("Diary"
43
    ["Other File" diary-view-other-diary-entries]
44
    ["Cursor Date" diary-view-entries]
45
    ["Mark All" diary-mark-entries]
46
    ["Show All" diary-show-all-entries]
47 48 49 50 51 52 53
    ["Insert Diary Entry" diary-insert-entry]
    ["Insert Weekly" diary-insert-weekly-entry]
    ["Insert Monthly" diary-insert-monthly-entry]
    ["Insert Yearly" diary-insert-yearly-entry]
    ["Insert Anniversary" diary-insert-anniversary-entry]
    ["Insert Block" diary-insert-block-entry]
    ["Insert Cyclic" diary-insert-cyclic-entry]
54
    ("Insert Baha'i"
55 56 57
     ["One time" diary-bahai-insert-entry]
     ["Monthly" diary-bahai-insert-monthly-entry]
     ["Yearly" diary-bahai-insert-yearly-entry])
58
    ("Insert Islamic"
59 60 61
     ["One time" diary-islamic-insert-entry]
     ["Monthly" diary-islamic-insert-monthly-entry]
     ["Yearly" diary-islamic-insert-yearly-entry])
62
    ("Insert Hebrew"
63 64 65
     ["One time" diary-hebrew-insert-entry]
     ["Monthly" diary-hebrew--insert-monthly-entry]
     ["Yearly" diary-hebrew-insert-yearly-entry])))
66 67

(defun cal-menu-holiday-window-suffix ()
68
  "Return a string suffix for the \"Window\" entry in `cal-menu-holidays-menu'."
69 70 71 72 73 74 75 76 77 78 79 80 81
  (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)))))

82 83
(defvar displayed-year)                 ; from generate-calendar

84 85 86 87 88
(defconst cal-menu-holidays-menu
  `("Holidays"
    ["For Cursor Date -" calendar-cursor-holidays
     :suffix (calendar-date-string (calendar-cursor-to-date) t t)
     :visible (calendar-cursor-to-date)]
89
    ["For Window -" calendar-list-holidays
90 91 92 93 94 95
     :suffix (cal-menu-holiday-window-suffix)]
    ["For Today -" cal-menu-today-holidays
     :suffix (calendar-date-string (calendar-current-date) t t)]
    "--"
    ,@(let ((l ()))
        ;; Show 11 years--5 before, 5 after year of middle month.
96 97
        ;; We used to use :suffix rather than :label and bumped into
        ;; an easymenu bug:
98
        ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html
99
        ;; The bug has since been fixed.
100
        (dotimes (i 11)
101
          (push (vector (format "hol-year-%d" i)
102 103
                        `(lambda ()
                           (interactive)
104
                           (holiday-list (+ displayed-year ,(- i 5))))
105 106
                        :label `(format "For Year %d"
                                       (+ displayed-year ,(- i 5))))
107
                l))
108 109 110
        (nreverse l))
    "--"
    ["Unmark Calendar" calendar-unmark]
111
    ["Mark Holidays" calendar-mark-holidays]))
112 113

(defconst cal-menu-goto-menu
114
  '("Go To"
115 116 117 118 119 120 121 122 123
    ["Today" calendar-goto-today]
    ["Beginning of Week" calendar-beginning-of-week]
    ["End of Week" calendar-end-of-week]
    ["Beginning of Month" calendar-beginning-of-month]
    ["End of Month" calendar-end-of-month]
    ["Beginning of Year" calendar-beginning-of-year]
    ["End of Year" calendar-end-of-year]
    ["Other Date" calendar-goto-date]
    ["Day of Year" calendar-goto-day-of-year]
124 125 126
    ["ISO Week" calendar-iso-goto-week]
    ["ISO Date" calendar-iso-goto-date]
    ["Astronomical Date" calendar-astro-goto-day-number]
127
    ["Hebrew Date" calendar-hebrew-goto-date]
128
    ["Persian Date" calendar-persian-goto-date]
129
    ["Baha'i Date" calendar-bahai-goto-date]
130 131
    ["Islamic Date" calendar-islamic-goto-date]
    ["Julian Date" calendar-julian-goto-date]
132
    ["Chinese Date" calendar-chinese-goto-date]
133 134
    ["Coptic Date" calendar-coptic-goto-date]
    ["Ethiopic Date" calendar-ethiopic-goto-date]
135
    ("Mayan Date"
136 137 138 139 140 141
     ["Next Tzolkin" calendar-mayan-next-tzolkin-date]
     ["Previous Tzolkin" calendar-mayan-previous-tzolkin-date]
     ["Next Haab" calendar-mayan-next-haab-date]
     ["Previous Haab" calendar-mayan-previous-haab-date]
     ["Next Round" calendar-mayan-next-round-date]
     ["Previous Round" calendar-mayan-previous-round-date])
142
    ["French Date" calendar-french-goto-date]))
143 144 145

(defconst cal-menu-scroll-menu
  '("Scroll"
146 147
    ["Forward 1 Month" calendar-scroll-left]
    ["Forward 3 Months" calendar-scroll-left-three-months]
148
    ["Forward 1 Year" "4\C-v"]
149 150
    ["Backward 1 Month" calendar-scroll-right]
    ["Backward 3 Months" calendar-scroll-right-three-months]
151
    ["Backward 1 Year" "4\ev"]))
152

153
(defun cal-menu-x-popup-menu (position menu)
154 155
  "Like `x-popup-menu', but print an error message if popups are unavailable.
POSITION and MENU are passed to `x-popup-menu'."
156 157
  (if (display-popup-menus-p)
      (x-popup-menu position menu)
158
    (error "Popup menus are not available on this system")))
159

160 161 162
(defun cal-menu-list-holidays-year ()
  "Display a list of the holidays of the selected date's year."
  (interactive)
163
  (holiday-list (extract-calendar-year (calendar-cursor-to-date))))
164 165 166 167

(defun cal-menu-list-holidays-following-year ()
  "Display a list of the holidays of the following year."
  (interactive)
168
  (holiday-list (1+ (extract-calendar-year (calendar-cursor-to-date)))))
169 170 171 172

(defun cal-menu-list-holidays-previous-year ()
  "Display a list of the holidays of the previous year."
  (interactive)
173
  (holiday-list (1- (extract-calendar-year (calendar-cursor-to-date)))))
174

175 176 177
(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
178
ERROR is non-nil, otherwise just returns nil."
179 180
  (with-current-buffer
      (window-buffer (posn-window (event-start last-input-event)))
Richard M. Stallman's avatar
Richard M. Stallman committed
181
    (goto-char (posn-point (event-start last-input-event)))
182
    (calendar-cursor-to-date error)))
Richard M. Stallman's avatar
Richard M. Stallman committed
183

184
(defun calendar-mouse-goto-date (date)
185
  "Go to DATE in the buffer specified by `last-input-event'."
186 187 188
  (set-buffer (window-buffer (posn-window (event-start last-input-event))))
  (calendar-goto-date date))

Richard M. Stallman's avatar
Richard M. Stallman committed
189 190 191 192
(defun calendar-mouse-sunrise/sunset ()
  "Show sunrise/sunset times for mouse-selected date."
  (interactive)
  (save-excursion
193
    (calendar-mouse-goto-date (calendar-event-to-date))
Richard M. Stallman's avatar
Richard M. Stallman committed
194 195
    (calendar-sunrise-sunset)))

196 197 198 199 200 201 202
(defun cal-menu-today-holidays ()
  "Show holidays for today's date."
  (interactive)
  (save-excursion
    (calendar-cursor-to-date (calendar-current-date))
    (calendar-cursor-holidays)))

203
(autoload 'calendar-check-holidays "holidays")
204

205
(defun calendar-mouse-holidays (&optional event)
206 207
  "Pop up menu of holidays for mouse selected date.
EVENT is the event that invoked this command."
208
  (interactive "e")
209
  (let* ((date (calendar-event-to-date))
210
         (title (format "Holidays for %s" (calendar-date-string date)))
211
         (selection
212
          (cal-menu-x-popup-menu
213
           event
214
           (list title
215 216 217
                 (append (list title)
                         (or (mapcar 'list (calendar-check-holidays date))
                             '("None")))))))
218
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
219

220
(autoload 'diary-list-entries "diary-lib")
221 222
(defvar holidays-in-diary-buffer)       ; only called from calendar.el

223
(defun calendar-mouse-view-diary-entries (&optional date diary event)
224
  "Pop up menu of diary entries for mouse-selected date.
225 226 227
Use optional DATE and alternative file DIARY.  EVENT is the event
that invoked this command.  Shows holidays if `holidays-in-diary-buffer'
is non-nil."
228
  (interactive "i\ni\ne")
229
  (let* ((date (or date (calendar-event-to-date)))
230
         (diary-file (or diary diary-file))
231 232 233
         (diary-list-include-blanks nil)
         (diary-display-hook 'ignore)
         (diary-entries
234
          (mapcar (lambda (x) (split-string (cadr x) "\n"))
235
                  (diary-list-entries date 1 'list-only)))
236
         (holidays (if holidays-in-diary-buffer
237
                       (calendar-check-holidays date)))
238 239 240 241
         (title (concat "Diary entries "
                        (if diary (format "from %s " diary) "")
                        "for "
                        (calendar-date-string date)))
242
         (selection
243
          (cal-menu-x-popup-menu
244
           event
245 246 247
           (list title
                 (append
                  (list title)
248
                  (mapcar (lambda (x) (list (concat "     " x))) holidays)
249 250 251
                  (if holidays
                      (list "--shadow-etched-in" "--shadow-etched-in"))
                  (if diary-entries
252
                      (mapcar 'list (apply 'append diary-entries))
253
                    '("None")))))))
254
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
255

256
(defun calendar-mouse-view-other-diary-entries ()
257
  "Pop up menu of diary entries from alternative file on mouse-selected date."
258
  (interactive)
259 260 261
  (calendar-mouse-view-diary-entries
   (calendar-event-to-date)
   (read-file-name "Enter diary file name: " default-directory nil t)))
262

263 264 265 266
(defun calendar-mouse-insert-diary-entry ()
  "Insert diary entry for mouse-selected date."
  (interactive)
  (save-excursion
267
    (calendar-mouse-goto-date (calendar-event-to-date))
268
    (diary-insert-entry nil)))
269

270 271 272 273
(defun calendar-mouse-set-mark ()
  "Mark the date under the cursor."
  (interactive)
  (save-excursion
274
    (calendar-mouse-goto-date (calendar-event-to-date))
275 276
    (calendar-set-mark nil)))

277 278 279 280
(defun cal-tex-mouse-day ()
  "Make a buffer with LaTeX commands for the day mouse is on."
  (interactive)
  (save-excursion
281
    (calendar-mouse-goto-date (calendar-event-to-date))
282 283 284 285
    (cal-tex-cursor-day nil)))

(defun cal-tex-mouse-week ()
  "One page calendar for week indicated by cursor.
286
Holidays are included if `cal-tex-holidays' is non-nil."
287 288
  (interactive)
  (save-excursion
289
    (calendar-mouse-goto-date (calendar-event-to-date))
290 291 292 293 294 295 296
    (cal-tex-cursor-week nil)))

(defun cal-tex-mouse-week2 ()
  "Make a buffer with LaTeX commands for the week cursor is on.
The printed output will be on two pages."
  (interactive)
  (save-excursion
297
    (calendar-mouse-goto-date (calendar-event-to-date))
298 299
    (cal-tex-cursor-week2 nil)))

300
(defun cal-tex-mouse-week-iso ()
301
  "One page calendar for week indicated by cursor.
302
Holidays are included if `cal-tex-holidays' is non-nil."
303 304
  (interactive)
  (save-excursion
305
    (calendar-mouse-goto-date (calendar-event-to-date))
306
    (cal-tex-cursor-week-iso nil)))
307

308
(defun cal-tex-mouse-week-monday ()
309 310 311
  "One page calendar for week indicated by cursor."
  (interactive)
  (save-excursion
312
    (calendar-mouse-goto-date (calendar-event-to-date))
313
    (cal-tex-cursor-week-monday nil)))
314

315 316 317 318 319 320 321
(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)))

322
(defun cal-tex-mouse-filofax-2week ()
323 324 325
  "One page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
326
    (calendar-mouse-goto-date (calendar-event-to-date))
327
    (cal-tex-cursor-filofax-2week nil)))
328

329
(defun cal-tex-mouse-filofax-week ()
330 331 332
  "Two page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
333
    (calendar-mouse-goto-date (calendar-event-to-date))
334
    (cal-tex-cursor-filofax-week nil)))
335 336 337 338 339 340

(defun cal-tex-mouse-month ()
  "Make a buffer with LaTeX commands for the month cursor is on.
Calendar is condensed onto one page."
  (interactive)
  (save-excursion
341
    (calendar-mouse-goto-date (calendar-event-to-date))
342 343 344 345 346 347 348
    (cal-tex-cursor-month nil)))

(defun cal-tex-mouse-month-landscape ()
  "Make a buffer with LaTeX commands for the month cursor is on.
The output is in landscape format, one month to a page."
  (interactive)
  (save-excursion
349
    (calendar-mouse-goto-date (calendar-event-to-date))
350 351 352 353 354 355
    (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
356
    (calendar-mouse-goto-date (calendar-event-to-date))
357 358 359 360 361 362
    (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
363
    (calendar-mouse-goto-date (calendar-event-to-date))
364 365 366 367 368 369
    (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
370
    (calendar-mouse-goto-date (calendar-event-to-date))
371 372
    (cal-tex-cursor-year-landscape nil)))

373
(defun calendar-mouse-print-dates (&optional event)
374 375
  "Pop up menu of equivalent dates to mouse selected date.
EVENT is the event that invoked this command."
376 377
  (interactive "e")
  (let* ((date (calendar-event-to-date))
378 379 380 381 382 383 384 385
         (title (format "%s (Gregorian)" (calendar-date-string date)))
         (selection
          (cal-menu-x-popup-menu
           event
           (list title
                 (append (list title)
                         (mapcar 'list (calendar-other-dates date)))))))
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
386

387 388 389 390 391
(defun cal-menu-set-date-title (menu)
  "Convert date of last event to title suitable for MENU."
  (easy-menu-filter-return
   menu (calendar-date-string (calendar-event-to-date t) t nil)))

392
(easy-menu-define cal-menu-context-mouse-menu nil
393
  "Pop up menu for Mouse-2 for selected date in the calendar window."
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
  '("foo" :filter cal-menu-set-date-title
    "--"
    ["Holidays" calendar-mouse-holidays]
    ["Mark date" calendar-mouse-set-mark]
    ["Sunrise/sunset" calendar-mouse-sunrise/sunset]
    ["Other calendars" calendar-mouse-print-dates]
    ("Prepare LaTeX buffer"
     ["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"
      ["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]))
    ["Diary entries" calendar-mouse-view-diary-entries]
    ["Insert diary entry" calendar-mouse-insert-diary-entry]
    ["Other diary file entries" calendar-mouse-view-other-diary-entries]))

(easy-menu-define cal-menu-global-mouse-menu nil
  "Menu bound to a mouse event, not specific to the mouse-click location."
  '("Calendar"
422 423
    ["Scroll forward" calendar-scroll-left-three-months]
    ["Scroll backward" calendar-scroll-right-three-months]
424
    ["Mark diary entries" diary-mark-entries]
425 426
    ["List holidays" calendar-list-holidays]
    ["Mark holidays" calendar-mark-holidays]
427 428 429 430
    ["Unmark" calendar-unmark]
    ["Lunar phases" calendar-phases-of-moon]
    ["Show diary" diary-show-all-entries]
    ["Exit calendar" exit-calendar]))
Richard M. Stallman's avatar
Richard M. Stallman committed
431

432 433 434 435 436 437
;; Undocumented and probably useless.
(defvar cal-menu-load-hook nil
  "Hook run on loading of the `cal-menu' package.")
(make-obsolete-variable 'cal-menu-load-hook
                        "it will be removed in future." "23.1")

Richard M. Stallman's avatar
Richard M. Stallman committed
438 439 440 441
(run-hooks 'cal-menu-load-hook)

(provide 'cal-menu)

442
;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9
Richard M. Stallman's avatar
Richard M. Stallman committed
443
;;; cal-menu.el ends here