Commit 1aee45ed authored by Stefan Monnier's avatar Stefan Monnier

Use overlays rather than selective-display.

(diary-selective-display): New var.
(diary-header-line-format): Use it.
(diary-list-entries): Add argument `list-only'.
Put the buffer in diary-mode.  Don't add \^M at beg and end.
Replace \^M by invisible overlays.
(diary-unhide-everything): Replace \^M by invisible overlays.
(print-diary-entries): Look for overlays rather than \^M.
Add a space to the temp buffer name.
(diary-show-all-entries, mark-diary-entries, make-diary-entry):
Put the buffer in diary-mode.
(list-sexp-diary-entries): Replace \^M by invisible overlays.
(diary-anniversary): Make the year arg optional.
(diary-time-regexp): New const.
(diary-font-lock-keywords): Use it to accept a few more time formats.
parent 7a34e7b1
...@@ -271,20 +271,22 @@ search." ...@@ -271,20 +271,22 @@ search."
;; This can be removed once the kill/yank treatment of invisible text ;; This can be removed once the kill/yank treatment of invisible text
;; (see etc/TODO) is fixed. -- gm ;; (see etc/TODO) is fixed. -- gm
(defcustom diary-header-line-flag t (defcustom diary-header-line-flag t
"*If non-nil, `simple-diary-display' will show a header line. "If non-nil, `diary-simple-display' will show a header line.
The format of the header is specified by `diary-header-line-format'." The format of the header is specified by `diary-header-line-format'."
:group 'diary :group 'diary
:type 'boolean :type 'boolean
:version "22.1") :version "22.1")
(defvar diary-selective-display nil)
(defcustom diary-header-line-format (defcustom diary-header-line-format
'(:eval (calendar-string-spread '(:eval (calendar-string-spread
(list (if selective-display (list (if diary-selective-display
"Selective display active - press \"s\" in calendar \ "Selective display active - press \"s\" in calendar \
before edit/copy" before edit/copy"
"Diary")) "Diary"))
?\s (frame-width))) ?\s (frame-width)))
"*Format of the header line displayed by `simple-diary-display'. "Format of the header line displayed by `diary-simple-display'.
Only used if `diary-header-line-flag' is non-nil." Only used if `diary-header-line-flag' is non-nil."
:group 'diary :group 'diary
:type 'sexp :type 'sexp
...@@ -322,17 +324,17 @@ number of days of diary entries displayed." ...@@ -322,17 +324,17 @@ number of days of diary entries displayed."
:group 'diary) :group 'diary)
(define-obsolete-function-alias 'list-diary-entries 'diary-list-entries) (define-obsolete-function-alias 'list-diary-entries 'diary-list-entries)
(defun diary-list-entries (date number) (defun diary-list-entries (date number &optional list-only)
"Create and display a buffer containing the relevant lines in `diary-file'. "Create and display a buffer containing the relevant lines in `diary-file'.
The arguments are DATE and NUMBER; the entries selected are those The arguments are DATE and NUMBER; the entries selected are those
for NUMBER days starting with date DATE. The other entries are hidden for NUMBER days starting with date DATE. The other entries are hidden
using selective display. If NUMBER is less than 1, this function does nothing. using selective display. If NUMBER is less than 1, this function does nothing.
Returns a list of all relevant diary entries found, if any, in order by date. Returns a list of all relevant diary entries found, if any, in order by date.
The list entries have the form ((month day year) string specifier) where The list entries have the form ((MONTH DAY YEAR) STRING SPECIFIER) where
\(month day year) is the date of the entry, string is the entry text, and \(MONTH DAY YEAR) is the date of the entry, STRING is the entry text, and
specifier is the applicability. If the variable `diary-list-include-blanks' SPECIFIER is the applicability. If the variable `diary-list-include-blanks'
is t, this list includes a dummy diary entry consisting of the empty string) is t, this list includes a dummy diary entry consisting of the empty string
for a date with no diary entries. for a date with no diary entries.
After the list is prepared, the hooks `nongregorian-diary-listing-hook', After the list is prepared, the hooks `nongregorian-diary-listing-hook',
...@@ -354,7 +356,9 @@ These hooks have the following distinct roles: ...@@ -354,7 +356,9 @@ These hooks have the following distinct roles:
add-hook to set this to ignore. add-hook to set this to ignore.
`diary-hook' is run last. This can be used for an appointment `diary-hook' is run last. This can be used for an appointment
notification function." notification function.
If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
(unless number (unless number
(setq number (if (vectorp number-of-diary-entries) (setq number (if (vectorp number-of-diary-entries)
(aref number-of-diary-entries (calendar-day-of-week date)) (aref number-of-diary-entries (calendar-day-of-week date))
...@@ -373,29 +377,20 @@ These hooks have the following distinct roles: ...@@ -373,29 +377,20 @@ These hooks have the following distinct roles:
(set-buffer diary-buffer) (set-buffer diary-buffer)
(or (verify-visited-file-modtime diary-buffer) (or (verify-visited-file-modtime diary-buffer)
(revert-buffer t t)))) (revert-buffer t t))))
;; Setup things like the header-line-format and invisibility-spec.
(when (eq major-mode 'fundamental-mode) (diary-mode))
;; d-s-p is passed to the diary display function. ;; d-s-p is passed to the diary display function.
(let ((diary-saved-point (point))) (let ((diary-saved-point (point)))
(save-excursion (save-excursion
(setq file-glob-attrs (nth 1 (diary-pull-attrs nil ""))) (setq file-glob-attrs (nth 1 (diary-pull-attrs nil "")))
(setq selective-display t)
(setq selective-display-ellipses nil)
(if diary-header-line-flag
(setq header-line-format diary-header-line-format))
(with-syntax-table diary-syntax-table (with-syntax-table diary-syntax-table
(let ((buffer-read-only nil) (let ((mark (regexp-quote diary-nonmarking-symbol)))
(diary-modified (buffer-modified-p))
(mark (regexp-quote diary-nonmarking-symbol)))
;; First and last characters must be ^M or \n for
;; selective display to work properly
(goto-char (1- (point-max)))
(if (not (looking-at "\^M\\|\n"))
(progn
(goto-char (point-max))
(insert "\^M")))
(goto-char (point-min)) (goto-char (point-min))
(if (not (looking-at "\^M\\|\n")) (unless list-only
(insert "\^M")) (let ((ol (make-overlay (point-min) (point-max) nil t nil)))
(subst-char-in-region (point-min) (point-max) ?\n ?\^M t) (set (make-local-variable 'diary-selective-display) t)
(overlay-put ol 'invisible 'diary)
(overlay-put ol 'evaporate t)))
(calendar-for-loop (calendar-for-loop
i from 1 to number do i from 1 to number do
(let ((month (extract-calendar-month date)) (let ((month (extract-calendar-month date))
...@@ -426,7 +421,7 @@ These hooks have the following distinct roles: ...@@ -426,7 +421,7 @@ These hooks have the following distinct roles:
(regexp (regexp
(concat (concat
"\\(\\`\\|\^M\\|\n\\)" mark "?\\(" "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
(mapconcat 'eval date-form "\\)\\(") (mapconcat 'eval date-form "\\)\\(?:")
"\\)")) "\\)"))
(case-fold-search t)) (case-fold-search t))
(goto-char (point-min)) (goto-char (point-min))
...@@ -448,8 +443,9 @@ These hooks have the following distinct roles: ...@@ -448,8 +443,9 @@ These hooks have the following distinct roles:
(while (looking-at " \\|\^I") (while (looking-at " \\|\^I")
(re-search-forward "\^M\\|\n" nil t)) (re-search-forward "\^M\\|\n" nil t))
(backward-char 1) (backward-char 1)
(subst-char-in-region date-start (unless list-only
(point) ?\^M ?\n t) (remove-overlays date-start (point)
'invisible 'diary))
(setq entry (buffer-substring entry-start (point)) (setq entry (buffer-substring entry-start (point))
temp (diary-pull-attrs entry file-glob-attrs) temp (diary-pull-attrs entry file-glob-attrs)
entry (nth 0 temp)) entry (nth 0 temp))
...@@ -467,23 +463,20 @@ These hooks have the following distinct roles: ...@@ -467,23 +463,20 @@ These hooks have the following distinct roles:
(setq date (setq date
(calendar-gregorian-from-absolute (calendar-gregorian-from-absolute
(1+ (calendar-absolute-from-gregorian date)))) (1+ (calendar-absolute-from-gregorian date))))
(setq entry-found nil))) (setq entry-found nil)))))
(set-buffer-modified-p diary-modified)))
(goto-char (point-min)) (goto-char (point-min))
(run-hooks 'nongregorian-diary-listing-hook (run-hooks 'nongregorian-diary-listing-hook
'list-diary-entries-hook) 'list-diary-entries-hook)
(if diary-display-hook (unless list-only
(run-hooks 'diary-display-hook) (if diary-display-hook
(simple-diary-display)) (run-hooks 'diary-display-hook)
(simple-diary-display)))
(run-hooks 'diary-hook) (run-hooks 'diary-hook)
diary-entries-list)))))) diary-entries-list))))))
(defun diary-unhide-everything () (defun diary-unhide-everything ()
(setq selective-display nil) (kill-local-variable 'diary-selective-display)
(let ((inhibit-read-only t) (remove-overlays (point-min) (point-max) 'invisible 'diary)
(modified (buffer-modified-p)))
(subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
(set-buffer-modified-p modified))
(kill-local-variable 'mode-line-format)) (kill-local-variable 'mode-line-format))
(defun include-other-diary-files () (defun include-other-diary-files ()
...@@ -603,8 +596,8 @@ This function is provided for optional use as the `diary-display-hook'." ...@@ -603,8 +596,8 @@ This function is provided for optional use as the `diary-display-hook'."
(setq buffer-read-only t) (setq buffer-read-only t)
(display-buffer holiday-buffer) (display-buffer holiday-buffer)
(message "No diary entries for %s" date-string))) (message "No diary entries for %s" date-string)))
(save-excursion;; Prepare the fancy diary buffer. (with-current-buffer;; Prepare the fancy diary buffer.
(set-buffer (make-fancy-diary-buffer)) (make-fancy-diary-buffer)
(setq buffer-read-only nil) (setq buffer-read-only nil)
(let ((entry-list diary-entries-list) (let ((entry-list diary-entries-list)
(holiday-list) (holiday-list)
...@@ -673,10 +666,10 @@ This function is provided for optional use as the `diary-display-hook'." ...@@ -673,10 +666,10 @@ This function is provided for optional use as the `diary-display-hook'."
(temp-face (make-symbol (temp-face (make-symbol
(apply (apply
'concat "temp-face-" 'concat "temp-face-"
(mapcar '(lambda (sym) (mapcar (lambda (sym)
(if (stringp sym) (if (stringp sym)
sym sym
(symbol-name sym))) (symbol-name sym)))
marks)))) marks))))
(faceinfo marks)) (faceinfo marks))
(make-face temp-face) (make-face temp-face)
...@@ -687,7 +680,7 @@ This function is provided for optional use as the `diary-display-hook'." ...@@ -687,7 +680,7 @@ This function is provided for optional use as the `diary-display-hook'."
(setcar faceinfo nil) (setcar faceinfo nil)
(setcar (cdr faceinfo) nil)) (setcar (cdr faceinfo) nil))
(setq marks (delq nil marks)) (setq marks (delq nil marks))
;; Apply the font aspects ;; Apply the font aspects.
(apply 'set-face-attribute temp-face nil marks) (apply 'set-face-attribute temp-face nil marks)
(search-backward entry) (search-backward entry)
(overlay-put (overlay-put
...@@ -704,8 +697,7 @@ This function is provided for optional use as the `diary-display-hook'." ...@@ -704,8 +697,7 @@ This function is provided for optional use as the `diary-display-hook'."
(defun make-fancy-diary-buffer () (defun make-fancy-diary-buffer ()
"Create and return the initial fancy diary buffer." "Create and return the initial fancy diary buffer."
(save-excursion (with-current-buffer (get-buffer-create fancy-diary-buffer)
(set-buffer (get-buffer-create fancy-diary-buffer))
(setq buffer-read-only nil) (setq buffer-read-only nil)
(calendar-set-mode-line "Diary Entries") (calendar-set-mode-line "Diary Entries")
(erase-buffer) (erase-buffer)
...@@ -726,26 +718,33 @@ The hooks given by the variable `print-diary-entries-hook' are called to do ...@@ -726,26 +718,33 @@ The hooks given by the variable `print-diary-entries-hook' are called to do
the actual printing." the actual printing."
(interactive) (interactive)
(if (bufferp (get-buffer fancy-diary-buffer)) (if (bufferp (get-buffer fancy-diary-buffer))
(save-excursion (with-current-buffer (get-buffer fancy-diary-buffer)
(set-buffer (get-buffer fancy-diary-buffer))
(run-hooks 'print-diary-entries-hook)) (run-hooks 'print-diary-entries-hook))
(let ((diary-buffer (let ((diary-buffer
(find-buffer-visiting (substitute-in-file-name diary-file)))) (find-buffer-visiting (substitute-in-file-name diary-file))))
(if diary-buffer (if diary-buffer
(let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) (let ((temp-buffer (get-buffer-create " *Printable Diary Entries*"))
(heading)) (heading))
(save-excursion (with-current-buffer diary-buffer
(set-buffer diary-buffer)
(setq heading (setq heading
(if (not (stringp mode-line-format)) (if (not (stringp mode-line-format))
"All Diary Entries" "All Diary Entries"
(string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
(substring mode-line-format (match-string 1 mode-line-format)))
(match-beginning 1) (match-end 1)))) (let ((start (point-min))
(copy-to-buffer temp-buffer (point-min) (point-max)) end)
(while
(progn
(setq end (next-single-char-property-change
start 'invisible))
(if (get-char-property start 'invisible)
nil
(with-current-buffer temp-buffer
(insert-buffer-substring diary-buffer
start (or end (point-max)))))
(setq start end)
(and end (< end (point-max))))))
(set-buffer temp-buffer) (set-buffer temp-buffer)
(while (re-search-forward "\^M.*$" nil t)
(replace-match ""))
(goto-char (point-min)) (goto-char (point-min))
(insert heading "\n" (insert heading "\n"
(make-string (length heading) ?=) "\n") (make-string (length heading) ?=) "\n")
...@@ -764,18 +763,19 @@ is created." ...@@ -764,18 +763,19 @@ is created."
(pop-up-frames (window-dedicated-p (selected-window)))) (pop-up-frames (window-dedicated-p (selected-window))))
(with-current-buffer (or (find-buffer-visiting d-file) (with-current-buffer (or (find-buffer-visiting d-file)
(find-file-noselect d-file t)) (find-file-noselect d-file t))
(when (eq major-mode 'fundamental-mode) (diary-mode))
(diary-unhide-everything) (diary-unhide-everything)
(display-buffer (current-buffer))))) (display-buffer (current-buffer)))))
(defcustom diary-mail-addr (defcustom diary-mail-addr
(if (boundp 'user-mail-address) user-mail-address "") (if (boundp 'user-mail-address) user-mail-address "")
"*Email address that `diary-mail-entries' will send email to." "Email address that `diary-mail-entries' will send email to."
:group 'diary :group 'diary
:type 'string :type 'string
:version "20.3") :version "20.3")
(defcustom diary-mail-days 7 (defcustom diary-mail-days 7
"*Default number of days for `diary-mail-entries' to check." "Default number of days for `diary-mail-entries' to check."
:group 'diary :group 'diary
:type 'integer :type 'integer
:version "20.3") :version "20.3")
...@@ -866,6 +866,7 @@ diary entries." ...@@ -866,6 +866,7 @@ diary entries."
file-glob-attrs marks) file-glob-attrs marks)
(with-current-buffer (find-file-noselect (diary-check-diary-file) t) (with-current-buffer (find-file-noselect (diary-check-diary-file) t)
(save-excursion (save-excursion
(when (eq major-mode 'fundamental-mode) (diary-mode))
(setq mark-diary-entries-in-calendar t) (setq mark-diary-entries-in-calendar t)
(message "Marking diary entries...") (message "Marking diary entries...")
(setq file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) (setq file-glob-attrs (nth 1 (diary-pull-attrs nil '())))
...@@ -1118,7 +1119,7 @@ A value of 0 in any position of the pattern is a wildcard." ...@@ -1118,7 +1119,7 @@ A value of 0 in any position of the pattern is a wildcard."
(defcustom diary-unknown-time (defcustom diary-unknown-time
-9999 -9999
"*Value returned by diary-entry-time when no time is found. "Value returned by diary-entry-time when no time is found.
The default value -9999 causes entries with no recognizable time to be placed The default value -9999 causes entries with no recognizable time to be placed
before those with times; 9999 would place entries with no recognizable time before those with times; 9999 would place entries with no recognizable time
after those with times." after those with times."
...@@ -1361,7 +1362,7 @@ best if they are nonmarking." ...@@ -1361,7 +1362,7 @@ best if they are nonmarking."
diary-entry)) diary-entry))
(if diary-entry (if diary-entry
(progn (progn
(subst-char-in-region line-start (point) ?\^M ?\n t) (remove-overlays line-start (point) 'invisible 'diary)
(if (< 0 (length entry)) (if (< 0 (length entry))
(setq temp (diary-pull-attrs entry file-glob-attrs) (setq temp (diary-pull-attrs entry file-glob-attrs)
entry (nth 0 temp) entry (nth 0 temp)
...@@ -1511,7 +1512,7 @@ highlighting the day in the calendar." ...@@ -1511,7 +1512,7 @@ highlighting the day in the calendar."
(cons mark entry))))) (cons mark entry)))))
(defun diary-anniversary (month day year &optional mark) (defun diary-anniversary (month day &optional year mark)
"Anniversary diary entry. "Anniversary diary entry.
Entry applies if date is the anniversary of MONTH, DAY, YEAR if Entry applies if date is the anniversary of MONTH, DAY, YEAR if
`european-calendar-style' is nil, and DAY, MONTH, YEAR if `european-calendar-style' is nil, and DAY, MONTH, YEAR if
...@@ -1530,7 +1531,7 @@ use when highlighting the day in the calendar." ...@@ -1530,7 +1531,7 @@ use when highlighting the day in the calendar."
day day
month)) month))
(y (extract-calendar-year date)) (y (extract-calendar-year date))
(diff (- y year))) (diff (if year (- y year) 100)))
(if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
(setq m 3 (setq m 3
d 1)) d 1))
...@@ -1578,7 +1579,7 @@ use when highlighting the day in the calendar." ...@@ -1578,7 +1579,7 @@ use when highlighting the day in the calendar."
(concat (int-to-string days) (if (= 1 days) " day" " days"))) (concat (int-to-string days) (if (= 1 days) " day" " days")))
" until " " until "
diary-entry) diary-entry)
"*Pseudo-pattern giving form of reminder messages in the fancy diary "Pseudo-pattern giving form of reminder messages in the fancy diary
display. display.
Used by the function `diary-remind', a pseudo-pattern is a list of Used by the function `diary-remind', a pseudo-pattern is a list of
...@@ -1657,12 +1658,10 @@ Do nothing if DATE or STRING is nil." ...@@ -1657,12 +1658,10 @@ Do nothing if DATE or STRING is nil."
(defun make-diary-entry (string &optional nonmarking file) (defun make-diary-entry (string &optional nonmarking file)
"Insert a diary entry STRING which may be NONMARKING in FILE. "Insert a diary entry STRING which may be NONMARKING in FILE.
If omitted, NONMARKING defaults to nil and FILE defaults to If omitted, NONMARKING defaults to nil and FILE defaults to
`diary-file'. Adds `diary-redraw-calendar' to `diary-file'."
`write-contents-functions' for FILE, so that the calendar will be
redrawn with the new entry marked, if necessary."
(let ((pop-up-frames (window-dedicated-p (selected-window)))) (let ((pop-up-frames (window-dedicated-p (selected-window))))
(find-file-other-window (substitute-in-file-name (or file diary-file)))) (find-file-other-window (substitute-in-file-name (or file diary-file))))
(add-hook 'after-save-hook 'diary-redraw-calendar nil t) (when (eq major-mode 'fundamental-mode) (diary-mode))
(widen) (widen)
(diary-unhide-everything) (diary-unhide-everything)
(goto-char (point-max)) (goto-char (point-max))
...@@ -1867,6 +1866,13 @@ names." ...@@ -1867,6 +1866,13 @@ names."
(eval-when-compile (require 'cal-hebrew) (eval-when-compile (require 'cal-hebrew)
(require 'cal-islam)) (require 'cal-islam))
(defconst diary-time-regexp
;; Formats that should be accepted:
;; 10:00 10.00 10h00 10h 10am 10:00am 10.00am
(concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\("
"[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]"
"\\)\\([AaPp][Mm]\\)?\\)"))
(defvar diary-font-lock-keywords (defvar diary-font-lock-keywords
(append (append
(diary-font-lock-date-forms calendar-month-name-array (diary-font-lock-date-forms calendar-month-name-array
...@@ -1907,8 +1913,10 @@ names." ...@@ -1907,8 +1913,10 @@ names."
"?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)") "?\\(" (regexp-quote islamic-diary-entry-symbol) "\\)")
'(1 font-lock-reference-face)) '(1 font-lock-reference-face))
'(diary-font-lock-sexps . font-lock-keyword-face) '(diary-font-lock-sexps . font-lock-keyword-face)
'("[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\(-[0-9]?[0-9]\\([:.]?[0-9][0-9]\\)?\\(am\\|pm\\|AM\\|PM\\)\\)?" (cons
. font-lock-function-name-face))) (concat ;; "^[ \t]+"
diary-time-regexp "\\(-" diary-time-regexp "\\)?")
'font-lock-function-name-face)))
"Forms to highlight in `diary-mode'.") "Forms to highlight in `diary-mode'.")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment