cal-menu.el 16.5 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 31 32 33 34 35

;;; Commentary:

;; This collection of functions implements menu bar and popup menu support for
;; calendar.el.

;;; Code:

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

38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
(defconst cal-menu-moon-menu
  '("Moon"
    ["Lunar Phases" calendar-phases-of-moon]))

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

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

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

85 86 87 88 89
(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)]
90
    ["For Window -" calendar-list-holidays
91 92 93 94 95 96
     :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.
97 98
        ;; We used to use :suffix rather than :label and bumped into
        ;; 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 104
                        `(lambda ()
                           (interactive)
105
                           (holiday-list (+ displayed-year ,(- i 5))))
106 107
                        :label `(format "For Year %d"
                                       (+ displayed-year ,(- i 5))))
108
                l))
109 110 111 112 113 114
        (nreverse l))
    "--"
    ["Unmark Calendar" calendar-unmark]
    ["Mark Holidays" mark-calendar-holidays]))

(defconst cal-menu-goto-menu
115
  '("Go To"
116 117 118 119 120 121 122 123 124 125 126 127 128 129
    ["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]
    ["ISO Week" calendar-goto-iso-week]
    ["ISO Date" calendar-goto-iso-date]
    ["Astronomical Date" calendar-goto-astro-day-number]
    ["Hebrew Date" calendar-goto-hebrew-date]
    ["Persian Date" calendar-goto-persian-date]
130
    ["Baha'i Date" calendar-bahai-goto-date]
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
    ["Islamic Date" calendar-goto-islamic-date]
    ["Julian Date" calendar-goto-julian-date]
    ["Chinese Date" calendar-goto-chinese-date]
    ["Coptic Date" calendar-goto-coptic-date]
    ["Ethiopic Date" calendar-goto-ethiopic-date]
    ("Mayan Date"
     ["Next Tzolkin" calendar-next-tzolkin-date]
     ["Previous Tzolkin" calendar-previous-tzolkin-date]
     ["Next Haab" calendar-next-haab-date]
     ["Previous Haab" calendar-previous-haab-date]
     ["Next Round" calendar-next-calendar-round-date]
     ["Previous Round" calendar-previous-calendar-round-date])
    ["French Date" calendar-goto-french-date]))

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

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

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

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

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

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

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

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

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

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

206
(defun calendar-mouse-holidays (&optional event)
207 208
  "Pop up menu of holidays for mouse selected date.
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 217 218
                 (append (list title)
                         (or (mapcar 'list (calendar-check-holidays date))
                             '("None")))))))
219
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
220

221
(autoload 'diary-list-entries "diary-lib")
222 223
(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 227 228
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."
229
  (interactive "i\ni\ne")
230
  (let* ((date (or date (calendar-event-to-date)))
231
         (diary-file (or diary diary-file))
232 233 234
         (diary-list-include-blanks nil)
         (diary-display-hook 'ignore)
         (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 240 241 242
         (title (concat "Diary entries "
                        (if diary (format "from %s " diary) "")
                        "for "
                        (calendar-date-string date)))
243
         (selection
244
          (cal-menu-x-popup-menu
245
           event
246 247 248
           (list title
                 (append
                  (list title)
249
                  (mapcar (lambda (x) (list (concat "     " x))) holidays)
250 251 252
                  (if holidays
                      (list "--shadow-etched-in" "--shadow-etched-in"))
                  (if diary-entries
253
                      (mapcar 'list (apply 'append diary-entries))
254
                    '("None")))))))
255
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
256

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 261 262
  (calendar-mouse-view-diary-entries
   (calendar-event-to-date)
   (read-file-name "Enter diary file name: " default-directory nil t)))
263

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

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

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

(defun cal-tex-mouse-week ()
  "One page calendar for week indicated by cursor.
287
Holidays are included if `cal-tex-holidays' is non-nil."
288 289
  (interactive)
  (save-excursion
290
    (calendar-mouse-goto-date (calendar-event-to-date))
291 292 293 294 295 296 297
    (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
298
    (calendar-mouse-goto-date (calendar-event-to-date))
299 300
    (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 305
  (interactive)
  (save-excursion
306
    (calendar-mouse-goto-date (calendar-event-to-date))
307
    (cal-tex-cursor-week-iso nil)))
308

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

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

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

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

(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
342
    (calendar-mouse-goto-date (calendar-event-to-date))
343 344 345 346 347 348 349
    (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
350
    (calendar-mouse-goto-date (calendar-event-to-date))
351 352 353 354 355 356
    (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
357
    (calendar-mouse-goto-date (calendar-event-to-date))
358 359 360 361 362 363
    (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
364
    (calendar-mouse-goto-date (calendar-event-to-date))
365 366 367 368 369 370
    (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
371
    (calendar-mouse-goto-date (calendar-event-to-date))
372 373
    (cal-tex-cursor-year-landscape nil)))

374
(defun calendar-mouse-print-dates (&optional event)
375 376
  "Pop up menu of equivalent dates to mouse selected date.
EVENT is the event that invoked this command."
377 378
  (interactive "e")
  (let* ((date (calendar-event-to-date))
379 380 381 382 383 384 385 386
         (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
387

388 389 390 391 392
(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)))

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 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 422
  '("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"
423 424
    ["Scroll forward" calendar-scroll-left-three-months]
    ["Scroll backward" calendar-scroll-right-three-months]
425
    ["Mark diary entries" mark-diary-entries]
426 427
    ["List holidays" calendar-list-holidays]
    ["Mark holidays" calendar-mark-holidays]
428 429 430 431
    ["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
432

433 434 435 436 437 438
;; 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
439 440 441 442
(run-hooks 'cal-menu-load-hook)

(provide 'cal-menu)

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