/[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.163 by gm, Wed Mar 9 00:28:22 2005 UTC revision 1.164 by gm, Fri Mar 11 21:44:42 2005 UTC
# Line 2150  the inserted text.  Value is always t." Line 2150  the inserted text.  Value is always t."
2150            (forward-line 1))))            (forward-line 1))))
2151    t)    t)
2152    
2153    (defvar calendar-redrawing nil
2154      "Internal calendar variable, non-nil if inside redraw-calendar.")
2155    
2156  (defun redraw-calendar ()  (defun redraw-calendar ()
2157    "Redraw the calendar display, if `calendar-buffer' is live."    "Redraw the calendar display, if `calendar-buffer' is live."
2158    (interactive)    (interactive)
2159    (if (get-buffer calendar-buffer)    (if (get-buffer calendar-buffer)
2160        (save-excursion        (with-current-buffer calendar-buffer
2161          (with-current-buffer calendar-buffer          (let ((cursor-date (calendar-cursor-to-nearest-date))
2162            (let ((cursor-date (calendar-cursor-to-nearest-date)))                (calendar-redrawing t))
2163              (generate-calendar-window displayed-month displayed-year)            (generate-calendar-window displayed-month displayed-year)
2164              (calendar-cursor-to-visible-date cursor-date))))))            (calendar-cursor-to-visible-date cursor-date)))))
2165    
2166  ;;;###autoload  ;;;###autoload
2167  (defcustom calendar-week-start-day 0  (defcustom calendar-week-start-day 0
# Line 2918  MARK defaults to `diary-entry-marker'." Line 2921  MARK defaults to `diary-entry-marker'."
2921        (save-excursion        (save-excursion
2922          (set-buffer calendar-buffer)          (set-buffer calendar-buffer)
2923          (calendar-cursor-to-visible-date date)          (calendar-cursor-to-visible-date date)
2924          (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char          (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2925                          (and (listp mark) (> (length mark) 0) mark) ; attr list                          (and (listp mark) (> (length mark) 0) mark) ; attr list
2926                          (and (facep mark) mark) ; face-name                          (and (facep mark) mark) ; face-name
2927                          diary-entry-marker)))                          diary-entry-marker)))
2928            (if (facep mark)            (if (facep mark)
2929                (progn ; face or an attr-list that contained a face                (progn      ; face or an attr-list that contained a face
2930                  (overlay-put                  (overlay-put
2931                   (make-overlay (1- (point)) (1+ (point))) 'face mark))                   (make-overlay (1- (point)) (1+ (point))) 'face mark))
2932              (if (and (stringp mark)              (if (and (stringp mark)
2933                       (= (length mark) 1)) ; single-char                       (= (length mark) 1)) ; single-char
2934                  (let ((buffer-read-only nil))                  (let ((buffer-read-only nil))
2935                    (forward-char 1)                    (forward-char 1)
2936                    (delete-char 1)                    (delete-char 1)
2937                    (insert mark)                    (insert mark)
2938                    (forward-char -2))                    (forward-char -2))
2939                (let ; attr list                (let                      ; attr list
2940                    ((temp-face                    ((temp-face
2941                      (make-symbol (apply 'concat "temp-face-"                      (make-symbol (apply 'concat "temp-face-"
2942                                          (mapcar '(lambda (sym)                                          (mapcar '(lambda (sym)
2943                                                     (cond ((symbolp sym) (symbol-name sym))                                                     (cond ((symbolp sym) (symbol-name sym))
2944                                                           ((numberp sym) (int-to-string sym))                                                           ((numberp sym) (int-to-string sym))
2945                                                           (t sym))) mark))))                                                           (t sym))) mark))))
2946                     (faceinfo mark))                     (faceinfo mark))
2947                  (make-face temp-face)                  (make-face temp-face)
2948                  ;; Remove :face info from the mark, copy the face info into temp-face                  ;; Remove :face info from the mark, copy the face info into temp-face
2949                  (while (setq faceinfo (memq :face faceinfo))                  (while (setq faceinfo (memq :face faceinfo))
2950                    (copy-face (read (nth 1 faceinfo)) temp-face)                    (copy-face (read (nth 1 faceinfo)) temp-face)
2951                    (setcar faceinfo nil)                    (setcar faceinfo nil)
2952                    (setcar (cdr faceinfo) nil))                    (setcar (cdr faceinfo) nil))
2953                  (setq mark (delq nil mark))                  (setq mark (delq nil mark))
2954                  ;; Apply the font aspects                  ;; Apply the font aspects
2955                  (apply 'set-face-attribute temp-face nil mark)                  (apply 'set-face-attribute temp-face nil mark)
2956                  (overlay-put                  (overlay-put
2957                   (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))                   (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))
2958    
2959  (defun calendar-star-date ()  (defun calendar-star-date ()
2960    "Replace the date under the cursor in the calendar window with asterisks.    "Replace the date under the cursor in the calendar window with asterisks.

Legend:
Removed from v.1.163  
changed lines
  Added in v.1.164

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