comparison lisp/calendar/calendar.el @ 93504:9105df157c3a

(calendar-make-temp-face): New function. (mark-visible-calendar-date): Use it.

93503:a56e8caca83b

  (and
   (= (extract-calendar-month date1) (extract-calendar-month date2))
   (= (extract-calendar-day date1) (extract-calendar-day date2))
   (= (extract-calendar-year date1) (extract-calendar-year date2))))

(defun mark-visible-calendar-date (date &optional mark)
  "Mark DATE in the calendar window with MARK.
MARK is a single-character string, a list of face attributes/values, or a face.
MARK defaults to `diary-entry-marker'."
  (if (calendar-date-is-valid-p date)

           ;; Single-character mark, goes after the date.
           ((and (stringp mark) (= (length mark) 1))
            (overlay-put
             (make-overlay (1+ (point)) (+ 2 (point))) 'display mark))
           (t                           ; attr list
            (let ((temp-face
                   (make-symbol
                    (apply 'concat "temp-"
                           (mapcar (lambda (sym)
                                     (cond
                                      ((symbolp sym) (symbol-name sym))
                                      ((numberp sym) (number-to-string sym))
                                      (t sym)))
                                   mark))))
                  (faceinfo mark))
              (make-face temp-face)
              ;; Remove :face info from mark, copy the face info into temp-face.
              (while (setq faceinfo (memq :face faceinfo))
                ;; FIXME not read.
                (copy-face (read (nth 1 faceinfo)) temp-face)
                (setcar faceinfo nil)
                (setcar (cdr faceinfo) nil))
              (setq mark (delq nil mark))
              ;; Apply the font aspects.
              (apply 'set-face-attribute temp-face nil mark)
              (overlay-put
               (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))

(defun calendar-star-date ()
  "Replace the date under the cursor in the calendar window with asterisks.
You might want to add this function to `today-visible-calendar-hook'."
  (unless (catch 'found

93504:9105df157c3a

  (and
   (= (extract-calendar-month date1) (extract-calendar-month date2))
   (= (extract-calendar-day date1) (extract-calendar-day date2))
   (= (extract-calendar-year date1) (extract-calendar-year date2))))

(defun calendar-make-temp-face (attrlist)
  "Return a temporary face based on the attributes in ATTRLIST.
ATTRLIST is a list with elements of the form :face face :foreground color."
  (let ((temp-face (make-symbol
                    (mapconcat (lambda (sym)
                                 (cond
                                  ((symbolp sym) (symbol-name sym))
                                  ((numberp sym) (number-to-string sym))
                                  (t sym)))
                               attrlist "")))
        (faceinfo attrlist))
  (make-face temp-face)
  ;; Remove :face info, copy into temp-face.
  (while (setq faceinfo (memq :face faceinfo))
    ;; FIXME is there any point doing this multiple times, or could we
    ;; just take the last?
    (condition-case nil
        (copy-face (intern-soft (cadr faceinfo)) temp-face)
      (error nil))
    (setq faceinfo (cddr faceinfo)))
  (setq attrlist (delq nil attrlist))
  ;; Apply the font aspects.
  (apply 'set-face-attribute temp-face nil attrlist)
  temp-face))

(defun mark-visible-calendar-date (date &optional mark)
  "Mark DATE in the calendar window with MARK.
MARK is a single-character string, a list of face attributes/values, or a face.
MARK defaults to `diary-entry-marker'."
  (if (calendar-date-is-valid-p date)

           ;; Single-character mark, goes after the date.
           ((and (stringp mark) (= (length mark) 1))
            (overlay-put
             (make-overlay (1+ (point)) (+ 2 (point))) 'display mark))
           (t                           ; attr list
            (overlay-put
             (make-overlay (1- (point)) (1+ (point))) 'face
             (calendar-make-temp-face mark))))))))

(defun calendar-star-date ()
  "Replace the date under the cursor in the calendar window with asterisks.
You might want to add this function to `today-visible-calendar-hook'."
  (unless (catch 'found