Function: diary-mark-entries-1
diary-mark-entries-1 is a byte-compiled function defined in
diary-lib.el.gz.
Signature
(diary-mark-entries-1 MARKFUNC &optional MONTHS SYMBOL ABSFUNC)
Documentation
Mark diary entries of a certain type.
MARKFUNC is a function that marks entries of the appropriate type matching a given date pattern. MONTHS is an array of month names. SYMBOL marks diary entries of the type in question. ABSFUNC is a function that converts absolute dates to dates of the appropriate type.
Source Code
;; Defined in /usr/src/emacs/lisp/calendar/diary-lib.el.gz
;; file-glob-attrs bound in diary-mark-entries.
(defun diary-mark-entries-1 (markfunc &optional months symbol absfunc)
"Mark diary entries of a certain type.
MARKFUNC is a function that marks entries of the appropriate type
matching a given date pattern. MONTHS is an array of month names.
SYMBOL marks diary entries of the type in question. ABSFUNC is a
function that converts absolute dates to dates of the appropriate type."
(calendar-dlet
((dayname (diary-name-pattern calendar-day-name-array
calendar-day-abbrev-array))
(monthname (format "%s\\|\\*"
(if months
(diary-name-pattern months)
(diary-name-pattern calendar-month-name-array
calendar-month-abbrev-array))))
(month "[0-9]+\\|\\*")
(day "[0-9]+\\|\\*")
(year "[0-9]+\\|\\*"))
(let* ((case-fold-search t)
marks)
(dolist (date-form diary-date-forms)
(if (eq (car date-form) 'backup) ; ignore 'backup directive
(setq date-form (cdr date-form)))
(let* ((l (length date-form))
(d-name-pos (- l (length (memq 'dayname date-form))))
(d-name-pos (if (/= l d-name-pos) (1+ d-name-pos)))
(m-name-pos (- l (length (memq 'monthname date-form))))
(m-name-pos (if (/= l m-name-pos) (1+ m-name-pos)))
(d-pos (- l (length (memq 'day date-form))))
(d-pos (if (/= l d-pos) (1+ d-pos)))
(m-pos (- l (length (memq 'month date-form))))
(m-pos (if (/= l m-pos) (1+ m-pos)))
(y-pos (- l (length (memq 'year date-form))))
(y-pos (if (/= l y-pos) (1+ y-pos)))
(regexp (format "^%s\\(%s\\)"
(if symbol (regexp-quote symbol) "")
(mapconcat #'eval date-form "\\)\\("))))
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let* ((dd-name
(if d-name-pos
(match-string-no-properties d-name-pos)))
(mm-name
(if m-name-pos
(match-string-no-properties m-name-pos)))
(mm (string-to-number
(if m-pos
(match-string-no-properties m-pos)
"")))
(dd (string-to-number
(if d-pos
(match-string-no-properties d-pos)
"")))
(y-str (if y-pos
(match-string-no-properties y-pos)))
(yy (if (not y-str)
0
(if (and (= (length y-str) 2)
diary-abbreviated-year-flag)
(let* ((current-y
(calendar-extract-year
(if absfunc
(funcall
absfunc
(calendar-absolute-from-gregorian
(calendar-current-date)))
(calendar-current-date))))
(y (+ (string-to-number y-str)
;; Current century, eg 2000.
(* 100 (/ current-y 100))))
(offset (- y current-y)))
;; Add 2-digit year to current century.
;; If more than 50 years in the future,
;; assume last century. If more than 50
;; years in the past, assume next century.
(if (> offset 50)
(- y 100)
(if (< offset -50)
(+ y 100)
y)))
(string-to-number y-str)))))
(setq marks (cadr (diary-pull-attrs
(buffer-substring-no-properties
(point) (line-end-position))
file-glob-attrs)))
;; Only mark all days of a given name if the pattern
;; contains no more specific elements.
(if (and dd-name (not (or d-pos m-pos y-pos)))
(calendar-mark-days-named
(cdr (assoc-string dd-name
(calendar-make-alist
calendar-day-name-array
0 nil calendar-day-abbrev-array
(mapcar (lambda (e)
(format "%s." e))
calendar-day-abbrev-array))
t))
marks)
(if mm-name
(setq mm
(if (string-equal mm-name "*") 0
(cdr (assoc-string
mm-name
(if months (calendar-make-alist months)
(calendar-make-alist
calendar-month-name-array
1 nil calendar-month-abbrev-array
(mapcar (lambda (e)
(format "%s." e))
calendar-month-abbrev-array)))
t)))))
(funcall markfunc mm dd yy marks)))))))))