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