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-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;;         Lara Rios <lrios@coewl.cen.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: calendar
   9 ;; Human-Keywords: calendar, popup menus, menu bar
  10 ;; Package: calendar
  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-sunmoon-menu
  36   '("Sun/Moon"
  37     ["Lunar Phases" calendar-lunar-phases]
  38     ["Sunrise/sunset for cursor date" calendar-sunrise-sunset]
  39     ["Sunrise/sunset for cursor month" calendar-sunrise-sunset-month])
  40   "Key map for \"Sun/Moon\" menu in the calendar.")
  41
  42 (defconst cal-menu-diary-menu
  43   '("Diary"
  44     ["Other File" diary-view-other-diary-entries]
  45     ["Cursor Date" diary-view-entries]
  46     ["Mark All" diary-mark-entries]
  47     ["Show All" diary-show-all-entries]
  48     ["Insert Diary Entry" diary-insert-entry]
  49     ["Insert Weekly" diary-insert-weekly-entry]
  50     ["Insert Monthly" diary-insert-monthly-entry]
  51     ["Insert Yearly" diary-insert-yearly-entry]
  52     ["Insert Anniversary" diary-insert-anniversary-entry]
  53     ["Insert Block" diary-insert-block-entry]
  54     ["Insert Cyclic" diary-insert-cyclic-entry]
  55     ("Insert Bahá'í"
  56      ["One time" diary-bahai-insert-entry]
  57      ["Monthly" diary-bahai-insert-monthly-entry]
  58      ["Yearly" diary-bahai-insert-yearly-entry])
  59     ("Insert Chinese"
  60      ["One time" diary-chinese-insert-entry]
  61      ["Monthly" diary-chinese-insert-monthly-entry]
  62      ["Yearly" diary-chinese-insert-yearly-entry]
  63      ["Anniversary" diary-chinese-insert-anniversary-entry])
  64     ("Insert Islamic"
  65      ["One time" diary-islamic-insert-entry]
  66      ["Monthly" diary-islamic-insert-monthly-entry]
  67      ["Yearly" diary-islamic-insert-yearly-entry])
  68     ("Insert Hebrew"
  69      ["One time" diary-hebrew-insert-entry]
  70      ["Monthly" diary-hebrew-insert-monthly-entry]
  71      ["Yearly" diary-hebrew-insert-yearly-entry]))
  72     "Key map for \"Diary\" menu in the calendar.")
  73
  74 (defun cal-menu-holiday-window-suffix ()
  75   "Return a string suffix for the \"Window\" entry in `cal-menu-holidays-menu'."
  76   (let ((my1 (calendar-increment-month-cons -1))
  77         (my2 (calendar-increment-month-cons 1)))
  78     ;; Mon1-Mon2, Year  or  Mon1, Year1-Mon2, Year2.
  79     (format "%s%s-%s, %d"
  80             (calendar-month-name (car my1) 'abbrev)
  81             (if (= (cdr my1) (cdr my2))
  82                 ""
  83               (format ", %d" (cdr my1)))
  84             (calendar-month-name (car my2) 'abbrev)
  85             (cdr my2))))
  86
  87 (defvar displayed-year)                 ; from calendar-generate
  88
  89 (defconst cal-menu-holidays-menu
  90   `("Holidays"
  91     ["For Cursor Date -" calendar-cursor-holidays
  92      :suffix (calendar-date-string (calendar-cursor-to-date) t t)
  93      :visible (calendar-cursor-to-date)]
  94     ["For Window -" calendar-list-holidays
  95      :suffix (cal-menu-holiday-window-suffix)]
  96     ["For Today -" (calendar-cursor-holidays (calendar-current-date))
  97      :suffix (calendar-date-string (calendar-current-date) t t)]
  98     "--"
  99     ,@(let ((l ()))
 100         ;; Show 11 years--5 before, 5 after year of middle month.
 101         ;; We used to use :suffix rather than :label and bumped into
 102         ;; an easymenu bug:
 103         ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html
 104         ;; The bug has since been fixed.
 105         (dotimes (i 11)
 106           (push (vector (format "hol-year-%d" i)
 107                         `(lambda ()
 108                            (interactive)
 109                            (holiday-list (+ displayed-year ,(- i 5))))
 110                         :label `(format "For Year %d"
 111                                        (+ displayed-year ,(- i 5))))
 112                 l))
 113         (nreverse l))
 114     "--"
 115     ["Unmark Calendar" calendar-unmark]
 116     ["Mark Holidays" calendar-mark-holidays])
 117   "Key map for \"Holidays\" menu in the calendar.")
 118
 119 (defconst cal-menu-goto-menu
 120   '("Goto"
 121     ["Today" calendar-goto-today]
 122     ["Beginning of Week" calendar-beginning-of-week]
 123     ["End of Week" calendar-end-of-week]
 124     ["Beginning of Month" calendar-beginning-of-month]
 125     ["End of Month" calendar-end-of-month]
 126     ["Beginning of Year" calendar-beginning-of-year]
 127     ["End of Year" calendar-end-of-year]
 128     ["Other Date" calendar-goto-date]
 129     ["Day of Year" calendar-goto-day-of-year]
 130     ["ISO Week" calendar-iso-goto-week]
 131     ["ISO Date" calendar-iso-goto-date]
 132     ["Astronomical Date" calendar-astro-goto-day-number]
 133     ["Hebrew Date" calendar-hebrew-goto-date]
 134     ["Persian Date" calendar-persian-goto-date]
 135     ["Bahá'í Date" calendar-bahai-goto-date]
 136     ["Islamic Date" calendar-islamic-goto-date]
 137     ["Julian Date" calendar-julian-goto-date]
 138     ["Chinese Date" calendar-chinese-goto-date]
 139     ["Coptic Date" calendar-coptic-goto-date]
 140     ["Ethiopic Date" calendar-ethiopic-goto-date]
 141     ("Mayan Date"
 142      ["Next Tzolkin" calendar-mayan-next-tzolkin-date]
 143      ["Previous Tzolkin" calendar-mayan-previous-tzolkin-date]
 144      ["Next Haab" calendar-mayan-next-haab-date]
 145      ["Previous Haab" calendar-mayan-previous-haab-date]
 146      ["Next Round" calendar-mayan-next-round-date]
 147      ["Previous Round" calendar-mayan-previous-round-date])
 148     ["French Date" calendar-french-goto-date])
 149   "Key map for \"Goto\" menu in the calendar.")
 150
 151 (defconst cal-menu-scroll-menu
 152   '("Scroll"
 153     ["Scroll Commands" nil :help "Commands that scroll the visible window"]
 154     ["Forward 1 Month" calendar-scroll-left]
 155     ["Forward 3 Months" calendar-scroll-left-three-months]
 156     ["Forward 1 Year" (calendar-scroll-left 12) :keys "4 C-v"]
 157     ["Backward 1 Month" calendar-scroll-right]
 158     ["Backward 3 Months" calendar-scroll-right-three-months]
 159     ["Backward 1 Year" (calendar-scroll-right 12) :keys "4 M-v"]
 160     "--"
 161     ["Motion Commands" nil :help "Commands that move point"]
 162     ["Forward 1 Day" calendar-forward-day]
 163     ["Forward 1 Week" calendar-forward-week]
 164     ["Forward 1 Month" calendar-forward-month]
 165     ["Forward 1 Year" calendar-forward-year]
 166     ["Backward 1 Day" calendar-backward-day]
 167     ["Backward 1 Week" calendar-backward-week]
 168     ["Backward 1 Month" calendar-backward-month]
 169     ["Backward 1 Year" calendar-backward-year])
 170   "Key map for \"Scroll\" menu in the calendar.")
 171
 172 (declare-function x-popup-menu "menu.c" (position menu))
 173
 174 (defmacro cal-menu-x-popup-menu (event title &rest body)
 175   "Call `x-popup-menu' at position EVENT, with TITLE and contents BODY.
 176 Signals an error if popups are unavailable."
 177   (declare (indent 2))
 178   `(if (display-popup-menus-p)
 179        (x-popup-menu ,event (list ,title (append (list ,title) ,@body)))
 180      (error "Popup menus are not available on this system")))
 181
 182 (autoload 'diary-list-entries "diary-lib")
 183 ;; Autoloaded in diary-lib.
 184 (declare-function calendar-check-holidays "holidays" (date))
 185
 186 (defun calendar-mouse-view-diary-entries (&optional date diary event)
 187   "Pop up menu of diary entries for mouse-selected date.
 188 Use optional DATE and alternative file DIARY.  EVENT is the event
 189 that invoked this command.  Shows holidays if `diary-show-holidays-flag'
 190 is non-nil."
 191   (interactive "i\ni\ne")
 192   (let* ((date (or date (calendar-cursor-to-date nil event)))
 193          (diary-file (or diary diary-file))
 194          (diary-list-include-blanks nil)
 195          (diary-entries (mapcar (lambda (x) (split-string (cadr x) "\n"))
 196                                 (diary-list-entries date 1 'list-only)))
 197          (holidays (if diary-show-holidays-flag
 198                        (calendar-check-holidays date)))
 199          (title (format "Diary entries%s for %s"
 200                         (if diary (format " from %s" diary) "")
 201                         (calendar-date-string date)))
 202          (selection (cal-menu-x-popup-menu event title
 203                       (mapcar (lambda (x) (list (concat "     " x))) holidays)
 204                       (if holidays
 205                           (list "--shadow-etched-in" "--shadow-etched-in"))
 206                       (if diary-entries
 207                           (mapcar 'list (apply 'append diary-entries))
 208                         '("None")))))
 209     (and selection (call-interactively selection))))
 210
 211 (defun calendar-mouse-view-other-diary-entries (&optional event)
 212   "Pop up menu of diary entries from alternative file on mouse-selected date."
 213   (interactive "e")
 214   (calendar-mouse-view-diary-entries
 215    (calendar-cursor-to-date nil event)
 216    (read-file-name "Enter diary file name: " default-directory nil t)
 217    event))
 218
 219 ;; In 22, the equivalent code gave an error when not called on a date,
 220 ;; but easymenu does not seem to allow this (?).
 221 ;; The ignore-errors is because `documentation' can end up calling
 222 ;; this in a non-calendar buffer where displayed-month is unbound.  (Bug#3862)
 223 ;; This still has issues - bug#9976, so added derived-mode-p call.
 224 (defun cal-menu-set-date-title (menu)
 225   "Convert date of last event to title suitable for MENU."
 226   (when (derived-mode-p 'calendar-mode)
 227     (let ((date (ignore-errors (calendar-cursor-to-date nil last-input-event))))
 228       (if date
 229           (easy-menu-filter-return menu (calendar-date-string date t nil))
 230         (message "Not on a date!")
 231         nil))))
 232
 233 (easy-menu-define cal-menu-context-mouse-menu nil
 234   "Pop up mouse menu for selected date in the calendar window."
 235   '("cal-menu-context-mouse-menu" :filter cal-menu-set-date-title
 236     "--"
 237     ["Holidays" calendar-cursor-holidays]
 238     ["Mark date" calendar-set-mark]
 239     ["Sunrise/sunset" calendar-sunrise-sunset]
 240     ["Other calendars" calendar-print-other-dates]
 241     ;; There was a bug (#447; fixed) with last-nonmenu-event and submenus.
 242     ;; These did not work if called without calendar window selected.
 243     ("Prepare LaTeX buffer"
 244      ["Daily (1 page)" cal-tex-cursor-day]
 245      ["Weekly (1 page, with hours)" cal-tex-cursor-week]
 246      ["Weekly (2 pages, with hours)" cal-tex-cursor-week2]
 247      ["Weekly (1 page, no hours)" cal-tex-cursor-week-iso]
 248      ["Weekly (1 page, with hours, different style)" cal-tex-cursor-week-monday]
 249      ["Weekly (2 pages, no hours)" cal-tex-cursor-week2-summary]
 250      ["Monthly" cal-tex-cursor-month]
 251      ["Monthly (landscape)" cal-tex-cursor-month-landscape]
 252      ["Yearly" cal-tex-cursor-year]
 253      ["Yearly (landscape)" cal-tex-cursor-year-landscape]
 254      ("Filofax styles"
 255       ["Filofax Daily (one-day-per-page)" cal-tex-cursor-filofax-daily]
 256       ["Filofax Weekly (2-weeks-at-a-glance)" cal-tex-cursor-filofax-2week]
 257       ["Filofax Weekly (week-at-a-glance)" cal-tex-cursor-filofax-week]
 258       ["Filofax Yearly" cal-tex-cursor-filofax-year]))
 259     ("Write HTML calendar"
 260      ["For selected month" cal-html-cursor-month]
 261      ["For selected year" cal-html-cursor-year])
 262     ["Diary entries" calendar-mouse-view-diary-entries :keys "d"]
 263     ["Insert diary entry" diary-insert-entry]
 264     ["Other diary file entries" calendar-mouse-view-other-diary-entries
 265      :keys "D"]))
 266
 267 (easy-menu-define cal-menu-global-mouse-menu nil
 268   "Menu bound to a mouse event, not specific to the mouse-click location."
 269   '("Calendar"
 270     ["Scroll forward" calendar-scroll-left-three-months]
 271     ["Scroll backward" calendar-scroll-right-three-months]
 272     ["Mark diary entries" diary-mark-entries]
 273     ["List holidays" calendar-list-holidays]
 274     ["Mark holidays" calendar-mark-holidays]
 275     ["Unmark" calendar-unmark]
 276     ["Lunar phases" calendar-lunar-phases]
 277     ["Sunrise times for month" calendar-sunrise-sunset-month]
 278     ["Show diary" diary-show-all-entries]
 279     ["Exit calendar" calendar-exit]))
 280
 281 ;; Undocumented and probably useless.
 282 (defvar cal-menu-load-hook nil
 283   "Hook run on loading of the `cal-menu' package.")
 284 (make-obsolete-variable 'cal-menu-load-hook
 285                         "it will be removed in future." "23.1")
 286
 287 (run-hooks 'cal-menu-load-hook)
 288
 289 (provide 'cal-menu)
 290
 291 ;; Local Variables:
 292 ;; coding: utf-8
 293 ;; End:
 294
 295 ;;; cal-menu.el ends here