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