cal-menu.el 18.9 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:

Glenn Morris's avatar
Glenn Morris committed
36 37 38
;; The code in this file is only called from calendar.el, but can't
;; require it (to supress undefined function warnings from compiler)
;; without a recursive require.
Glenn Morris's avatar
Glenn Morris committed
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
;; All these functions are either autoloaded, or autoloaded or defined
;; in calendar.el.
(declare-function calendar-increment-month "calendar" (n &optional mon yr))
(declare-function calendar-month-name      "calendar" (month &optional abbrev))
(declare-function extract-calendar-year    "calendar" (date))
(declare-function calendar-cursor-to-date  "calendar" (&optional error))
(declare-function holiday-list             "holidays" (y1 y2 &optional l label))
(declare-function calendar-sunrise-sunset  "solar"    nil)
(declare-function calendar-current-date    "calendar" nil)
(declare-function calendar-cursor-holidays "holidays" nil)
(declare-function calendar-date-string     "calendar"
                  (date &optional abbreviate nodayname))
(declare-function insert-diary-entry       "diary-lib" (arg))
(declare-function calendar-set-mark        "calendar"  (arg))
(declare-function cal-tex-cursor-day       "cal-tex"   (&optional arg))
(declare-function cal-tex-cursor-week      "cal-tex"   (&optional arg))
(declare-function cal-tex-cursor-week2     "cal-tex"   (&optional arg))
(declare-function cal-tex-cursor-week-iso  "cal-tex"   (&optional arg))
57 58 59 60 61 62 63 64 65 66 67
(declare-function cal-tex-cursor-week-monday     "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-filofax-daily   "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-filofax-2week   "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-filofax-week    "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-month           "cal-tex"  (arg))
(declare-function cal-tex-cursor-month-landscape "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-year            "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-filofax-year    "cal-tex"  (&optional arg))
(declare-function cal-tex-cursor-year-landscape  "cal-tex"  (&optional arg))
(declare-function calendar-other-dates           "calendar" (date))
(declare-function calendar-goto-date             "cal-move" (date))
Glenn Morris's avatar
Glenn Morris committed
68

69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
(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"
     [" " nil :suffix (calendar-bahai-date-string (calendar-cursor-to-date))]
88 89 90
     ["One time" diary-bahai-insert-entry]
     ["Monthly" diary-bahai-insert-monthly-entry]
     ["Yearly" diary-bahai-insert-yearly-entry])
91 92 93 94 95 96 97 98 99 100 101 102
    ("Insert Islamic"
     [" " nil :suffix (calendar-islamic-date-string (calendar-cursor-to-date))]
     ["One time" insert-islamic-diary-entry]
     ["Monthly" insert-monthly-islamic-diary-entry]
     ["Yearly" insert-yearly-islamic-diary-entry])
    ("Insert Hebrew"
     [" " nil :suffix (calendar-hebrew-date-string (calendar-cursor-to-date))]
     ["One time" insert-hebrew-diary-entry]
     ["Monthly" insert-monthly-hebrew-diary-entry]
     ["Yearly" insert-yearly-hebrew-diary-entry])))

(defun cal-menu-holiday-window-suffix ()
103
  "Return a string suffix for the \"Window\" entry in `cal-menu-holidays-menu'."
104 105 106 107 108 109 110 111 112 113 114 115 116
  (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)))))

117 118
(defvar displayed-year)                 ; from generate-calendar

119 120 121 122 123
(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)]
124
    ["For Window -" calendar-list-holidays
125 126 127 128 129 130
     :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.
131 132
        ;; We used to use :suffix rather than :label and bumped into
        ;; an easymenu bug:
133
        ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html
134
        ;; The bug has since been fixed.
135
        (dotimes (i 11)
136
          (push (vector (format "hol-year-%d" i)
137 138 139 140
                        `(lambda ()
                           (interactive)
                           (holiday-list (+ displayed-year ,(- i 5))
                                         (+ displayed-year ,(- i 5))))
141 142
                        :label `(format "For Year %d"
                                       (+ displayed-year ,(- i 5))))
143
                l))
144 145 146 147 148 149
        (nreverse l))
    "--"
    ["Unmark Calendar" calendar-unmark]
    ["Mark Holidays" mark-calendar-holidays]))

(defconst cal-menu-goto-menu
150
  '("Go To"
151 152 153 154 155 156 157 158 159 160 161 162 163 164
    ["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]
165
    ["Baha'i Date" calendar-bahai-goto-date]
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
    ["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"
182 183
    ["Forward 1 Month" calendar-scroll-left]
    ["Forward 3 Months" calendar-scroll-left-three-months]
184
    ["Forward 1 Year" "4\C-v"]
185 186
    ["Backward 1 Month" calendar-scroll-right]
    ["Backward 3 Months" calendar-scroll-right-three-months]
187
    ["Backward 1 Year" "4\ev"]))
188

189
(defun cal-menu-x-popup-menu (position menu)
190 191
  "Like `x-popup-menu', but print an error message if popups are unavailable.
POSITION and MENU are passed to `x-popup-menu'."
192 193
  (if (display-popup-menus-p)
      (x-popup-menu position menu)
194
    (error "Popup menus are not available on this system")))
195

196 197 198 199
(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))))
200
    (holiday-list year year)))
201 202 203 204 205

(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)))))
206
    (holiday-list year year)))
207 208 209 210 211

(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)))))
212
    (holiday-list year year)))
213

214 215 216
(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
217
ERROR is non-nil, otherwise just returns nil."
218 219
  (with-current-buffer
      (window-buffer (posn-window (event-start last-input-event)))
Richard M. Stallman's avatar
Richard M. Stallman committed
220
    (goto-char (posn-point (event-start last-input-event)))
221
    (calendar-cursor-to-date error)))
Richard M. Stallman's avatar
Richard M. Stallman committed
222

223
(defun calendar-mouse-goto-date (date)
224
  "Go to DATE in the buffer specified by `last-input-event'."
225 226 227
  (set-buffer (window-buffer (posn-window (event-start last-input-event))))
  (calendar-goto-date date))

Richard M. Stallman's avatar
Richard M. Stallman committed
228 229 230 231
(defun calendar-mouse-sunrise/sunset ()
  "Show sunrise/sunset times for mouse-selected date."
  (interactive)
  (save-excursion
232
    (calendar-mouse-goto-date (calendar-event-to-date))
Richard M. Stallman's avatar
Richard M. Stallman committed
233 234
    (calendar-sunrise-sunset)))

235 236 237 238 239 240 241
(defun cal-menu-today-holidays ()
  "Show holidays for today's date."
  (interactive)
  (save-excursion
    (calendar-cursor-to-date (calendar-current-date))
    (calendar-cursor-holidays)))

242
(autoload 'calendar-check-holidays "holidays")
243 244
(autoload 'diary-list-entries "diary-lib")

245
(defun calendar-mouse-holidays (&optional event)
246 247
  "Pop up menu of holidays for mouse selected date.
EVENT is the event that invoked this command."
248
  (interactive "e")
249
  (let* ((date (calendar-event-to-date))
250
         (l (mapcar 'list (calendar-check-holidays date)))
251
         (title (format "Holidays for %s" (calendar-date-string date)))
252
         (selection
253
          (cal-menu-x-popup-menu
254
           event
255 256
           (list title
                 (append (list title) (or l '("None")))))))
257
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
258

259 260
(defvar holidays-in-diary-buffer)       ; only called from calendar.el

261
(defun calendar-mouse-view-diary-entries (&optional date diary event)
262
  "Pop up menu of diary entries for mouse-selected date.
263 264 265
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."
266
  (interactive "i\ni\ne")
267
  (let* ((date (or date (calendar-event-to-date)))
268
         (diary-file (or diary diary-file))
269 270 271
         (diary-list-include-blanks nil)
         (diary-display-hook 'ignore)
         (diary-entries
272
          (mapcar (lambda (x) (split-string (cadr x) "\n"))
273
                  (diary-list-entries date 1 'list-only)))
274
         (holidays (if holidays-in-diary-buffer
275
                       (calendar-check-holidays date)))
276 277 278 279
         (title (concat "Diary entries "
                        (if diary (format "from %s " diary) "")
                        "for "
                        (calendar-date-string date)))
280
         (selection
281
          (cal-menu-x-popup-menu
282
           event
283 284 285
           (list title
                 (append
                  (list title)
286
                  (mapcar (lambda (x) (list (concat "     " x))) holidays)
287 288 289
                  (if holidays
                      (list "--shadow-etched-in" "--shadow-etched-in"))
                  (if diary-entries
290
                      (mapcar 'list (apply 'append diary-entries))
291
                    '("None")))))))
292
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
293

294
(defun calendar-mouse-view-other-diary-entries ()
295
  "Pop up menu of diary entries from alternative file on mouse-selected date."
296
  (interactive)
297 298 299
  (calendar-mouse-view-diary-entries
   (calendar-event-to-date)
   (read-file-name "Enter diary file name: " default-directory nil t)))
300

301 302 303 304
(defun calendar-mouse-insert-diary-entry ()
  "Insert diary entry for mouse-selected date."
  (interactive)
  (save-excursion
305
    (calendar-mouse-goto-date (calendar-event-to-date))
306 307
    (insert-diary-entry nil)))

308 309 310 311
(defun calendar-mouse-set-mark ()
  "Mark the date under the cursor."
  (interactive)
  (save-excursion
312
    (calendar-mouse-goto-date (calendar-event-to-date))
313 314
    (calendar-set-mark nil)))

315 316 317 318
(defun cal-tex-mouse-day ()
  "Make a buffer with LaTeX commands for the day mouse is on."
  (interactive)
  (save-excursion
319
    (calendar-mouse-goto-date (calendar-event-to-date))
320 321 322 323
    (cal-tex-cursor-day nil)))

(defun cal-tex-mouse-week ()
  "One page calendar for week indicated by cursor.
324
Holidays are included if `cal-tex-holidays' is non-nil."
325 326
  (interactive)
  (save-excursion
327
    (calendar-mouse-goto-date (calendar-event-to-date))
328 329 330 331 332 333 334
    (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
335
    (calendar-mouse-goto-date (calendar-event-to-date))
336 337
    (cal-tex-cursor-week2 nil)))

338
(defun cal-tex-mouse-week-iso ()
339
  "One page calendar for week indicated by cursor.
340
Holidays are included if `cal-tex-holidays' is non-nil."
341 342
  (interactive)
  (save-excursion
343
    (calendar-mouse-goto-date (calendar-event-to-date))
344
    (cal-tex-cursor-week-iso nil)))
345

346
(defun cal-tex-mouse-week-monday ()
347 348 349
  "One page calendar for week indicated by cursor."
  (interactive)
  (save-excursion
350
    (calendar-mouse-goto-date (calendar-event-to-date))
351
    (cal-tex-cursor-week-monday nil)))
352

353 354 355 356 357 358 359
(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)))

360
(defun cal-tex-mouse-filofax-2week ()
361 362 363
  "One page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
364
    (calendar-mouse-goto-date (calendar-event-to-date))
365
    (cal-tex-cursor-filofax-2week nil)))
366

367
(defun cal-tex-mouse-filofax-week ()
368 369 370
  "Two page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
371
    (calendar-mouse-goto-date (calendar-event-to-date))
372
    (cal-tex-cursor-filofax-week nil)))
373 374 375 376 377 378

(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
379
    (calendar-mouse-goto-date (calendar-event-to-date))
380 381 382 383 384 385 386
    (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
387
    (calendar-mouse-goto-date (calendar-event-to-date))
388 389 390 391 392 393
    (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
394
    (calendar-mouse-goto-date (calendar-event-to-date))
395 396 397 398 399 400
    (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
401
    (calendar-mouse-goto-date (calendar-event-to-date))
402 403 404 405 406 407
    (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
408
    (calendar-mouse-goto-date (calendar-event-to-date))
409 410
    (cal-tex-cursor-year-landscape nil)))

411
(defun calendar-mouse-print-dates (&optional event)
412 413
  "Pop up menu of equivalent dates to mouse selected date.
EVENT is the event that invoked this command."
414 415
  (interactive "e")
  (let* ((date (calendar-event-to-date))
416 417 418 419 420 421 422 423
         (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
424

425 426 427 428 429
(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)))

430
(easy-menu-define cal-menu-context-mouse-menu nil
431
  "Pop up menu for Mouse-2 for selected date in the calendar window."
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459
  '("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"
460 461
    ["Scroll forward" calendar-scroll-left-three-months]
    ["Scroll backward" calendar-scroll-right-three-months]
462
    ["Mark diary entries" mark-diary-entries]
463 464
    ["List holidays" calendar-list-holidays]
    ["Mark holidays" calendar-mark-holidays]
465 466 467 468
    ["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
469

470 471 472 473 474 475
;; 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
476 477 478 479
(run-hooks 'cal-menu-load-hook)

(provide 'cal-menu)

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