1 |
;;; cal-menu.el --- calendar functions for menu bar and popup menu support |
;;; cal-menu.el --- calendar functions for menu bar and popup menu support |
2 |
|
|
3 |
;; Copyright (C) 1994, 1995, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1994, 1995, 2001, 2003 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> |
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> |
6 |
;; Lara Rios <lrios@coewl.cen.uiuc.edu> |
;; Lara Rios <lrios@coewl.cen.uiuc.edu> |
37 |
|
|
38 |
;;; Code: |
;;; Code: |
39 |
|
|
40 |
|
(defvar displayed-month) |
41 |
|
(defvar displayed-year) |
42 |
|
|
43 |
(eval-when-compile (require 'calendar)) |
(eval-when-compile (require 'calendar)) |
44 |
(require 'easymenu) |
(require 'easymenu) |
45 |
|
|
117 |
'("Astronomical Date" . calendar-goto-astro-day-number)) |
'("Astronomical Date" . calendar-goto-astro-day-number)) |
118 |
(define-key calendar-mode-map [menu-bar goto iso] |
(define-key calendar-mode-map [menu-bar goto iso] |
119 |
'("ISO Date" . calendar-goto-iso-date)) |
'("ISO Date" . calendar-goto-iso-date)) |
120 |
|
(define-key calendar-mode-map [menu-bar goto day-of-year] |
121 |
|
'("Day of Year" . calendar-goto-day-of-year)) |
122 |
(define-key calendar-mode-map [menu-bar goto gregorian] |
(define-key calendar-mode-map [menu-bar goto gregorian] |
123 |
'("Other Date" . calendar-goto-date)) |
'("Other Date" . calendar-goto-date)) |
124 |
(define-key calendar-mode-map [menu-bar goto end-of-year] |
(define-key calendar-mode-map [menu-bar goto end-of-year] |
166 |
(define-key calendar-mode-map [menu-bar scroll fwd-1] |
(define-key calendar-mode-map [menu-bar scroll fwd-1] |
167 |
'("Forward 1 Month" . scroll-calendar-left)) |
'("Forward 1 Month" . scroll-calendar-left)) |
168 |
|
|
169 |
|
(defun calendar-flatten (list) |
170 |
|
"Flatten LIST eliminating sublists structure; result is a list of atoms. |
171 |
|
This is the same as the preorder list of leaves in a rooted forest." |
172 |
|
(if (atom list) |
173 |
|
(list list) |
174 |
|
(if (cdr list) |
175 |
|
(append (calendar-flatten (car list)) (calendar-flatten (cdr list))) |
176 |
|
(calendar-flatten (car list))))) |
177 |
|
|
178 |
(defun cal-menu-x-popup-menu (position menu) |
(defun cal-menu-x-popup-menu (position menu) |
179 |
"Like `x-popup-menu', but prints an error message if popup menus are |
"Like `x-popup-menu', but prints an error message if popup menus are |
180 |
not available." |
not available." |
216 |
(setq l (cons ["Mark Holidays" mark-calendar-holidays t] |
(setq l (cons ["Mark Holidays" mark-calendar-holidays t] |
217 |
(cons ["Unmark Calendar" calendar-unmark t] |
(cons ["Unmark Calendar" calendar-unmark t] |
218 |
(cons ["--" '("--") t] l)))) |
(cons ["--" '("--") t] l)))) |
219 |
(easy-menu-change nil "Holidays" (nreverse l)) |
(define-key calendar-mode-map [menu-bar Holidays] |
220 |
|
(cons "Holidays" (easy-menu-create-menu "Holidays" (nreverse l)))) |
221 |
(define-key calendar-mode-map [menu-bar Holidays separator] |
(define-key calendar-mode-map [menu-bar Holidays separator] |
222 |
'("--")) |
'("--")) |
223 |
(define-key calendar-mode-map [menu-bar Holidays today] |
(define-key calendar-mode-map [menu-bar Holidays today] |
233 |
(increment-calendar-month m2 y2 1) |
(increment-calendar-month m2 y2 1) |
234 |
(if (= y1 y2) |
(if (= y1 y2) |
235 |
(format "%s-%s, %d" |
(format "%s-%s, %d" |
236 |
(calendar-month-name m1 3) |
(calendar-month-name m1 'abbrev) |
237 |
(calendar-month-name m2 3) |
(calendar-month-name m2 'abbrev) |
238 |
y2) |
y2) |
239 |
(format "%s, %d-%s, %d" |
(format "%s, %d-%s, %d" |
240 |
(calendar-month-name m1 3) |
(calendar-month-name m1 'abbrev) |
241 |
y1 |
y1 |
242 |
(calendar-month-name m2 3) |
(calendar-month-name m2 'abbrev) |
243 |
y2))))) |
y2))))) |
244 |
(define-key calendar-mode-map [menu-bar Holidays 3-month] |
(define-key calendar-mode-map [menu-bar Holidays 3-month] |
245 |
`(,(format "For Window (%s)" title) |
`(,(format "For Window (%s)" title) |
318 |
(if l l '("None"))))))) |
(if l l '("None"))))))) |
319 |
(and selection (call-interactively selection)))) |
(and selection (call-interactively selection)))) |
320 |
|
|
321 |
(defun calendar-mouse-view-diary-entries () |
(defun calendar-mouse-view-diary-entries (&optional date diary) |
322 |
"Pop up menu of diary entries for mouse selected date." |
"Pop up menu of diary entries for mouse-selected date. |
323 |
|
Use optional DATE and alternative file DIARY. |
324 |
|
|
325 |
|
Any holidays are shown if `holidays-in-diary-buffer' is t." |
326 |
(interactive) |
(interactive) |
327 |
(let* ((date (calendar-event-to-date)) |
(let* ((date (if date date (calendar-event-to-date))) |
328 |
(l (mapcar '(lambda (x) (list (car (cdr x)))) |
(diary-file (if diary diary diary-file)) |
329 |
(let ((diary-list-include-blanks nil) |
(diary-list-include-blanks nil) |
330 |
(diary-display-hook 'ignore)) |
(diary-display-hook 'ignore) |
331 |
(list-diary-entries date 1)))) |
(diary-entries |
332 |
|
(mapcar '(lambda (x) (split-string (car (cdr x)) "\^M\\|\n")) |
333 |
|
(list-diary-entries date 1))) |
334 |
|
(holidays (if holidays-in-diary-buffer |
335 |
|
(mapcar '(lambda (x) (list x)) |
336 |
|
(check-calendar-holidays date)))) |
337 |
|
(title (concat "Diary entries " |
338 |
|
(if diary (format "from %s " diary) "") |
339 |
|
"for " |
340 |
|
(calendar-date-string date))) |
341 |
(selection |
(selection |
342 |
(cal-menu-x-popup-menu |
(cal-menu-x-popup-menu |
343 |
event |
event |
344 |
(list |
(list title |
345 |
(format "Diary entries for %s" (calendar-date-string date)) |
(append |
346 |
(append |
(list title) |
347 |
(list (format "Diary entries for %s" (calendar-date-string date))) |
(if holidays |
348 |
(if l l '("None"))))))) |
(mapcar '(lambda (x) (list (concat " " (car x)))) |
349 |
|
holidays)) |
350 |
|
(if holidays |
351 |
|
(list "--shadow-etched-in" "--shadow-etched-in")) |
352 |
|
(if diary-entries |
353 |
|
(mapcar 'list (calendar-flatten diary-entries)) |
354 |
|
'("None"))))))) |
355 |
(and selection (call-interactively selection)))) |
(and selection (call-interactively selection)))) |
356 |
|
|
357 |
(defun calendar-mouse-view-other-diary-entries () |
(defun calendar-mouse-view-other-diary-entries () |
358 |
"Pop up menu of diary entries from alternative file on mouse-selected date." |
"Pop up menu of diary entries from alternative file on mouse-selected date." |
359 |
(interactive) |
(interactive) |
360 |
(let* ((date (calendar-event-to-date)) |
(calendar-mouse-view-diary-entries |
361 |
(diary-list-include-blanks nil) |
(calendar-event-to-date) |
362 |
(diary-display-hook 'ignore) |
(read-file-name "Enter diary file name: " default-directory nil t))) |
|
(diary-file (read-file-name |
|
|
"Enter diary file name: " |
|
|
default-directory nil t)) |
|
|
; The following doesn't really do the right thing. The problem is |
|
|
; that a newline in the diary entry does not give a newline in a |
|
|
; pop-up menu; for that you need a separate list item. When the (car |
|
|
; (cdr x)) contains newlines, the item should be split into a list of |
|
|
; items. Too minor and messy to worry about. |
|
|
(l (mapcar '(lambda (x) (list (car (cdr x)))) |
|
|
(list-diary-entries date 1))) |
|
|
(selection |
|
|
(cal-menu-x-popup-menu |
|
|
event |
|
|
(list |
|
|
(format "Diary entries from %s for %s" |
|
|
diary-file |
|
|
(calendar-date-string date)) |
|
|
(append |
|
|
(list (format "Diary entries from %s for %s" |
|
|
diary-file |
|
|
(calendar-date-string date))) |
|
|
(if l l '("None"))))))) |
|
|
(and selection (call-interactively selection)))) |
|
363 |
|
|
364 |
(defun calendar-mouse-insert-diary-entry () |
(defun calendar-mouse-insert-diary-entry () |
365 |
"Insert diary entry for mouse-selected date." |
"Insert diary entry for mouse-selected date." |
618 |
|
|
619 |
(provide 'cal-menu) |
(provide 'cal-menu) |
620 |
|
|
621 |
|
;;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9 |
622 |
;;; cal-menu.el ends here |
;;; cal-menu.el ends here |