lisp/calendar/cal-menu.el

   1 ;;; cal-menu.el --- calendar functions for menu bar and popup menu support
   2
   3 ;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008  Free Software Foundation, Inc.
   5
   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
  11
  12 ;; This file is part of GNU Emacs.
  13
  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.
  18
  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.
  23
  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.
  28
  29 ;;; Commentary:
  30
  31 ;; See calendar.el.
  32
  33 ;;; Code:
  34
  35 (require 'calendar)
  36
  37 (defconst cal-menu-moon-menu
  38   '("Moon"
  39     ["Lunar Phases" calendar-phases-of-moon]))
  40
  41 (defconst cal-menu-diary-menu
  42   '("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     ["Insert Diary Entry" diary-insert-entry]
  48     ["Insert Weekly" diary-insert-weekly-entry]
  49     ["Insert Monthly" diary-insert-monthly-entry]
  50     ["Insert Yearly" diary-insert-yearly-entry]
  51     ["Insert Anniversary" diary-insert-anniversary-entry]
  52     ["Insert Block" diary-insert-block-entry]
  53     ["Insert Cyclic" diary-insert-cyclic-entry]
  54     ("Insert Baha'i"
  55      ["One time" diary-bahai-insert-entry]
  56      ["Monthly" diary-bahai-insert-monthly-entry]
  57      ["Yearly" diary-bahai-insert-yearly-entry])
  58     ("Insert Islamic"
  59      ["One time" diary-islamic-insert-entry]
  60      ["Monthly" diary-islamic-insert-monthly-entry]
  61      ["Yearly" diary-islamic-insert-yearly-entry])
  62     ("Insert Hebrew"
  63      ["One time" diary-hebrew-insert-entry]
  64      ["Monthly" diary-hebrew--insert-monthly-entry]
  65      ["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   (let ((my1 (calendar-increment-month -1))
  70         (my2 (calendar-increment-month 1)))
  71     (if (= (cdr my1) (cdr my2))
  72         (format "%s-%s, %d"
  73                 (calendar-month-name (car my1) 'abbrev)
  74                 (calendar-month-name (car my2) 'abbrev)
  75                 (cdr my2))
  76       (format "%s, %d-%s, %d"
  77               (calendar-month-name (car my1) 'abbrev)
  78               (cdr my1)
  79               (calendar-month-name (car my2) 'abbrev)
  80               (cdr my2)))))
  81
  82 (defvar displayed-year)                 ; from generate-calendar
  83
  84 (defconst cal-menu-holidays-menu
  85   `("Holidays"
  86     ["For Cursor Date -" calendar-cursor-holidays
  87      :suffix (calendar-date-string (calendar-cursor-to-date) t t)
  88      :visible (calendar-cursor-to-date)]
  89     ["For Window -" calendar-list-holidays
  90      :suffix (cal-menu-holiday-window-suffix)]
  91     ["For Today -" cal-menu-today-holidays
  92      :suffix (calendar-date-string (calendar-current-date) t t)]
  93     "--"
  94     ,@(let ((l ()))
  95         ;; Show 11 years--5 before, 5 after year of middle month.
  96         ;; We used to use :suffix rather than :label and bumped into
  97         ;; 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                         `(lambda ()
 103                            (interactive)
 104                            (holiday-list (+ displayed-year ,(- i 5))))
 105                         :label `(format "For Year %d"
 106                                        (+ displayed-year ,(- i 5))))
 107                 l))
 108         (nreverse l))
 109     "--"
 110     ["Unmark Calendar" calendar-unmark]
 111     ["Mark Holidays" calendar-mark-holidays]))
 112
 113 (defconst cal-menu-goto-menu
 114   '("Go To"
 115     ["Today" calendar-goto-today]
 116     ["Beginning of Week" calendar-beginning-of-week]
 117     ["End of Week" calendar-end-of-week]
 118     ["Beginning of Month" calendar-beginning-of-month]
 119     ["End of Month" calendar-end-of-month]
 120     ["Beginning of Year" calendar-beginning-of-year]
 121     ["End of Year" calendar-end-of-year]
 122     ["Other Date" calendar-goto-date]
 123     ["Day of Year" calendar-goto-day-of-year]
 124     ["ISO Week" calendar-iso-goto-week]
 125     ["ISO Date" calendar-iso-goto-date]
 126     ["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     ["Islamic Date" calendar-islamic-goto-date]
 131     ["Julian Date" calendar-julian-goto-date]
 132     ["Chinese Date" calendar-chinese-goto-date]
 133     ["Coptic Date" calendar-coptic-goto-date]
 134     ["Ethiopic Date" calendar-ethiopic-goto-date]
 135     ("Mayan Date"
 136      ["Next Tzolkin" calendar-mayan-next-tzolkin-date]
 137      ["Previous Tzolkin" calendar-mayan-previous-tzolkin-date]
 138      ["Next Haab" calendar-mayan-next-haab-date]
 139      ["Previous Haab" calendar-mayan-previous-haab-date]
 140      ["Next Round" calendar-mayan-next-round-date]
 141      ["Previous Round" calendar-mayan-previous-round-date])
 142     ["French Date" calendar-french-goto-date]))
 143
 144 (defconst cal-menu-scroll-menu
 145   '("Scroll"
 146     ["Forward 1 Month" calendar-scroll-left]
 147     ["Forward 3 Months" calendar-scroll-left-three-months]
 148     ["Forward 1 Year" "4\C-v"]
 149     ["Backward 1 Month" calendar-scroll-right]
 150     ["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   "Like `x-popup-menu', but print an error message if popups are unavailable.
 155 POSITION and MENU are passed to `x-popup-menu'."
 156   (if (display-popup-menus-p)
 157       (x-popup-menu position menu)
 158     (error "Popup menus are not available on this system")))
 159
 160 (defun cal-menu-list-holidays-year ()
 161   "Display a list of the holidays of the selected date's year."
 162   (interactive)
 163   (holiday-list (extract-calendar-year (calendar-cursor-to-date))))
 164
 165 (defun cal-menu-list-holidays-following-year ()
 166   "Display a list of the holidays of the following year."
 167   (interactive)
 168   (holiday-list (1+ (extract-calendar-year (calendar-cursor-to-date)))))
 169
 170 (defun cal-menu-list-holidays-previous-year ()
 171   "Display a list of the holidays of the previous year."
 172   (interactive)
 173   (holiday-list (1- (extract-calendar-year (calendar-cursor-to-date)))))
 174
 175 (defun calendar-event-to-date (&optional error)
 176   "Date of last event.
 177 If event is not on a specific date, signals an error if optional parameter
 178 ERROR is non-nil, otherwise just returns nil."
 179   (with-current-buffer
 180       (window-buffer (posn-window (event-start last-input-event)))
 181     (goto-char (posn-point (event-start last-input-event)))
 182     (calendar-cursor-to-date error)))
 183
 184 (defun calendar-mouse-goto-date (date)
 185   "Go to DATE in the buffer specified by `last-input-event'."
 186   (set-buffer (window-buffer (posn-window (event-start last-input-event))))
 187   (calendar-goto-date date))
 188
 189 (defun calendar-mouse-sunrise/sunset ()
 190   "Show sunrise/sunset times for mouse-selected date."
 191   (interactive)
 192   (save-excursion
 193     (calendar-mouse-goto-date (calendar-event-to-date))
 194     (calendar-sunrise-sunset)))
 195
 196 (defun cal-menu-today-holidays ()
 197   "Show holidays for today's date."
 198   (interactive)
 199   (save-excursion
 200     (calendar-cursor-to-date (calendar-current-date))
 201     (calendar-cursor-holidays)))
 202
 203 (autoload 'calendar-check-holidays "holidays")
 204
 205 (defun calendar-mouse-holidays (&optional event)
 206   "Pop up menu of holidays for mouse selected date.
 207 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                  (append (list title)
 216                          (or (mapcar 'list (calendar-check-holidays date))
 217                              '("None")))))))
 218     (and selection (call-interactively selection))))
 219
 220 (autoload 'diary-list-entries "diary-lib")
 221 (defvar holidays-in-diary-buffer)       ; only called from calendar.el
 222
 223 (defun calendar-mouse-view-diary-entries (&optional date diary event)
 224   "Pop up menu of diary entries for mouse-selected date.
 225 Use optional DATE and alternative file DIARY.  EVENT is the event
 226 that invoked this command.  Shows holidays if `holidays-in-diary-buffer'
 227 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          (diary-list-include-blanks nil)
 232          (diary-display-hook 'ignore)
 233          (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          (title (concat "Diary entries "
 239                         (if diary (format "from %s " diary) "")
 240                         "for "
 241                         (calendar-date-string date)))
 242          (selection
 243           (cal-menu-x-popup-menu
 244            event
 245            (list title
 246                  (append
 247                   (list title)
 248                   (mapcar (lambda (x) (list (concat "     " x))) holidays)
 249                   (if holidays
 250                       (list "--shadow-etched-in" "--shadow-etched-in"))
 251                   (if diary-entries
 252                       (mapcar 'list (apply 'append diary-entries))
 253                     '("None")))))))
 254     (and selection (call-interactively selection))))
 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   (calendar-mouse-view-diary-entries
 260    (calendar-event-to-date)
 261    (read-file-name "Enter diary file name: " default-directory nil t)))
 262
 263 (defun calendar-mouse-insert-diary-entry ()
 264   "Insert diary entry for mouse-selected date."
 265   (interactive)
 266   (save-excursion
 267     (calendar-mouse-goto-date (calendar-event-to-date))
 268     (diary-insert-entry nil)))
 269
 270 (defun calendar-mouse-set-mark ()
 271   "Mark the date under the cursor."
 272   (interactive)
 273   (save-excursion
 274     (calendar-mouse-goto-date (calendar-event-to-date))
 275     (calendar-set-mark nil)))
 276
 277 (defun cal-tex-mouse-day ()
 278   "Make a buffer with LaTeX commands for the day mouse is on."
 279   (interactive)
 280   (save-excursion
 281     (calendar-mouse-goto-date (calendar-event-to-date))
 282     (cal-tex-cursor-day nil)))
 283
 284 (defun cal-tex-mouse-week ()
 285   "One page calendar for week indicated by cursor.
 286 Holidays are included if `cal-tex-holidays' is non-nil."
 287   (interactive)
 288   (save-excursion
 289     (calendar-mouse-goto-date (calendar-event-to-date))
 290     (cal-tex-cursor-week nil)))
 291
 292 (defun cal-tex-mouse-week2 ()
 293   "Make a buffer with LaTeX commands for the week cursor is on.
 294 The printed output will be on two pages."
 295   (interactive)
 296   (save-excursion
 297     (calendar-mouse-goto-date (calendar-event-to-date))
 298     (cal-tex-cursor-week2 nil)))
 299
 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   (interactive)
 304   (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   "One page calendar for week indicated by cursor."
 310   (interactive)
 311   (save-excursion
 312     (calendar-mouse-goto-date (calendar-event-to-date))
 313     (cal-tex-cursor-week-monday nil)))
 314
 315 (defun cal-tex-mouse-filofax-daily ()
 316   "Day-per-page Filofax calendar for week indicated by cursor."
 317   (interactive)
 318   (save-excursion
 319     (calendar-mouse-goto-date (calendar-event-to-date))
 320     (cal-tex-cursor-filofax-daily nil)))
 321
 322 (defun cal-tex-mouse-filofax-2week ()
 323   "One page Filofax calendar for week indicated by cursor."
 324   (interactive)
 325   (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   "Two page Filofax calendar for week indicated by cursor."
 331   (interactive)
 332   (save-excursion
 333     (calendar-mouse-goto-date (calendar-event-to-date))
 334     (cal-tex-cursor-filofax-week nil)))
 335
 336 (defun cal-tex-mouse-month ()
 337   "Make a buffer with LaTeX commands for the month cursor is on.
 338 Calendar is condensed onto one page."
 339   (interactive)
 340   (save-excursion
 341     (calendar-mouse-goto-date (calendar-event-to-date))
 342     (cal-tex-cursor-month nil)))
 343
 344 (defun cal-tex-mouse-month-landscape ()
 345   "Make a buffer with LaTeX commands for the month cursor is on.
 346 The output is in landscape format, one month to a page."
 347   (interactive)
 348   (save-excursion
 349     (calendar-mouse-goto-date (calendar-event-to-date))
 350     (cal-tex-cursor-month-landscape nil)))
 351
 352 (defun cal-tex-mouse-year ()
 353   "Make a buffer with LaTeX commands for the year cursor is on."
 354   (interactive)
 355   (save-excursion
 356     (calendar-mouse-goto-date (calendar-event-to-date))
 357     (cal-tex-cursor-year nil)))
 358
 359 (defun cal-tex-mouse-filofax-year ()
 360   "Make a buffer with LaTeX commands for Filofax calendar of year cursor is on."
 361   (interactive)
 362   (save-excursion
 363     (calendar-mouse-goto-date (calendar-event-to-date))
 364     (cal-tex-cursor-filofax-year nil)))
 365
 366 (defun cal-tex-mouse-year-landscape ()
 367   "Make a buffer with LaTeX commands for the year cursor is on."
 368   (interactive)
 369   (save-excursion
 370     (calendar-mouse-goto-date (calendar-event-to-date))
 371     (cal-tex-cursor-year-landscape nil)))
 372
 373 (defun calendar-mouse-print-dates (&optional event)
 374   "Pop up menu of equivalent dates to mouse selected date.
 375 EVENT is the event that invoked this command."
 376   (interactive "e")
 377   (let* ((date (calendar-event-to-date))
 378          (title (format "%s (Gregorian)" (calendar-date-string date)))
 379          (selection
 380           (cal-menu-x-popup-menu
 381            event
 382            (list title
 383                  (append (list title)
 384                          (mapcar 'list (calendar-other-dates date)))))))
 385     (and selection (call-interactively selection))))
 386
 387 (defun cal-menu-set-date-title (menu)
 388   "Convert date of last event to title suitable for MENU."
 389   (easy-menu-filter-return
 390    menu (calendar-date-string (calendar-event-to-date t) t nil)))
 391
 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   '("foo" :filter cal-menu-set-date-title
 395     "--"
 396     ["Holidays" calendar-mouse-holidays]
 397     ["Mark date" calendar-mouse-set-mark]
 398     ["Sunrise/sunset" calendar-mouse-sunrise/sunset]
 399     ["Other calendars" calendar-mouse-print-dates]
 400     ("Prepare LaTeX buffer"
 401      ["Daily (1 page)" cal-tex-mouse-day]
 402      ["Weekly (1 page)" cal-tex-mouse-week]
 403      ["Weekly (2 pages)" cal-tex-mouse-week2]
 404      ["Weekly (other style; 1 page)" cal-tex-mouse-week-iso]
 405      ["Weekly (yet another style; 1 page)" cal-tex-mouse-week-monday]
 406      ["Monthly" cal-tex-mouse-month]
 407      ["Monthly (landscape)" cal-tex-mouse-month-landscape]
 408      ["Yearly" cal-tex-mouse-year]
 409      ["Yearly (landscape)" cal-tex-mouse-year-landscape]
 410      ("Filofax styles"
 411       ["Filofax Daily (one-day-per-page)" cal-tex-mouse-filofax-daily]
 412       ["Filofax Weekly (2-weeks-at-a-glance)" cal-tex-mouse-filofax-2week]
 413       ["Filofax Weekly (week-at-a-glance)" cal-tex-mouse-filofax-week]
 414       ["Filofax Yearly" cal-tex-mouse-filofax-year]))
 415     ["Diary entries" calendar-mouse-view-diary-entries]
 416     ["Insert diary entry" calendar-mouse-insert-diary-entry]
 417     ["Other diary file entries" calendar-mouse-view-other-diary-entries]))
 418
 419 (easy-menu-define cal-menu-global-mouse-menu nil
 420   "Menu bound to a mouse event, not specific to the mouse-click location."
 421   '("Calendar"
 422     ["Scroll forward" calendar-scroll-left-three-months]
 423     ["Scroll backward" calendar-scroll-right-three-months]
 424     ["Mark diary entries" diary-mark-entries]
 425     ["List holidays" calendar-list-holidays]
 426     ["Mark holidays" calendar-mark-holidays]
 427     ["Unmark" calendar-unmark]
 428     ["Lunar phases" calendar-phases-of-moon]
 429     ["Show diary" diary-show-all-entries]
 430     ["Exit calendar" exit-calendar]))
 431
 432 ;; Undocumented and probably useless.
 433 (defvar cal-menu-load-hook nil
 434   "Hook run on loading of the `cal-menu' package.")
 435 (make-obsolete-variable 'cal-menu-load-hook
 436                         "it will be removed in future." "23.1")
 437
 438 (run-hooks 'cal-menu-load-hook)
 439
 440 (provide 'cal-menu)
 441
 442 ;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9
 443 ;;; cal-menu.el ends here