/[emacs]/emacs/lisp/calendar/cal-menu.el
ViewVC logotype

Diff of /emacs/lisp/calendar/cal-menu.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.49 by pj, Wed May 1 09:46:36 2002 UTC revision 1.49.2.1 by miles, Tue Oct 14 23:42:13 2003 UTC
# Line 1  Line 1 
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>
# Line 37  Line 37 
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    
# Line 114  Line 117 
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]
# Line 161  Line 166 
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."
# Line 202  not available." Line 216  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]
# Line 218  not available." Line 233  not available."
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)
# Line 303  ERROR is t, otherwise just returns nil." Line 318  ERROR is t, otherwise just returns nil."
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."
# Line 608  The output is in landscape format, one m Line 618  The output is in landscape format, one m
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

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.49.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26