/[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.176 by monnier, Mon Sep 12 21:31:17 2005 UTC revision 1.177 by monnier, Mon Sep 19 17:41:19 2005 UTC
# Line 2900  interpreted as BC; -1 being 1 BC, and so Line 2900  interpreted as BC; -1 being 1 BC, and so
2900  MARK is a single-character string, a list of face attributes/values, or a face.  MARK is a single-character string, a list of face attributes/values, or a face.
2901  MARK defaults to `diary-entry-marker'."  MARK defaults to `diary-entry-marker'."
2902    (if (calendar-date-is-legal-p date)    (if (calendar-date-is-legal-p date)
2903        (save-excursion        (with-current-buffer calendar-buffer
2904          (set-buffer calendar-buffer)          (save-excursion
2905          (calendar-cursor-to-visible-date date)            (calendar-cursor-to-visible-date date)
2906          (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char            (setq mark
2907                          (and (listp mark) (> (length mark) 0) mark) ; attr list                  (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2908                          (and (facep mark) mark) ; face-name                      (and (listp mark) (> (length mark) 0) mark)   ; attr list
2909                          diary-entry-marker)))                      (and (facep mark) mark)                       ; face-name
2910            (if (facep mark)                      diary-entry-marker))
2911                (progn      ; face or an attr-list that contained a face            (cond
2912                  (overlay-put             ;; face or an attr-list that contained a face
2913                   (make-overlay (1- (point)) (1+ (point))) 'face mark))             ((facep mark)
2914              (if (and (stringp mark)              (overlay-put
2915                       (= (length mark) 1)) ; single-char               (make-overlay (1- (point)) (1+ (point))) 'face mark))
2916                  (let ((buffer-read-only nil))             ;; single-char
2917                    (forward-char 1)             ((and (stringp mark) (= (length mark) 1))
2918                    (delete-char 1)              (let ((inhibit-read-only t))
2919                    (insert mark)                (forward-char 1)
2920                    (forward-char -2))                ;; Insert before delete so as to better preserve markers.
2921                (let                      ; attr list                (insert mark)
2922                    ((temp-face                (delete-char 1)
2923                      (make-symbol (apply 'concat "temp-"                (forward-char -2)))
2924                                          (mapcar '(lambda (sym)             (t ;; attr list
2925                                                     (cond ((symbolp sym) (symbol-name sym))              (let ((temp-face
2926                                                           ((numberp sym) (int-to-string sym))                     (make-symbol
2927                                                           (t sym))) mark))))                      (apply 'concat "temp-"
2928                     (faceinfo mark))                             (mapcar (lambda (sym)
2929                  (make-face temp-face)                                       (cond
2930                  ;; Remove :face info from the mark, copy the face info into temp-face                                        ((symbolp sym) (symbol-name sym))
2931                  (while (setq faceinfo (memq :face faceinfo))                                        ((numberp sym) (number-to-string sym))
2932                    (copy-face (read (nth 1 faceinfo)) temp-face)                                        (t sym)))
2933                    (setcar faceinfo nil)                                     mark))))
2934                    (setcar (cdr faceinfo) nil))                    (faceinfo mark))
2935                  (setq mark (delq nil mark))                (make-face temp-face)
2936                  ;; Apply the font aspects                ;; Remove :face info from the mark, copy the face info into
2937                  (apply 'set-face-attribute temp-face nil mark)                ;; temp-face
2938                  (overlay-put                (while (setq faceinfo (memq :face faceinfo))
2939                   (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))                  (copy-face (read (nth 1 faceinfo)) temp-face)
2940                    (setcar faceinfo nil)
2941                    (setcar (cdr faceinfo) nil))
2942                  (setq mark (delq nil mark))
2943                  ;; Apply the font aspects
2944                  (apply 'set-face-attribute temp-face nil mark)
2945                  (overlay-put
2946                   (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))
2947    
2948  (defun calendar-star-date ()  (defun calendar-star-date ()
2949    "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.176  
changed lines
  Added in v.1.177

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