/[emacs]/emacs/lisp/calendar/calendar.el
ViewVC logotype

Diff of /emacs/lisp/calendar/calendar.el

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

revision 1.140 by lektu, Wed Apr 3 14:47:16 2002 UTC revision 1.140.2.1 by miles, Fri Apr 4 06:20:15 2003 UTC
# Line 204  If nil, make an icon of the frame.  If n Line 204  If nil, make an icon of the frame.  If n
204    :type 'boolean    :type 'boolean
205    :group 'view)    :group 'view)
206    
207  (add-to-list 'facemenu-unlisted-faces 'diary-face)  (defvar diary-face 'diary-face
208      "Face name to use for diary entries.")
209  (defface diary-face  (defface diary-face
210    '((((class color) (background light))    '((((class color) (background light))
211       :foreground "red")       :foreground "red")
# Line 215  If nil, make an icon of the frame.  If n Line 216  If nil, make an icon of the frame.  If n
216    "Face for highlighting diary entries."    "Face for highlighting diary entries."
217    :group 'diary)    :group 'diary)
218    
 (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)  
219  (defface calendar-today-face  (defface calendar-today-face
220    '((t (:underline t)))    '((t (:underline t)))
221    "Face for indicating today's date."    "Face for indicating today's date."
222    :group 'diary)    :group 'diary)
223    
 (add-to-list 'facemenu-unlisted-faces 'holiday-face)  
224  (defface holiday-face  (defface holiday-face
225    '((((class color) (background light))    '((((class color) (background light))
226       :background "pink")       :background "pink")
# Line 232  If nil, make an icon of the frame.  If n Line 231  If nil, make an icon of the frame.  If n
231    "Face for indicating dates that have holidays."    "Face for indicating dates that have holidays."
232    :group 'diary)    :group 'diary)
233    
234    (eval-after-load "facemenu"
235      '(progn
236         (add-to-list 'facemenu-unlisted-faces 'diary-face)
237         (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
238         (add-to-list 'facemenu-unlisted-faces 'holiday-face)))
239    
240  (defcustom diary-entry-marker  (defcustom diary-entry-marker
241    (if (not (display-color-p))    (if (not (display-color-p))
242        "+"        "+"
# Line 305  calendar." Line 310  calendar."
310    :type 'boolean    :type 'boolean
311    :group 'holidays)    :group 'holidays)
312    
313    (defcustom diary-file-name-prefix-function (function (lambda (str) str))
314      "*The function that will take a diary file name and return the desired prefix."
315      :type 'function
316      :group 'diary)
317    
318  ;;;###autoload  ;;;###autoload
319  (defcustom calendar-load-hook nil  (defcustom calendar-load-hook nil
320    "*List of functions to be called after the calendar is first loaded.    "*List of functions to be called after the calendar is first loaded.
# Line 492  See the documentation for the function ` Line 502  See the documentation for the function `
502    :type 'string    :type 'string
503    :group 'diary)    :group 'diary)
504    
505    (defcustom diary-glob-file-regexp-prefix "^\\#"
506      "*The regular expression that gets pre-pended to each of the attribute-regexp's for file-wide specifiers."
507      :type 'regexp
508      :group 'diary)
509    
510    (defcustom diary-face-attrs '(
511                                  (" *\\[foreground:\\([-a-z]+\\)\\]$" 1 :foreground string)
512                                  (" *\\[background:\\([-a-z]+\\)\\]$" 1 :background string)
513                                  (" *\\[width:\\([-a-z]+\\)\\]$" 1 :width symbol)
514                                  (" *\\[height:\\([-0-9a-z]+\\)\\]$" 1 :height int)
515                                  (" *\\[weight:\\([-a-z]+\\)\\]$" 1 :weight symbol)
516                                  (" *\\[slant:\\([-a-z]+\\)\\]$" 1 :slant symbol)
517                                  (" *\\[underline:\\([-a-z]+\\)\\]$" 1 :underline stringtnil)
518                                  (" *\\[overline:\\([-a-z]+\\)\\]$" 1 :overline stringtnil)
519                                  (" *\\[strike-through:\\([-a-z]+\\)\\]$" 1 :strike-through stringtnil)
520                                  (" *\\[inverse-video:\\([-a-z]+\\)\\]$" 1 :inverse-video tnil)
521                                  (" *\\[face:\\([-0-9a-z]+\\)\\]$" 1 :face string)
522                                  (" *\\[font:\\([-a-z0-9]+\\)\\]$" 1 :font string)
523    ;Unsupported                          (" *\\[box:\\([-a-z]+\\)\\]$" 1 :box)
524    ;Unsupported                          (" *\\[stipple:\\([-a-z]+\\)\\]$" 1 :stipple)
525                                  )
526      "*A list of (regexp regnum attr attrtype) lists where the regexp says how to find the tag, the regnum says which parenthetical sub-regexp this regexp looks for, and the attr says which attribute of the face (or that this _is_ a face) is being modified."
527      :type 'sexp
528      :group 'diary)
529    
530    (defcustom diary-file-name-prefix nil
531      "If non-nil then each entry in the diary list will be prefixed with the name of the file in which it was defined."
532      :type 'boolean
533      :group 'diary)
534    
535  ;;;###autoload  ;;;###autoload
536  (defcustom sexp-diary-entry-symbol "%%"  (defcustom sexp-diary-entry-symbol "%%"
537    "*The string used to indicate a sexp diary entry in `diary-file'.    "*The string used to indicate a sexp diary entry in `diary-file'.
# Line 605  a portion of the first word of the diary Line 645  a portion of the first word of the diary
645  (defcustom european-calendar-display-form  (defcustom european-calendar-display-form
646    '((if dayname (concat dayname ", ")) day " " monthname " " year)    '((if dayname (concat dayname ", ")) day " " monthname " " year)
647    "*Pseudo-pattern governing the way a date appears in the European style.    "*Pseudo-pattern governing the way a date appears in the European style.
648  See the documentation of calendar-date-display-form for an explanation."  See the documentation of `calendar-date-display-form' for an explanation."
649    :type 'sexp    :type 'sexp
650    :group 'calendar)    :group 'calendar)
651    
# Line 1346  The Gregorian date Sunday, December 31, Line 1386  The Gregorian date Sunday, December 31,
1386    "Move cursor to DATE."    "Move cursor to DATE."
1387    t)    t)
1388    
1389    (autoload 'calendar-only-one-frame-setup "cal-x"
1390     "Start calendar and display it in a dedicated frame.")
1391    
1392  (autoload 'calendar-one-frame-setup "cal-x"  (autoload 'calendar-one-frame-setup "cal-x"
1393    "Start calendar and display it in a dedicated frame together with the diary.")    "Start calendar and display it in a dedicated frame together with the diary.")
1394    
# Line 1808  Or, for optional MON, YR." Line 1851  Or, for optional MON, YR."
1851        ;; Adjust the window to exactly fit the displayed calendar        ;; Adjust the window to exactly fit the displayed calendar
1852        (fit-window-to-buffer))        (fit-window-to-buffer))
1853      (sit-for 0)      (sit-for 0)
1854        (if (and (boundp 'font-lock-mode)
1855                 font-lock-mode)
1856            (font-lock-fontify-buffer))
1857      (and mark-holidays-in-calendar      (and mark-holidays-in-calendar
1858           (mark-calendar-holidays)           (mark-calendar-holidays)
1859           (sit-for 0))           (sit-for 0))
# Line 2021  the inserted text.  Value is always t." Line 2067  the inserted text.  Value is always t."
2067    (define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape))    (define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape))
2068    
2069  (defun describe-calendar-mode ()  (defun describe-calendar-mode ()
2070    "Create a help buffer with a brief description of the calendar-mode."    "Create a help buffer with a brief description of the `calendar-mode'."
2071    (interactive)    (interactive)
2072    (with-output-to-temp-buffer "*Help*"    (with-output-to-temp-buffer "*Help*"
2073      (princ      (princ
# Line 2044  the inserted text.  Value is always t." Line 2090  the inserted text.  Value is always t."
2090                  "\\<calendar-mode-map>\\[scroll-calendar-left]")                  "\\<calendar-mode-map>\\[scroll-calendar-left]")
2091                 'help-echo "mouse-2: scroll left"                 'help-echo "mouse-2: scroll left"
2092                 'keymap (make-mode-line-mouse-map 'mouse-2                 'keymap (make-mode-line-mouse-map 'mouse-2
2093                                                   #'scroll-calendar-left))                                                   'mouse-scroll-calendar-left))
2094     "Calendar"     "Calendar"
2095     (concat     (concat
2096      (propertize      (propertize
# Line 2058  the inserted text.  Value is always t." Line 2104  the inserted text.  Value is always t."
2104       "\\<calendar-mode-map>\\[calendar-other-month] other")       "\\<calendar-mode-map>\\[calendar-other-month] other")
2105       'help-echo "mouse-2: choose another month"       'help-echo "mouse-2: choose another month"
2106       'keymap (make-mode-line-mouse-map       'keymap (make-mode-line-mouse-map
2107                'mouse-2                'mouse-2 'mouse-calendar-other-month))
               (lambda ()  
                 (interactive)  
                 (call-interactively  
                  'calendar-other-month))))  
2108      "/"      "/"
2109      (propertize      (propertize
2110       (substitute-command-keys       (substitute-command-keys
# Line 2074  the inserted text.  Value is always t." Line 2116  the inserted text.  Value is always t."
2116                  "\\<calendar-mode-map>\\[scroll-calendar-right]")                  "\\<calendar-mode-map>\\[scroll-calendar-right]")
2117                 'help-echo "mouse-2: scroll right"                 'help-echo "mouse-2: scroll right"
2118                 'keymap (make-mode-line-mouse-map                 'keymap (make-mode-line-mouse-map
2119                          'mouse-2 #'scroll-calendar-right)))                          'mouse-2 'mouse-scroll-calendar-right)))
2120    "The mode line of the calendar buffer.    "The mode line of the calendar buffer.
2121    
2122  This must be a list of items that evaluate to strings--those strings are  This must be a list of items that evaluate to strings--those strings are
# Line 2102  under the cursor: Line 2144  under the cursor:
2144         \"\"))         \"\"))
2145  ")  ")
2146    
2147    (defun mouse-scroll-calendar-left (event)
2148      "Scroll the displayed calendar left by one month.
2149    Maintains the relative position of the cursor
2150    with respect to the calendar as well as possible."
2151      (interactive "e")
2152      (save-selected-window
2153        (select-window (posn-window (event-start event)))
2154        (scroll-calendar-left 1)))
2155    
2156    (defun mouse-scroll-calendar-right (event)
2157      "Scroll the displayed calendar right by one month.
2158    Maintains the relative position of the cursor
2159    with respect to the calendar as well as possible."
2160      (interactive "e")
2161      (save-selected-window
2162        (select-window (posn-window (event-start event)))
2163        (scroll-calendar-right 1)))
2164    
2165    (defun mouse-calendar-other-month (event)
2166      "Display a three-month calendar centered around a specified month and year."
2167      (interactive "e")
2168      (save-selected-window
2169        (select-window (posn-window (event-start event)))
2170        (call-interactively 'calendar-other-month)))
2171    
2172  (defun calendar-goto-info-node ()  (defun calendar-goto-info-node ()
2173    "Go to the info node for the calendar."    "Go to the info node for the calendar."
2174    (interactive)    (interactive)
# Line 2114  under the cursor: Line 2181  under the cursor:
2181          (info))          (info))
2182        (Info-find-node (car (car where)) (car (cdr (car where)))))))        (Info-find-node (car (car where)) (car (cdr (car where)))))))
2183    
2184    
2185    
2186  (defun calendar-mode ()  (defun calendar-mode ()
2187    "A major mode for the calendar window.    "A major mode for the calendar window.
2188    
# Line 2132  For a complete description, type \ Line 2201  For a complete description, type \
2201    (add-hook 'activate-menubar-hook 'cal-menu-update nil t)    (add-hook 'activate-menubar-hook 'cal-menu-update nil t)
2202    (make-local-variable 'calendar-mark-ring)    (make-local-variable 'calendar-mark-ring)
2203    (make-local-variable 'displayed-month);;  Month in middle of window.    (make-local-variable 'displayed-month);;  Month in middle of window.
2204    (make-local-variable 'displayed-year));;  Year in middle of window.    (make-local-variable 'displayed-year) ;;  Year in middle of window.
2205      (set (make-local-variable 'font-lock-defaults)
2206           '(calendar-font-lock-keywords t)))
2207    
2208  (defun calendar-string-spread (strings char length)  (defun calendar-string-spread (strings char length)
2209    "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.    "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
# Line 2426  If optional NODAY is t, does not ask for Line 2497  If optional NODAY is t, does not ask for
2497    (+ (* 12 (- yr2 yr1))    (+ (* 12 (- yr2 yr1))
2498       (- mon2 mon1)))       (- mon2 mon1)))
2499    
2500    (defvar calendar-day-name-array
2501      ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
2502      "Array of capitalized strings giving, in order, the day names.")
2503    
2504    (defvar calendar-month-name-array
2505      ["January" "February" "March"     "April"   "May"      "June"
2506       "July"    "August"   "September" "October" "November" "December"]
2507      "Array of capitalized strings giving, in order, the month names.")
2508    
2509    (defvar calendar-font-lock-keywords
2510      `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
2511                  " -?[0-9]+")
2512         . font-lock-function-name-face) ; month and year
2513        (,(regexp-opt
2514           (list (substring (aref calendar-day-name-array 6) 0 2)
2515                 (substring (aref calendar-day-name-array 0) 0 2)))
2516         ;; Saturdays and Sundays are hilited differently.
2517         . font-lock-comment-face)
2518        (,(regexp-opt (mapcar (lambda (x) (substring x 0 2)) calendar-day-name-array))
2519         . font-lock-reference-face))
2520      "Default keywords to highlight in Calendar mode.")
2521    
2522  (defun calendar-day-name (date &optional width absolute)  (defun calendar-day-name (date &optional width absolute)
2523    "Return a string with the name of the day of the week of DATE.    "Return a string with the name of the day of the week of DATE.
2524  If WIDTH is non-nil, return just the first WIDTH characters of the name.  If WIDTH is non-nil, return just the first WIDTH characters of the name.
# Line 2437  rather than a date." Line 2530  rather than a date."
2530            (enable-multibyte-characters (truncate-string-to-width string width))            (enable-multibyte-characters (truncate-string-to-width string width))
2531            (t (substring string 0 width)))))            (t (substring string 0 width)))))
2532    
 (defvar calendar-day-name-array  
   ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]  
   "Array of capitalized strings giving, in order, the day names.")  
   
 (defvar calendar-month-name-array  
   ["January" "February" "March"     "April"   "May"      "June"  
    "July"    "August"   "September" "October" "November" "December"]  
   "Array of capitalized strings giving, in order, the month names.")  
   
2533  (defun calendar-make-alist (sequence &optional start-index filter)  (defun calendar-make-alist (sequence &optional start-index filter)
2534    "Make an assoc list corresponding to SEQUENCE.    "Make an assoc list corresponding to SEQUENCE.
2535  Start at index 1, unless optional START-INDEX is provided.  Start at index 1, unless optional START-INDEX is provided.
# Line 2508  If WIDTH is non-nil, return just the fir Line 2592  If WIDTH is non-nil, return just the fir
2592    
2593  (defun mark-visible-calendar-date (date &optional mark)  (defun mark-visible-calendar-date (date &optional mark)
2594    "Mark DATE in the calendar window with MARK.    "Mark DATE in the calendar window with MARK.
2595  MARK is either a single-character string or a face.  MARK is a single-character string, a list of face attributes/values, or a face.
2596  MARK defaults to diary-entry-marker."  MARK defaults to `diary-entry-marker'."
2597    (if (calendar-date-is-legal-p date)    (if (calendar-date-is-legal-p date)
2598        (save-excursion        (save-excursion
2599          (set-buffer calendar-buffer)          (set-buffer calendar-buffer)
2600          (calendar-cursor-to-visible-date date)          (calendar-cursor-to-visible-date date)
2601          (let ((mark (or mark diary-entry-marker)))          (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2602            (if (stringp mark)                          (and (listp mark) (> (length mark) 0) mark) ; attr list
2603                (let ((buffer-read-only nil))                          (and (facep mark) mark) ; face-name
2604                  (forward-char 1)                          diary-entry-marker)))
2605                  (delete-char 1)            (if (facep mark)
2606                  (insert mark)                (progn ; face or an attr-list that contained a face
2607                  (forward-char -2))                  (overlay-put
2608              (overlay-put                   (make-overlay (1- (point)) (1+ (point))) 'face mark))
2609               (make-overlay (1- (point)) (1+ (point))) 'face mark))))))              (if (and (stringp mark)
2610                         (= (length mark) 1)) ; single-char
2611                    (let ((buffer-read-only nil))
2612                      (forward-char 1)
2613                      (delete-char 1)
2614                      (insert mark)
2615                      (forward-char -2))
2616                  (progn ; attr list
2617                    (setq temp-face
2618                          (make-symbol (apply 'concat "temp-face-"
2619                                              (mapcar '(lambda (sym)
2620                                                         (cond ((symbolp sym) (symbol-name sym))
2621                                                               ((numberp sym) (int-to-string sym))
2622                                                               (t sym))) mark))))
2623                    (make-face temp-face)
2624                    ;; Remove :face info from the mark, copy the face info into temp-face
2625                    (setq faceinfo mark)
2626                    (while (setq faceinfo (memq :face faceinfo))
2627                      (copy-face (read (nth 1 faceinfo)) temp-face)
2628                      (setcar faceinfo nil)
2629                      (setcar (cdr faceinfo) nil))
2630                    (setq mark (delq nil mark))
2631                    ;; Apply the font aspects
2632                    (apply 'set-face-attribute temp-face nil mark)
2633                    (overlay-put
2634                     (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))
2635    
2636  (defun calendar-star-date ()  (defun calendar-star-date ()
2637    "Replace the date under the cursor in the calendar window with asterisks.    "Replace the date under the cursor in the calendar window with asterisks.
# Line 2541  calendar window has been prepared." Line 2650  calendar window has been prepared."
2650    
2651  (defun calendar-mark-today ()  (defun calendar-mark-today ()
2652    "Mark the date under the cursor in the calendar window.    "Mark the date under the cursor in the calendar window.
2653  The date is marked with calendar-today-marker.  This function can be used with  The date is marked with `calendar-today-marker'.  This function can be used with
2654  the `today-visible-calendar-hook' run after the calendar window has been  the `today-visible-calendar-hook' run after the calendar window has been
2655  prepared."  prepared."
2656    (mark-visible-calendar-date    (mark-visible-calendar-date

Legend:
Removed from v.1.140  
changed lines
  Added in v.1.140.2.1

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