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. |