From bd0674c9321da4a1e4fcf37df98cec9f51dc728f Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 00:40:39 +0100 Subject: [PATCH 001/191] Allow suggesting to install packages * etc/package-autosuggest.eld: Add a manual sketch of the database * lisp/emacs-lisp/package.el (package-autosuggest-database) (package-autosuggest-mode, package--suggestion-applies-p) (package--autosuggest-find-candidates) (package--autosuggest-install-and-enable) (package--autosuggest-suggested, package--autosugest-line-format) (package-autosuggest-face, mode-line-misc-info) (package--autosuggest-after-change-mode, package-autosuggest): Implement the feature. --- etc/package-autosuggest.eld | 7 ++ lisp/emacs-lisp/package.el | 147 ++++++++++++++++++++++++++++++++++++ 2 files changed, 154 insertions(+) create mode 100644 etc/package-autosuggest.eld diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld new file mode 100644 index 00000000000..e6c2c805edd --- /dev/null +++ b/etc/package-autosuggest.eld @@ -0,0 +1,7 @@ +;; Database of suggestions for `package-autosuggest' + +( + (sml-mode auto-mode-alist "\\.sml\\'") + (ada-mode auto-mode-alist "\\.ada\\'") + (go-mode auto-mode-alist "\\.go\\'") +) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index af07ba44e28..c6ab77fc3d3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4536,6 +4536,153 @@ the `Version:' header." (or (lm-header "package-version") (lm-header "version"))))))))) + +;;;; Autosuggest + +(defconst package-autosuggest-database + (eval-when-compile + (with-temp-buffer + (insert-file-contents + (expand-file-name "package-autosuggest.eld" data-directory)"/home/phi/Source/emacs/etc/package-autosuggest.eld") + (read (current-buffer)))) + "Database of hints for packages to suggest installing.") + +(define-minor-mode package-autosuggest-mode + "Enable the automatic suggestion and installation of packages." + :init-value 'mode-line :global t + :type '(choice (const :tag "Indicate in mode line" mode-line) + (const :tag "Always prompt" always) + (const :tag "Prompt only once" once) + (const :tag "Indicate with message" message) + (const :tag "Do not suggest anything" nil)) + (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) + 'after-change-major-mode-hook + #'package--autosuggest-after-change-mode)) + +(defun package--suggestion-applies-p (pkg-sug) + "Check if a suggestion PKG-SUG is applicable to the current buffer." + (pcase pkg-sug + (`(,(pred package-installed-p) . ,_) nil) + ((or `(,_ auto-mode-alist ,ext _) + `(,_ auto-mode-alist ,ext)) + (and (string-match-p ext (buffer-name)) t)) + ((or `(,_ magic-mode-alist ,mag _) + `(,_ magic-mode-alist ,mag)) + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (looking-at-p mag)))) + ((or `(,_ interpreter-mode-alist ,magic _) + `(,_ interpreter-mode-alist ,magic)) + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (and (looking-at auto-mode-interpreter-regexp) + (string-match-p + (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") + magic))))))) + +(defun package--autosuggest-find-candidates () + "Return a list of packages that might be interesting the current buffer." + (and package-autosuggest-mode + (let (suggetions) + (dolist (sug package-autosuggest-database) + (when (package--suggestion-applies-p sug) + (push sug suggetions))) + suggetions))) + +(defun package--autosuggest-install-and-enable (pkg-sug) + "Install and enable a package suggestion PKG-ENT. +PKG-SUG has the same form as an element of +`package-autosuggest-database'." + (let ((buffers-to-update '())) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (and (eq major-mode 'fundamental-mode) (buffer-file-name) + (package--suggestion-applies-p pkg-sug)) + (push buf buffers-to-update)))) + (package-install (car pkg-sug)) + (dolist (buf buffers-to-update) + (with-demoted-errors "Failed to enable major mode: %S" + (with-current-buffer buf + (funcall-interactively (or (cadddr pkg-sug) (car pkg-sug)))))))) + +(defvar package--autosuggest-suggested '() + "List of packages that have already been suggested.") + +(defvar package--autosugest-line-format + '(:eval (package--autosugest-line-format))) +(put 'package--autosugest-line-format 'risky-local-variable t) + +(defface package-autosuggest-face + '((t :inherit (success))) + "Face to use in the mode line to highlight suggested packages." + :version "30.1") + +(defun package--autosugest-line-format () + "Generate a mode-line string to indicate a suggested package." + `(,@(and-let* (((eq package-autosuggest-mode 'mode-line)) + (avail (seq-difference (package--autosuggest-find-candidates) + package--autosuggest-suggested))) + (propertize + (format "Install %s?" + (mapconcat + #'symbol-name + (delete-dups (mapcar #'car avail)) + ", ")) + 'face 'package-autosuggest-face + 'mouse-face 'mode-line-highlight + 'help-echo "Click to install suggested package." + 'keymap (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] #'package-autosuggest) + map))))) + +(add-to-list + 'mode-line-misc-info + '(package-autosuggest-mode ("" package--autosugest-line-format))) + +(defun package--autosuggest-after-change-mode () + "Hook function to suggest packages for installation." + (when-let* ((avail (seq-difference (package--autosuggest-find-candidates) + package--autosuggest-suggested)) + (pkgs (mapconcat #'symbol-name + (delete-dups (mapcar #'car avail)) + ", ")) + (use-dialog-box t)) + (pcase package-autosuggest-mode + ('mode-line + (force-mode-line-update t)) + ('always + (when (yes-or-no-p (format "Install suggested packages (%s)?" pkgs)) + (mapc #'package--autosuggest-install-and-enable avail))) + ('once + (when (yes-or-no-p (format "Install suggested packages (%s)?" pkgs)) + (mapc #'package--autosuggest-install-and-enable avail)) + (setq package--autosuggest-suggested (append avail package--autosuggest-suggested))) + ('message + (message + (substitute-command-keys + (format "Found suggested packages: %s. Install using \\[package-autosuggest]" + pkgs))))))) + +(defun package-autosuggest () + "Prompt the user for suggested packages." + (interactive) + (let* ((avail (or (package--autosuggest-find-candidates) + (user-error "No suggestions found"))) + (pkgs (completing-read-multiple + "Install suggested packages: " avail + nil t + (mapconcat #'symbol-name + (delete-dups (mapcar #'car avail)) + ","))) + (choice (concat "\\`" (regexp-opt pkgs) "\\'"))) + (dolist (ent avail) + (when (string-match-p choice (symbol-name (car ent))) + (package--autosuggest-install-and-enable ent))))) + ;;;; Quickstart: precompute activation actions for faster start up. From 81869a5b9fad86503afd8c8cb063555627bc21ff Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 13:51:08 +0100 Subject: [PATCH 002/191] Improve prompting of autosuggested packages * lisp/emacs-lisp/package.el (package--autosuggest-suggested): Move declaration up. (package--suggestion-applies-p): Respect 'package--autosuggest-suggested', avoiding to suggest packages multiple times. (package--autosugest-line-format) (package--autosuggest-after-change-mode): Simplify due to 'package--suggestion-applies-p' respecting 'package--autosuggest-suggested'. (package-autosuggest): Replace CRM prompt with a yes-or-no-p, so that 'use-dialog-box' can take effect. --- lisp/emacs-lisp/package.el | 42 +++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c6ab77fc3d3..7bf26ff1ba3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4559,10 +4559,16 @@ the `Version:' header." 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) +(defvar package--autosuggest-suggested '() + "List of packages that have already been suggested.") + (defun package--suggestion-applies-p (pkg-sug) "Check if a suggestion PKG-SUG is applicable to the current buffer." (pcase pkg-sug - (`(,(pred package-installed-p) . ,_) nil) + (`(,(or (pred (assq _ package--autosuggest-suggested)) + (pred package-installed-p)) + . ,_) + nil) ((or `(,_ auto-mode-alist ,ext _) `(,_ auto-mode-alist ,ext)) (and (string-match-p ext (buffer-name)) t)) @@ -4609,9 +4615,6 @@ PKG-SUG has the same form as an element of (with-current-buffer buf (funcall-interactively (or (cadddr pkg-sug) (car pkg-sug)))))))) -(defvar package--autosuggest-suggested '() - "List of packages that have already been suggested.") - (defvar package--autosugest-line-format '(:eval (package--autosugest-line-format))) (put 'package--autosugest-line-format 'risky-local-variable t) @@ -4624,8 +4627,7 @@ PKG-SUG has the same form as an element of (defun package--autosugest-line-format () "Generate a mode-line string to indicate a suggested package." `(,@(and-let* (((eq package-autosuggest-mode 'mode-line)) - (avail (seq-difference (package--autosuggest-find-candidates) - package--autosuggest-suggested))) + (avail (package--autosuggest-find-candidates))) (propertize (format "Install %s?" (mapconcat @@ -4645,12 +4647,10 @@ PKG-SUG has the same form as an element of (defun package--autosuggest-after-change-mode () "Hook function to suggest packages for installation." - (when-let* ((avail (seq-difference (package--autosuggest-find-candidates) - package--autosuggest-suggested)) + (when-let* ((avail (package--autosuggest-find-candidates)) (pkgs (mapconcat #'symbol-name (delete-dups (mapcar #'car avail)) - ", ")) - (use-dialog-box t)) + ", "))) (pcase package-autosuggest-mode ('mode-line (force-mode-line-update t)) @@ -4672,17 +4672,17 @@ PKG-SUG has the same form as an element of (interactive) (let* ((avail (or (package--autosuggest-find-candidates) (user-error "No suggestions found"))) - (pkgs (completing-read-multiple - "Install suggested packages: " avail - nil t - (mapconcat #'symbol-name - (delete-dups (mapcar #'car avail)) - ","))) - (choice (concat "\\`" (regexp-opt pkgs) "\\'"))) - (dolist (ent avail) - (when (string-match-p choice (symbol-name (car ent))) - (package--autosuggest-install-and-enable ent))))) - + (use-dialog-box t) + (prompt (concat + "Install " + (mapconcat + #'symbol-name + (delete-dups (mapcar #'car avail)) + ", ") + "?"))) + (if (yes-or-no-p prompt) + (mapc #'package--autosuggest-install-and-enable avail) + (setq package--autosuggest-suggested (append avail package--autosuggest-suggested))))) ;;;; Quickstart: precompute activation actions for faster start up. From 90d6044e23b65c76ba529a7b20c7d8e27634b6f0 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 13:55:40 +0100 Subject: [PATCH 003/191] * lisp/emacs-lisp/package.el (package-autosuggest): New command --- lisp/emacs-lisp/package.el | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7bf26ff1ba3..50095d92ae3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4683,6 +4683,16 @@ PKG-SUG has the same form as an element of (if (yes-or-no-p prompt) (mapc #'package--autosuggest-install-and-enable avail) (setq package--autosuggest-suggested (append avail package--autosuggest-suggested))))) + +(defun package-reset-suggestions () + "Forget previous package suggestions. +Emacs will remember if you have previously rejected a suggestion during +a session and won't mention it afterwards. If you have made a mistake +or would like to reconsider this, use this command to want to reset the +suggestions." + (interactive) + (setq package--autosuggest-suggested nil)) + ;;;; Quickstart: precompute activation actions for faster start up. From 73c76caa1a5871a81500b3e2df8da38f48cc5d1e Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 19:41:12 +0100 Subject: [PATCH 004/191] Improve package-autosuggest documentation * lisp/emacs-lisp/package.el (package-autosuggest-database) (package-autosuggest-mode, package--autosuggest-suggested) (package--suggestion-applies-p) (package--autosuggest-find-candidates) (package--autosuggest-install-and-enable) (package--autosuggest-after-change-mode, package-autosuggest): Elaborate docstrings. --- lisp/emacs-lisp/package.el | 63 +++++++++++++++++++++++++------------- 1 file changed, 41 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 50095d92ae3..bead32bdaf8 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4545,10 +4545,24 @@ the `Version:' header." (insert-file-contents (expand-file-name "package-autosuggest.eld" data-directory)"/home/phi/Source/emacs/etc/package-autosuggest.eld") (read (current-buffer)))) - "Database of hints for packages to suggest installing.") + "List of hints for packages to suggest installing. +Each hint has the form (PACKAGE TYPE DATA), where PACKAGE is a symbol +denoting the package the hint applies to, TYPE is one of +`auto-mode-alist', `magic-mode-alist' or `interpreter-mode-alist' +indicating the type of check to be made and DATA is the value to check +against TYPE in the intuitive way (e.g. for `auto-mode-alist' DATA is a +regular expression matching a file name that PACKAGE should be suggested +for).") (define-minor-mode package-autosuggest-mode - "Enable the automatic suggestion and installation of packages." + "Enable the automatic suggestion and installation of packages. +As a user option, you can set this value to `mode-line' (default) to +indicate the availability of a package suggestion in the minor mode, +`always' to prompt the user in the minibuffer every time a suggestion is +available in a `fundamenta-mode' buffer, `once' to do only prompt the +user once for each suggestion or `message' to just display a message +hinting at the existence of a suggestion. If `package-autosuggest-mode' +is set to nil, the minor mode will be disabled and no suggestions occur." :init-value 'mode-line :global t :type '(choice (const :tag "Indicate in mode line" mode-line) (const :tag "Always prompt" always) @@ -4560,27 +4574,30 @@ the `Version:' header." #'package--autosuggest-after-change-mode)) (defvar package--autosuggest-suggested '() - "List of packages that have already been suggested.") + "List of packages that have already been suggested. +The elements of this list should be a subset of elements from +`package-autosuggest-database'. Suggestions found in this list will not +count as suggestions (e.g. if `package-autosuggest-mode' is set to +`mode-line', a suggestion found in here will inhibit +`package-autosuggest-mode' from displaying a hint in the mode line).") -(defun package--suggestion-applies-p (pkg-sug) - "Check if a suggestion PKG-SUG is applicable to the current buffer." - (pcase pkg-sug +(defun package--suggestion-applies-p (sug) + "Check if a suggestion SUG is applicable to the current buffer. +SUG should be an element of `package-autosuggest-database'." + (pcase sug (`(,(or (pred (assq _ package--autosuggest-suggested)) (pred package-installed-p)) . ,_) nil) - ((or `(,_ auto-mode-alist ,ext _) - `(,_ auto-mode-alist ,ext)) + (`(,_ auto-mode-alist ,ext) (and (string-match-p ext (buffer-name)) t)) - ((or `(,_ magic-mode-alist ,mag _) - `(,_ magic-mode-alist ,mag)) + (`(,_ magic-mode-alist ,mag) (save-restriction (widen) (save-excursion (goto-char (point-min)) (looking-at-p mag)))) - ((or `(,_ interpreter-mode-alist ,magic _) - `(,_ interpreter-mode-alist ,magic)) + (`(,_ interpreter-mode-alist ,magic) (save-restriction (widen) (save-excursion @@ -4591,7 +4608,9 @@ the `Version:' header." magic))))))) (defun package--autosuggest-find-candidates () - "Return a list of packages that might be interesting the current buffer." + "Return a list of suggestions that might be interesting the current buffer. +The elements of the returned list will be a subset of the elements of +`package--autosuggest-suggested'." (and package-autosuggest-mode (let (suggetions) (dolist (sug package-autosuggest-database) @@ -4599,21 +4618,20 @@ the `Version:' header." (push sug suggetions))) suggetions))) -(defun package--autosuggest-install-and-enable (pkg-sug) +(defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. -PKG-SUG has the same form as an element of -`package-autosuggest-database'." +SUG should be an element of `package-autosuggest-database'." (let ((buffers-to-update '())) (dolist (buf (buffer-list)) (with-current-buffer buf (when (and (eq major-mode 'fundamental-mode) (buffer-file-name) - (package--suggestion-applies-p pkg-sug)) + (package--suggestion-applies-p sug)) (push buf buffers-to-update)))) - (package-install (car pkg-sug)) + (package-install (car sug)) (dolist (buf buffers-to-update) (with-demoted-errors "Failed to enable major mode: %S" (with-current-buffer buf - (funcall-interactively (or (cadddr pkg-sug) (car pkg-sug)))))))) + (funcall-interactively (or (cadddr sug) (car sug)))))))) (defvar package--autosugest-line-format '(:eval (package--autosugest-line-format))) @@ -4646,7 +4664,8 @@ PKG-SUG has the same form as an element of '(package-autosuggest-mode ("" package--autosugest-line-format))) (defun package--autosuggest-after-change-mode () - "Hook function to suggest packages for installation." + "Display package suggestions for the current buffer. +This function should be added to `after-change-major-mode-hook'." (when-let* ((avail (package--autosuggest-find-candidates)) (pkgs (mapconcat #'symbol-name (delete-dups (mapcar #'car avail)) @@ -4665,10 +4684,10 @@ PKG-SUG has the same form as an element of (message (substitute-command-keys (format "Found suggested packages: %s. Install using \\[package-autosuggest]" - pkgs))))))) + pkgs)))p)))) (defun package-autosuggest () - "Prompt the user for suggested packages." + "Prompt the user to install the suggested packages." (interactive) (let* ((avail (or (package--autosuggest-find-candidates) (user-error "No suggestions found"))) From d9214f157359f6ed00de27ba2756127ee754140f Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 19:42:34 +0100 Subject: [PATCH 005/191] Ensure a valid value for 'package-autosuggest-mode' * lisp/emacs-lisp/package.el (package-autosuggest-mode): If 'define-minor-mode' sets the value of the variable to t, then we will override this to the default value. --- lisp/emacs-lisp/package.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index bead32bdaf8..4f20a1735f2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4569,6 +4569,9 @@ is set to nil, the minor mode will be disabled and no suggestions occur." (const :tag "Prompt only once" once) (const :tag "Indicate with message" message) (const :tag "Do not suggest anything" nil)) + (unless (memq package-autosuggest-mode '(mode-line always once message)) + (let ((def (custom--standard-value 'package-autosuggest-mode))) + (setq package-autosuggest-mode def))) (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) From 6b65feabf1b0528e16e0ead84c8e2a3bb5ce55c3 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 19:55:05 +0100 Subject: [PATCH 006/191] ; Remove thinko value from 'package-autosuggest-database' * lisp/emacs-lisp/package.el (package-autosuggest-database): Read the result of evaluating 'expand-file-name' instead of discarding the value. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4f20a1735f2..ec56c327dae 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4543,7 +4543,7 @@ the `Version:' header." (eval-when-compile (with-temp-buffer (insert-file-contents - (expand-file-name "package-autosuggest.eld" data-directory)"/home/phi/Source/emacs/etc/package-autosuggest.eld") + (expand-file-name "package-autosuggest.eld" data-directory)) (read (current-buffer)))) "List of hints for packages to suggest installing. Each hint has the form (PACKAGE TYPE DATA), where PACKAGE is a symbol From 33c349dd3ac65d56e629d6cf94e66276815068f8 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 20:58:31 +0100 Subject: [PATCH 007/191] Create separate 'package-autosuggest-style' user option * lisp/emacs-lisp/package.el (package-autosuggest-mode): Extract part of the logic into a separate user option. (package--autosuggest-suggested, package--suggestion-applies-p) (package--autosugest-line-format) (package--autosuggest-after-change-mode): Respect the change. --- lisp/emacs-lisp/package.el | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ec56c327dae..ec4b569b6ca 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4554,24 +4554,22 @@ against TYPE in the intuitive way (e.g. for `auto-mode-alist' DATA is a regular expression matching a file name that PACKAGE should be suggested for).") -(define-minor-mode package-autosuggest-mode - "Enable the automatic suggestion and installation of packages. -As a user option, you can set this value to `mode-line' (default) to -indicate the availability of a package suggestion in the minor mode, -`always' to prompt the user in the minibuffer every time a suggestion is -available in a `fundamenta-mode' buffer, `once' to do only prompt the -user once for each suggestion or `message' to just display a message -hinting at the existence of a suggestion. If `package-autosuggest-mode' -is set to nil, the minor mode will be disabled and no suggestions occur." - :init-value 'mode-line :global t +(defcustom package-autosuggest-style 'mode-line + "How to draw attention to `package-autosuggest-mode' suggestions. +You can set this value to `mode-line' (default) to indicate the +availability of a package suggestion in the minor mode, `always' to +prompt the user in the minibuffer every time a suggestion is available +in a `fundamenta-mode' buffer, `once' to do only prompt the user once +for each suggestion or `message' to just display a message hinting at +the existence of a suggestion." :type '(choice (const :tag "Indicate in mode line" mode-line) (const :tag "Always prompt" always) (const :tag "Prompt only once" once) - (const :tag "Indicate with message" message) - (const :tag "Do not suggest anything" nil)) - (unless (memq package-autosuggest-mode '(mode-line always once message)) - (let ((def (custom--standard-value 'package-autosuggest-mode))) - (setq package-autosuggest-mode def))) + (const :tag "Indicate with message" message))) + +(define-minor-mode package-autosuggest-mode + "Enable the automatic suggestion and installation of packages." + :init-value t :global t (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) @@ -4580,7 +4578,7 @@ is set to nil, the minor mode will be disabled and no suggestions occur." "List of packages that have already been suggested. The elements of this list should be a subset of elements from `package-autosuggest-database'. Suggestions found in this list will not -count as suggestions (e.g. if `package-autosuggest-mode' is set to +count as suggestions (e.g. if `package-autosuggest-style' is set to `mode-line', a suggestion found in here will inhibit `package-autosuggest-mode' from displaying a hint in the mode line).") @@ -4588,7 +4586,7 @@ count as suggestions (e.g. if `package-autosuggest-mode' is set to "Check if a suggestion SUG is applicable to the current buffer. SUG should be an element of `package-autosuggest-database'." (pcase sug - (`(,(or (pred (assq _ package--autosuggest-suggested)) + (`(,(or (pred (lambda (e) (assq e package--autosuggest-suggested))) (pred package-installed-p)) . ,_) nil) @@ -4647,7 +4645,8 @@ SUG should be an element of `package-autosuggest-database'." (defun package--autosugest-line-format () "Generate a mode-line string to indicate a suggested package." - `(,@(and-let* (((eq package-autosuggest-mode 'mode-line)) + `(,@(and-let* (((not (null package-autosuggest-mode))) + ((eq package-autosuggest-style 'mode-line)) (avail (package--autosuggest-find-candidates))) (propertize (format "Install %s?" @@ -4673,7 +4672,7 @@ This function should be added to `after-change-major-mode-hook'." (pkgs (mapconcat #'symbol-name (delete-dups (mapcar #'car avail)) ", "))) - (pcase package-autosuggest-mode + (pcase-exhaustive package-autosuggest-style ('mode-line (force-mode-line-update t)) ('always From e2965e25529a6f2113e44e54c566d729bfd5c955 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 20:59:53 +0100 Subject: [PATCH 008/191] Update mode line after rejecting a suggestion * lisp/emacs-lisp/package.el (package-autosuggest): Call 'force-mode-line-update' if it would make sense. --- lisp/emacs-lisp/package.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ec4b569b6ca..308c6ad1a51 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4703,7 +4703,9 @@ This function should be added to `after-change-major-mode-hook'." "?"))) (if (yes-or-no-p prompt) (mapc #'package--autosuggest-install-and-enable avail) - (setq package--autosuggest-suggested (append avail package--autosuggest-suggested))))) + (setq package--autosuggest-suggested (append avail package--autosuggest-suggested)) + (when (eq package-autosuggest-style 'mode-line) + (force-mode-line-update t))))) (defun package-reset-suggestions () "Forget previous package suggestions. From 0cb99c51a3aa7453a524ab7498fb982416308875 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 6 Nov 2024 21:09:57 +0100 Subject: [PATCH 009/191] Add command to scrape ELPA for package suggestions * admin/scrape-elpa.el (scrape-elpa): Add new command. * etc/package-autosuggest.eld: Generate file using 'scrape-elpa'. --- admin/scrape-elpa.el | 78 ++++++++++++++++++++++++++++++++++++ etc/package-autosuggest.eld | 80 +++++++++++++++++++++++++++++++++++-- 2 files changed, 154 insertions(+), 4 deletions(-) create mode 100644 admin/scrape-elpa.el diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el new file mode 100644 index 00000000000..78dbd7349d0 --- /dev/null +++ b/admin/scrape-elpa.el @@ -0,0 +1,78 @@ +;;; scrape-elpa.el --- Collect ELPA package suggestions -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic +;; Keywords: tools + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This file defines an administrative command to update the +;; `package-autosuggest' database. + +;;; Code: + +(defun scrape-elpa (&rest directories) + "Scrape autoload files in DIRECTORIES for package suggestions. +This file will automatically update \"package-autosuggest.eld\", but not +save it. You should invoke this command with built GNU ELPA and NonGNU +ELPA checkouts (i.e. having run \"make build-all\" in both directories). +Please review the results before updating the autosuggest database!" + (interactive (completing-read-multiple + "ELPA directories to scrape: " + #'completion-file-name-table + #'file-directory-p)) + (with-current-buffer + (find-file (expand-file-name "package-autosuggest.eld" data-directory)) + (erase-buffer) + (lisp-data-mode) + (insert ";; The contents of this file are loaded into `package-autosuggest-database' +;; and were automatically generate by scraping ELPA for auto-loaded +;; code using the `scrape-elpa' command. Please avoid updating this +;; file manually! + +") + (fill-paragraph) + (insert "(") + (let ((standard-output (current-buffer))) + (dolist-with-progress-reporter + (file (mapcan + (lambda (dir) + (directory-files-recursively + dir "-autoloads\\.el\\'")) + directories)) + "Scraping files..." + (let ((inhibit-message t)) + (with-temp-buffer + (insert-file-contents file) + (condition-case nil + (while t + (pcase (read (current-buffer)) + (`(add-to-list + ',(and (or 'interpreter-mode-alist + 'magic-mode-alist + 'auto-mode-alist) + variable) + '(,(and (pred stringp) regexp) . + ,(and (pred symbolp) mode))) + (terpri) + (prin1 `(,mode ,variable ,regexp)) + (princ (concat " ;from " file))))) + (end-of-file nil)))))) + (insert "\n)\n"))) + +(provide 'scrape-elpa) +;;; scrape-elpa.el ends here diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index e6c2c805edd..742983fa9eb 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -1,7 +1,79 @@ -;; Database of suggestions for `package-autosuggest' +;; The contents of this file are loaded into `package-autosuggest-database' +;; and were automatically generate by scraping ELPA for auto-loaded +;; code using the `scrape-elpa' command. Please avoid updating this +;; file manually! ( - (sml-mode auto-mode-alist "\\.sml\\'") - (ada-mode auto-mode-alist "\\.ada\\'") - (go-mode auto-mode-alist "\\.go\\'") +(ada-mode auto-mode-alist "\\.ad[abs]\\'") ;from ~/Source/elpa/packages/ada-mode/ada-mode-autoloads.el +(arbitools-mode auto-mode-alist "\\.trf?\\'") ;from ~/Source/elpa/packages/arbitools/arbitools-autoloads.el +(LaTeX-mode auto-mode-alist "\\.hva\\'") ;from ~/Source/elpa/packages/auctex/auctex-autoloads.el +(bnf-mode auto-mode-alist "\\.bnf\\'") ;from ~/Source/elpa/packages/bnf-mode/bnf-mode-autoloads.el +(chess-pgn-mode auto-mode-alist "\\.pgn\\'") ;from ~/Source/elpa/packages/chess/chess-autoloads.el +(cobol-mode auto-mode-alist "\\.c\\(ob\\|bl\\|py\\)\\'") ;from ~/Source/elpa/packages/cobol-mode/cobol-mode-autoloads.el +(code-cells-convert-ipynb auto-mode-alist "\\.ipynb\\'") ;from ~/Source/elpa/packages/code-cells/code-cells-autoloads.el +(csharp-mode auto-mode-alist "\\.cs\\'") ;from ~/Source/elpa/packages/csharp-mode/csharp-mode-autoloads.el +(csv-mode auto-mode-alist "\\.[Cc][Ss][Vv]\\'") ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el +(tsv-mode auto-mode-alist "\\.tsv\\'") ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el +(dismal-mode auto-mode-alist "\\.dis\\'") ;from ~/Source/elpa/packages/dismal/dismal-autoloads.el +(djvu-init-mode auto-mode-alist "\\.djvu\\'") ;from ~/Source/elpa/packages/djvu/djvu-autoloads.el +(dts-mode auto-mode-alist "\\.dtsi?\\'") ;from ~/Source/elpa/packages/dts-mode/dts-mode-autoloads.el +(ess-bugs-mode auto-mode-alist "\\.[Bb][Uu][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-bugs-mode auto-mode-alist "\\.[Bb][Oo][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-bugs-mode auto-mode-alist "\\.[Bb][Mm][Dd]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-jags-mode auto-mode-alist "\\.[Jj][Aa][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode auto-mode-alist "/R/.*\\.q\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode auto-mode-alist "\\.[rR]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode auto-mode-alist "\\.[rR]profile\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode auto-mode-alist "NAMESPACE\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode auto-mode-alist "CITATION\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-transcript-mode auto-mode-alist "\\.[Rr]out\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode interpreter-mode-alist "Rscript") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess-r-mode interpreter-mode-alist "r") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(makefile-mode auto-mode-alist "/Makevars\\(\\.win\\)?\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(conf-colon-mode auto-mode-alist "DESCRIPTION\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(Rd-mode auto-mode-alist "\\.Rd\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(S-transcript-mode auto-mode-alist "\\.[Ss]t\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(S-transcript-mode auto-mode-alist "\\.Sout\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(SAS-mode auto-mode-alist "\\.[Ss][Aa][Ss]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(gle-mode auto-mode-alist "\\.gle\\'") ;from ~/Source/elpa/packages/gle-mode/gle-mode-autoloads.el +(gpr-mode auto-mode-alist "\\.gpr\\'") ;from ~/Source/elpa/packages/gpr-mode/gpr-mode-autoloads.el +(nxml-mode auto-mode-alist "\\.html?\\'") ;from ~/Source/elpa/packages/html5-schema/html5-schema-autoloads.el +(jgraph-mode auto-mode-alist "\\.jgr\\'") ;from ~/Source/elpa/packages/jgraph-mode/jgraph-mode-autoloads.el +(json-mode auto-mode-alist "\\.json\\'") ;from ~/Source/elpa/packages/json-mode/json-mode-autoloads.el +(lmc-asm-mode auto-mode-alist "\\.elmc\\'") ;from ~/Source/elpa/packages/lmc/lmc-autoloads.el +(muse-mode-choose-mode auto-mode-alist "\\.muse\\'") ;from ~/Source/elpa/packages/muse/lisp/muse-autoloads.el +(latex-mode auto-mode-alist "\\.drv\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el +(doctex-mode auto-mode-alist "\\.dtx\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el +(nftables-mode auto-mode-alist "\\.nft\\(?:ables\\)?\\'") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el +(nftables-mode auto-mode-alist "/etc/nftables.conf") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el +(nftables-mode interpreter-mode-alist "nft\\(?:ables\\)?") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el +(omn-mode auto-mode-alist "\\.pomn\\'") ;from ~/Source/elpa/packages/omn-mode/omn-mode-autoloads.el +(omn-mode auto-mode-alist "\\.omn\\'") ;from ~/Source/elpa/packages/omn-mode/omn-mode-autoloads.el +(poke-mode auto-mode-alist "\\.pk\\'") ;from ~/Source/elpa/packages/poke-mode/poke-mode-autoloads.el +(pspp-mode auto-mode-alist "\\.sps\\'") ;from ~/Source/elpa/packages/pspp-mode/pspp-mode-autoloads.el +(conf-mode auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'") ;from ~/Source/elpa/packages/python/python-autoloads.el +(rec-mode auto-mode-alist "\\.rec\\'") ;from ~/Source/elpa/packages/rec-mode/rec-mode-autoloads.el +(rnc-mode auto-mode-alist "\\.rnc\\'") ;from ~/Source/elpa/packages/rnc-mode/rnc-mode-autoloads.el +(sed-mode auto-mode-alist "\\.sed\\'") ;from ~/Source/elpa/packages/sed-mode/sed-mode-autoloads.el +(sed-mode interpreter-mode-alist "sed") ;from ~/Source/elpa/packages/sed-mode/sed-mode-autoloads.el +(shen-mode auto-mode-alist "\\.shen\\'") ;from ~/Source/elpa/packages/shen-mode/shen-mode-autoloads.el +(sisu-mode auto-mode-alist "\\.ss[imt]\\'") ;from ~/Source/elpa/packages/sisu-mode/sisu-mode-autoloads.el +(smalltalk-mode auto-mode-alist "\\.st\\'") ;from ~/Source/elpa/packages/smalltalk-mode/smalltalk-mode-autoloads.el +(sml-mode auto-mode-alist "\\.s\\(ml\\|ig\\)\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el +(sml-cm-mode auto-mode-alist "\\.cm\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el +(sml-yacc-mode auto-mode-alist "\\.grm\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el +(sql-mode auto-mode-alist "\\.cql\\'") ;from ~/Source/elpa/packages/sql-cassandra/sql-cassandra-autoloads.el +(sxhkdrc-mode auto-mode-alist "sxhkdrc\\'") ;from ~/Source/elpa/packages/sxhkdrc-mode/sxhkdrc-mode-autoloads.el +(systemd-automount-mode auto-mode-alist "\\.automount\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-mount-mode auto-mode-alist "\\.mount\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-path-mode auto-mode-alist "\\.path\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-service-mode auto-mode-alist "\\.service\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-socket-mode auto-mode-alist "\\.socket\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-swap-mode auto-mode-alist "\\.swap\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd-timer-mode auto-mode-alist "\\.timer\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(vcard-mode auto-mode-alist "\\.[Vv][Cc][Ff]\\'") ;from ~/Source/elpa/packages/vcard/vcard-autoloads.el +(wisitoken-parse_table-mode auto-mode-alist "\\.parse_table.*\\'") ;from ~/Source/elpa/packages/wisi/wisi-autoloads.el +(simple-indent-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el +(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el +(coq-mode auto-mode-alist "\\.v\\'") ;from ~/Source/nongnu/packages/proof-general/generic/proof-autoloads.el ) From 8cc5013d5c6e013e59b7b9987f704138307ffd22 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 12:30:25 +0100 Subject: [PATCH 010/191] * doc/emacs/package.texi: Document 'package-autosuggest' --- doc/emacs/package.texi | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 2022ea61f6b..b91a49cbf2e 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -408,6 +408,14 @@ name of the package archive directory. You can alter this list if you wish to use third party package archives---but do so at your own risk, and use only third parties that you think you can trust! +@cindex suggestions +@findex package-autosuggest + Emacs has a built-in database of suggested packages for certain file +types. If Emacs opens a file with no specific mode, you can use the +@code{package-autosuggest} command to install the recommended packages +from ELPA. By default, Emacs will display a clickable hint in the +mode-line if it there is a suggested package. + @anchor{Package Signing} @cindex package security @cindex package signing From 5a6717695ae1ce2ca3d13cd2db05f19f889f10ed Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 12:33:14 +0100 Subject: [PATCH 011/191] * etc/NEWS: Mention 'package-autosuggest' --- etc/NEWS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index af6259a68c8..a808cc30b58 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -659,6 +659,13 @@ cloning, or prompts for that, too. When the argument is non-nil, the function switches to a buffer visiting the directory into which the repository was cloned. +** Package + ++++ +*** New command 'package-autosuggest' +Using a built-in database of package suggestions from ELPA, this command +will install viable packages if no specific major mode is available. + * New Modes and Packages in Emacs 31.1 From d9c581ead4da3764817939a7ff67ac3ecebab765 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 12:34:33 +0100 Subject: [PATCH 012/191] ; Fix typo in 'package--autosuggest-after-change-mode' --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 308c6ad1a51..2849c05fa41 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4686,7 +4686,7 @@ This function should be added to `after-change-major-mode-hook'." (message (substitute-command-keys (format "Found suggested packages: %s. Install using \\[package-autosuggest]" - pkgs)))p)))) + pkgs))))))) (defun package-autosuggest () "Prompt the user to install the suggested packages." From 48eefe094f3cfdd7135b1fb2a98f0699a4fb777e Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 12:44:50 +0100 Subject: [PATCH 013/191] Do not enable 'package-autosuggest-mode' by default As the feature is intrusive and can slow down startup time it is safer to disable the feature by default. * doc/emacs/package.texi (Package Installation): Explicitly mention the minor mode in the manual. * etc/NEWS: Document it here as well. * lisp/emacs-lisp/package.el (package-autosuggest-mode): Change default value to nil and autoload it. --- doc/emacs/package.texi | 6 ++++-- etc/NEWS | 6 ++++++ lisp/emacs-lisp/package.el | 3 ++- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index b91a49cbf2e..7f8b199c9f3 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -410,11 +410,13 @@ and use only third parties that you think you can trust! @cindex suggestions @findex package-autosuggest +@findex package-autosuggest-mode Emacs has a built-in database of suggested packages for certain file types. If Emacs opens a file with no specific mode, you can use the @code{package-autosuggest} command to install the recommended packages -from ELPA. By default, Emacs will display a clickable hint in the -mode-line if it there is a suggested package. +from ELPA. After enabling @code{package-autosuggest-mode}, Emacs will +display a clickable hint in the mode-line if it there is a suggested +package. @anchor{Package Signing} @cindex package security diff --git a/etc/NEWS b/etc/NEWS index a808cc30b58..dcbe75b6b8b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -666,6 +666,12 @@ the directory into which the repository was cloned. Using a built-in database of package suggestions from ELPA, this command will install viable packages if no specific major mode is available. ++++ +*** New minor mode 'package-autosuggest-mode' +When enabled, this displays a hint in the mode line indicating the +availability of a suggested package. You can customise the presentation +of these hints using 'package-autosuggest-style'. + * New Modes and Packages in Emacs 31.1 diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2849c05fa41..b5c48928fc5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4567,9 +4567,10 @@ the existence of a suggestion." (const :tag "Prompt only once" once) (const :tag "Indicate with message" message))) +;;;###autoload (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." - :init-value t :global t + :global t (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) From bf72666d41e643a842f1a18950f83874e88d588d Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 15:26:01 +0100 Subject: [PATCH 014/191] Update 'package-autosuggest' database * admin/scrape-elpa.el (scrape-elpa): Detect 'add-to-list' expressions that are "hidden" under a 'progn'. * etc/package-autosuggest.eld: Re-generate database with more packages (after having run "make autoloads") and with the above improvement. --- admin/scrape-elpa.el | 25 +++++---- etc/package-autosuggest.eld | 109 ++++++++++++++++++++++++++++++++++++ 2 files changed, 122 insertions(+), 12 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index 78dbd7349d0..0b04ba79982 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -29,7 +29,7 @@ "Scrape autoload files in DIRECTORIES for package suggestions. This file will automatically update \"package-autosuggest.eld\", but not save it. You should invoke this command with built GNU ELPA and NonGNU -ELPA checkouts (i.e. having run \"make build-all\" in both directories). +ELPA checkouts (i.e. having run \"make autoloads\" in both directories). Please review the results before updating the autosuggest database!" (interactive (completing-read-multiple "ELPA directories to scrape: " @@ -60,17 +60,18 @@ Please review the results before updating the autosuggest database!" (insert-file-contents file) (condition-case nil (while t - (pcase (read (current-buffer)) - (`(add-to-list - ',(and (or 'interpreter-mode-alist - 'magic-mode-alist - 'auto-mode-alist) - variable) - '(,(and (pred stringp) regexp) . - ,(and (pred symbolp) mode))) - (terpri) - (prin1 `(,mode ,variable ,regexp)) - (princ (concat " ;from " file))))) + (dolist (exp (macroexp-unprogn (read (current-buffer)))) + (pcase exp + (`(add-to-list + ',(and (or 'interpreter-mode-alist + 'magic-mode-alist + 'auto-mode-alist) + variable) + '(,(and (pred stringp) regexp) . + ,(and (pred symbolp) mode))) + (terpri) + (prin1 `(,mode ,variable ,regexp)) + (princ (concat " ;from " file)))))) (end-of-file nil)))))) (insert "\n)\n"))) diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index 742983fa9eb..a8977f194e5 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -41,6 +41,8 @@ (jgraph-mode auto-mode-alist "\\.jgr\\'") ;from ~/Source/elpa/packages/jgraph-mode/jgraph-mode-autoloads.el (json-mode auto-mode-alist "\\.json\\'") ;from ~/Source/elpa/packages/json-mode/json-mode-autoloads.el (lmc-asm-mode auto-mode-alist "\\.elmc\\'") ;from ~/Source/elpa/packages/lmc/lmc-autoloads.el +(tlc-mode auto-mode-alist "\\.tlc\\'") ;from ~/Source/elpa/packages/matlab-mode/matlab-mode-autoloads.el +(tlc-mode auto-mode-alist "\\.tlc\\'") ;from ~/Source/elpa/packages/matlab/matlab-autoloads.el (muse-mode-choose-mode auto-mode-alist "\\.muse\\'") ;from ~/Source/elpa/packages/muse/lisp/muse-autoloads.el (latex-mode auto-mode-alist "\\.drv\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el (doctex-mode auto-mode-alist "\\.dtx\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el @@ -75,5 +77,112 @@ (wisitoken-parse_table-mode auto-mode-alist "\\.parse_table.*\\'") ;from ~/Source/elpa/packages/wisi/wisi-autoloads.el (simple-indent-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el (wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el +(adoc-mode auto-mode-alist "\\.a\\(?:scii\\)?doc\\'") ;from ~/Source/nongnu/packages/adoc-mode/adoc-mode-autoloads.el +(apache-mode auto-mode-alist "/\\.htaccess\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el +(apache-mode auto-mode-alist "/\\(?:access\\|httpd\\|srm\\)\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el +(apache-mode auto-mode-alist "/apache2/.+\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el +(apache-mode auto-mode-alist "/httpd/conf/.+\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el +(apache-mode auto-mode-alist "/apache2/sites-\\(?:available\\|enabled\\)/") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el +(arduino-mode auto-mode-alist "\\.pde\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el +(arduino-mode auto-mode-alist "\\.ino\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el +(beancount-mode auto-mode-alist "\\.beancount\\'") ;from ~/Source/nongnu/packages/beancount/beancount-autoloads.el +(bison-mode auto-mode-alist "\\.y\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el +(flex-mode auto-mode-alist "\\.l\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el +(jison-mode auto-mode-alist "\\.jison\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el +(bqn-mode auto-mode-alist "\\.bqn\\'") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el +(bqn-mode interpreter-mode-alist "bqn") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el +(clojure-mode auto-mode-alist "\\.\\(clj\\|cljd\\|dtm\\|edn\\|lpy\\)\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojurec-mode auto-mode-alist "\\.cljc\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojurescript-mode auto-mode-alist "\\.cljs\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojure-mode auto-mode-alist "\\(?:build\\|profile\\)\\.boot\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojure-mode interpreter-mode-alist "bb") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojurescript-mode interpreter-mode-alist "nbb") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(coffee-mode auto-mode-alist "\\.coffee\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el +(coffee-mode auto-mode-alist "\\.iced\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el +(coffee-mode auto-mode-alist "Cakefile\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el +(coffee-mode auto-mode-alist "\\.cson\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el +(coffee-mode interpreter-mode-alist "coffee") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el +(d-mode auto-mode-alist "\\.d[i]?\\'") ;from ~/Source/nongnu/packages/d-mode/d-mode-autoloads.el +(dart-mode auto-mode-alist "\\.dart\\'") ;from ~/Source/nongnu/packages/dart-mode/dart-mode-autoloads.el +(dockerfile-mode auto-mode-alist "\\.dockerfile\\'") ;from ~/Source/nongnu/packages/dockerfile-mode/dockerfile-mode-autoloads.el +(php-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(conf-windows-mode auto-mode-alist "[^/]\\.info\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(drush-make-mode auto-mode-alist "[^/]\\.make\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(editorconfig-conf-mode auto-mode-alist "\\.editorconfig\\'") ;from ~/Source/nongnu/packages/editorconfig/editorconfig-autoloads.el +(elixir-mode auto-mode-alist "\\.elixir\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el +(elixir-mode auto-mode-alist "\\.ex\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el +(elixir-mode auto-mode-alist "\\.exs\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el +(elixir-mode auto-mode-alist "mix\\.lock") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el +(ett-mode auto-mode-alist "\\.ett\\'") ;from ~/Source/nongnu/packages/ett/ett-autoloads.el +(forth-mode auto-mode-alist "\\.\\(f\\|fs\\|fth\\|4th\\)\\'") ;from ~/Source/nongnu/packages/forth-mode/forth-mode-autoloads.el +(scheme-mode auto-mode-alist "\\.rkt\\'") ;from ~/Source/nongnu/packages/geiser-racket/geiser-racket-autoloads.el +(gnu-apl-mode auto-mode-alist "\\.apl\\'") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el +(gnu-apl-mode interpreter-mode-alist "apl") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el +(go-dot-mod-mode auto-mode-alist "go\\.mod\\'") ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el +(go-dot-work-mode auto-mode-alist "go\\.work\\'") ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el +(graphql-mode auto-mode-alist "\\.graphql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el +(graphql-mode auto-mode-alist "\\.gql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el +(haml-mode auto-mode-alist "\\.haml\\'") ;from ~/Source/nongnu/packages/haml-mode/haml-mode-autoloads.el +(ghc-core-mode auto-mode-alist "\\.hcr\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(ghc-core-mode auto-mode-alist "\\.dump-simpl\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(ghci-script-mode auto-mode-alist "\\.ghci\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-c2hs-mode auto-mode-alist "\\.chs\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-cabal-mode auto-mode-alist "\\.cabal\\'\\|/cabal\\.project\\|/\\.cabal/config\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.[gh]s\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.hsig\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-literate-mode auto-mode-alist "\\.l[gh]s\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.hsc\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode interpreter-mode-alist "runghc") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode interpreter-mode-alist "runhaskell") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(j-mode auto-mode-alist "\\.ij[rsp]$") ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el +(j-lab-mode auto-mode-alist "\\.ijt$") ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el +(jade-mode auto-mode-alist "\\.jade\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el +(jade-mode auto-mode-alist "\\.pug\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el +(stylus-mode auto-mode-alist "\\.styl\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el +(jinja2-mode auto-mode-alist "\\.jinja2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el +(jinja2-mode auto-mode-alist "\\.j2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el +(julia-mode auto-mode-alist "\\.jl\\'") ;from ~/Source/nongnu/packages/julia-mode/julia-mode-autoloads.el +(lua-mode auto-mode-alist "\\.lua\\'") ;from ~/Source/nongnu/packages/lua-mode/lua-mode-autoloads.el +(lua-mode interpreter-mode-alist "lua") ;from ~/Source/nongnu/packages/lua-mode/lua-mode-autoloads.el +(markdown-mode auto-mode-alist "\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'") ;from ~/Source/nongnu/packages/markdown-mode/markdown-mode-autoloads.el +(nginx-mode auto-mode-alist "nginx\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el +(nginx-mode auto-mode-alist "/nginx/.+\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el +(nix-drv-mode auto-mode-alist "^/nix/store/.+\\.drv\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el +(js-mode auto-mode-alist "\\flake.lock\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el +(nix-mode auto-mode-alist "\\.nix\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el +(php-mode auto-mode-alist "/\\.php_cs\\(?:\\.dist\\)?\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el +(php-mode auto-mode-alist "\\.\\(?:php\\.inc\\|stub\\)\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el +(php-mode-maybe auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el (coq-mode auto-mode-alist "\\.v\\'") ;from ~/Source/nongnu/packages/proof-general/generic/proof-autoloads.el +(racket-mode auto-mode-alist "\\.rkt\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el +(racket-mode auto-mode-alist "\\.rktd\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el +(racket-mode auto-mode-alist "\\.rktl\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el +(racket-mode interpreter-mode-alist "racket") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el +(raku-mode interpreter-mode-alist "perl6\\|raku") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el +(raku-mode auto-mode-alist "\\.p[lm]?6\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el +(raku-mode auto-mode-alist "\\.nqp\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el +(raku-mode auto-mode-alist "\\.raku\\(?:mod\\|test\\)?\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el +(rfc-mode auto-mode-alist "/rfc[0-9]+\\.txt\\'") ;from ~/Source/nongnu/packages/rfc-mode/rfc-mode-autoloads.el +(rust-mode auto-mode-alist "\\.rs\\'") ;from ~/Source/nongnu/packages/rust-mode/rust-mode-autoloads.el +(sass-mode auto-mode-alist "\\.sass\\'") ;from ~/Source/nongnu/packages/sass-mode/sass-mode-autoloads.el +(scad-mode auto-mode-alist "\\.scad\\'") ;from ~/Source/nongnu/packages/scad-mode/scad-mode-autoloads.el +(scala-mode auto-mode-alist "\\.\\(scala\\|sbt\\|worksheet\\.sc\\)\\'") ;from ~/Source/nongnu/packages/scala-mode/scala-mode-autoloads.el +(jade-mode auto-mode-alist "\\.jade\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el +(jade-mode auto-mode-alist "\\.pug\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el +(stylus-mode auto-mode-alist "\\.styl\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el +(subed-ass-mode auto-mode-alist "\\.ass\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(subed-srt-mode auto-mode-alist "\\.srt\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(subed-vtt-mode auto-mode-alist "\\.vtt\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(swift-mode auto-mode-alist "\\.swift\\(interface\\)?\\'") ;from ~/Source/nongnu/packages/swift-mode/swift-mode-autoloads.el +(systemd-mode auto-mode-alist "\\.nspawn\\'") ;from ~/Source/nongnu/packages/systemd/systemd-autoloads.el +(tuareg-mode auto-mode-alist "\\.ml[ip]?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg-mode auto-mode-alist "\\.eliomi?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg-mode interpreter-mode-alist "ocamlrun") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg-mode interpreter-mode-alist "ocaml") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg-menhir-mode auto-mode-alist "\\.mly\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg-opam-mode auto-mode-alist "[./]opam_?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(typescript-mode auto-mode-alist "\\.ts\\'") ;from ~/Source/nongnu/packages/typescript-mode/typescript-mode-autoloads.el +(yaml-mode auto-mode-alist "\\.\\(e?ya?\\|ra\\)ml\\'") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el +(yaml-mode magic-mode-alist "^%YAML\\s-+[0-9]+\\.[0-9]+\\(\\s-+#\\|\\s-*$\\)") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el +(zig-mode auto-mode-alist "\\.\\(zig\\|zon\\)\\'") ;from ~/Source/nongnu/packages/zig-mode/zig-mode-autoloads.el ) From 450c49af1c629c06669732ca12869f747f773963 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 15:56:52 +0100 Subject: [PATCH 015/191] Distinguish between suggested packages and major modes * admin/scrape-elpa.el (scrape-elpa): Infer package names from autoloads file. * etc/package-autosuggest.eld: Recompute database. * lisp/emacs-lisp/package.el (package-autosuggest-database): Update documentation to clarify how the major mode can be explicitly indicated. (package--suggestion-applies-p): Handle the optional fourth element. --- admin/scrape-elpa.el | 7 +- etc/package-autosuggest.eld | 168 ++++++++++++++++++------------------ lisp/emacs-lisp/package.el | 15 ++-- 3 files changed, 99 insertions(+), 91 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index 0b04ba79982..ef2b189883e 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -55,7 +55,9 @@ Please review the results before updating the autosuggest database!" dir "-autoloads\\.el\\'")) directories)) "Scraping files..." - (let ((inhibit-message t)) + (and-let* (((string-match "/\\([^/]+?\\)-autoloads\\.el\\'" file)) + (pkg (intern (match-string 1 file))) + (inhibit-message t)) (with-temp-buffer (insert-file-contents file) (condition-case nil @@ -70,7 +72,8 @@ Please review the results before updating the autosuggest database!" '(,(and (pred stringp) regexp) . ,(and (pred symbolp) mode))) (terpri) - (prin1 `(,mode ,variable ,regexp)) + (prin1 (append (list pkg variable regexp) + (and (not (eq pkg mode)) (list mode)))) (princ (concat " ;from " file)))))) (end-of-file nil)))))) (insert "\n)\n"))) diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index a8977f194e5..38cf121a49e 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -5,47 +5,47 @@ ( (ada-mode auto-mode-alist "\\.ad[abs]\\'") ;from ~/Source/elpa/packages/ada-mode/ada-mode-autoloads.el -(arbitools-mode auto-mode-alist "\\.trf?\\'") ;from ~/Source/elpa/packages/arbitools/arbitools-autoloads.el -(LaTeX-mode auto-mode-alist "\\.hva\\'") ;from ~/Source/elpa/packages/auctex/auctex-autoloads.el +(arbitools auto-mode-alist "\\.trf?\\'" arbitools-mode) ;from ~/Source/elpa/packages/arbitools/arbitools-autoloads.el +(auctex auto-mode-alist "\\.hva\\'" LaTeX-mode) ;from ~/Source/elpa/packages/auctex/auctex-autoloads.el (bnf-mode auto-mode-alist "\\.bnf\\'") ;from ~/Source/elpa/packages/bnf-mode/bnf-mode-autoloads.el -(chess-pgn-mode auto-mode-alist "\\.pgn\\'") ;from ~/Source/elpa/packages/chess/chess-autoloads.el +(chess auto-mode-alist "\\.pgn\\'" chess-pgn-mode) ;from ~/Source/elpa/packages/chess/chess-autoloads.el (cobol-mode auto-mode-alist "\\.c\\(ob\\|bl\\|py\\)\\'") ;from ~/Source/elpa/packages/cobol-mode/cobol-mode-autoloads.el -(code-cells-convert-ipynb auto-mode-alist "\\.ipynb\\'") ;from ~/Source/elpa/packages/code-cells/code-cells-autoloads.el +(code-cells auto-mode-alist "\\.ipynb\\'" code-cells-convert-ipynb) ;from ~/Source/elpa/packages/code-cells/code-cells-autoloads.el (csharp-mode auto-mode-alist "\\.cs\\'") ;from ~/Source/elpa/packages/csharp-mode/csharp-mode-autoloads.el (csv-mode auto-mode-alist "\\.[Cc][Ss][Vv]\\'") ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el -(tsv-mode auto-mode-alist "\\.tsv\\'") ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el -(dismal-mode auto-mode-alist "\\.dis\\'") ;from ~/Source/elpa/packages/dismal/dismal-autoloads.el -(djvu-init-mode auto-mode-alist "\\.djvu\\'") ;from ~/Source/elpa/packages/djvu/djvu-autoloads.el +(csv-mode auto-mode-alist "\\.tsv\\'" tsv-mode) ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el +(dismal auto-mode-alist "\\.dis\\'" dismal-mode) ;from ~/Source/elpa/packages/dismal/dismal-autoloads.el +(djvu auto-mode-alist "\\.djvu\\'" djvu-init-mode) ;from ~/Source/elpa/packages/djvu/djvu-autoloads.el (dts-mode auto-mode-alist "\\.dtsi?\\'") ;from ~/Source/elpa/packages/dts-mode/dts-mode-autoloads.el -(ess-bugs-mode auto-mode-alist "\\.[Bb][Uu][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-bugs-mode auto-mode-alist "\\.[Bb][Oo][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-bugs-mode auto-mode-alist "\\.[Bb][Mm][Dd]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-jags-mode auto-mode-alist "\\.[Jj][Aa][Gg]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode auto-mode-alist "/R/.*\\.q\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode auto-mode-alist "\\.[rR]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode auto-mode-alist "\\.[rR]profile\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode auto-mode-alist "NAMESPACE\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode auto-mode-alist "CITATION\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-transcript-mode auto-mode-alist "\\.[Rr]out\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode interpreter-mode-alist "Rscript") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess-r-mode interpreter-mode-alist "r") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(makefile-mode auto-mode-alist "/Makevars\\(\\.win\\)?\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(conf-colon-mode auto-mode-alist "DESCRIPTION\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(Rd-mode auto-mode-alist "\\.Rd\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(S-transcript-mode auto-mode-alist "\\.[Ss]t\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(S-transcript-mode auto-mode-alist "\\.Sout\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(SAS-mode auto-mode-alist "\\.[Ss][Aa][Ss]\\'") ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Bb][Uu][Gg]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Bb][Oo][Gg]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Bb][Mm][Dd]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Jj][Aa][Gg]\\'" ess-jags-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "/R/.*\\.q\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[rR]\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[rR]profile\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "NAMESPACE\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "CITATION\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Rr]out\\'" ess-r-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess interpreter-mode-alist "Rscript" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess interpreter-mode-alist "r" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "/Makevars\\(\\.win\\)?\\'" makefile-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "DESCRIPTION\\'" conf-colon-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.Rd\\'" Rd-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Ss]t\\'" S-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.Sout\\'" S-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el +(ess auto-mode-alist "\\.[Ss][Aa][Ss]\\'" SAS-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el (gle-mode auto-mode-alist "\\.gle\\'") ;from ~/Source/elpa/packages/gle-mode/gle-mode-autoloads.el (gpr-mode auto-mode-alist "\\.gpr\\'") ;from ~/Source/elpa/packages/gpr-mode/gpr-mode-autoloads.el -(nxml-mode auto-mode-alist "\\.html?\\'") ;from ~/Source/elpa/packages/html5-schema/html5-schema-autoloads.el +(html5-schema auto-mode-alist "\\.html?\\'" nxml-mode) ;from ~/Source/elpa/packages/html5-schema/html5-schema-autoloads.el (jgraph-mode auto-mode-alist "\\.jgr\\'") ;from ~/Source/elpa/packages/jgraph-mode/jgraph-mode-autoloads.el (json-mode auto-mode-alist "\\.json\\'") ;from ~/Source/elpa/packages/json-mode/json-mode-autoloads.el -(lmc-asm-mode auto-mode-alist "\\.elmc\\'") ;from ~/Source/elpa/packages/lmc/lmc-autoloads.el -(tlc-mode auto-mode-alist "\\.tlc\\'") ;from ~/Source/elpa/packages/matlab-mode/matlab-mode-autoloads.el -(tlc-mode auto-mode-alist "\\.tlc\\'") ;from ~/Source/elpa/packages/matlab/matlab-autoloads.el -(muse-mode-choose-mode auto-mode-alist "\\.muse\\'") ;from ~/Source/elpa/packages/muse/lisp/muse-autoloads.el -(latex-mode auto-mode-alist "\\.drv\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el -(doctex-mode auto-mode-alist "\\.dtx\\'") ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el +(lmc auto-mode-alist "\\.elmc\\'" lmc-asm-mode) ;from ~/Source/elpa/packages/lmc/lmc-autoloads.el +(matlab-mode auto-mode-alist "\\.tlc\\'" tlc-mode) ;from ~/Source/elpa/packages/matlab-mode/matlab-mode-autoloads.el +(matlab auto-mode-alist "\\.tlc\\'" tlc-mode) ;from ~/Source/elpa/packages/matlab/matlab-autoloads.el +(muse auto-mode-alist "\\.muse\\'" muse-mode-choose-mode) ;from ~/Source/elpa/packages/muse/lisp/muse-autoloads.el +(auctex auto-mode-alist "\\.drv\\'" latex-mode) ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el +(auctex auto-mode-alist "\\.dtx\\'" doctex-mode) ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el (nftables-mode auto-mode-alist "\\.nft\\(?:ables\\)?\\'") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el (nftables-mode auto-mode-alist "/etc/nftables.conf") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el (nftables-mode interpreter-mode-alist "nft\\(?:ables\\)?") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el @@ -53,7 +53,7 @@ (omn-mode auto-mode-alist "\\.omn\\'") ;from ~/Source/elpa/packages/omn-mode/omn-mode-autoloads.el (poke-mode auto-mode-alist "\\.pk\\'") ;from ~/Source/elpa/packages/poke-mode/poke-mode-autoloads.el (pspp-mode auto-mode-alist "\\.sps\\'") ;from ~/Source/elpa/packages/pspp-mode/pspp-mode-autoloads.el -(conf-mode auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'") ;from ~/Source/elpa/packages/python/python-autoloads.el +(python auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'" conf-mode) ;from ~/Source/elpa/packages/python/python-autoloads.el (rec-mode auto-mode-alist "\\.rec\\'") ;from ~/Source/elpa/packages/rec-mode/rec-mode-autoloads.el (rnc-mode auto-mode-alist "\\.rnc\\'") ;from ~/Source/elpa/packages/rnc-mode/rnc-mode-autoloads.el (sed-mode auto-mode-alist "\\.sed\\'") ;from ~/Source/elpa/packages/sed-mode/sed-mode-autoloads.el @@ -62,20 +62,20 @@ (sisu-mode auto-mode-alist "\\.ss[imt]\\'") ;from ~/Source/elpa/packages/sisu-mode/sisu-mode-autoloads.el (smalltalk-mode auto-mode-alist "\\.st\\'") ;from ~/Source/elpa/packages/smalltalk-mode/smalltalk-mode-autoloads.el (sml-mode auto-mode-alist "\\.s\\(ml\\|ig\\)\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sml-cm-mode auto-mode-alist "\\.cm\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sml-yacc-mode auto-mode-alist "\\.grm\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sql-mode auto-mode-alist "\\.cql\\'") ;from ~/Source/elpa/packages/sql-cassandra/sql-cassandra-autoloads.el +(sml-mode auto-mode-alist "\\.cm\\'" sml-cm-mode) ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el +(sml-mode auto-mode-alist "\\.grm\\'" sml-yacc-mode) ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el +(sql-cassandra auto-mode-alist "\\.cql\\'" sql-mode) ;from ~/Source/elpa/packages/sql-cassandra/sql-cassandra-autoloads.el (sxhkdrc-mode auto-mode-alist "sxhkdrc\\'") ;from ~/Source/elpa/packages/sxhkdrc-mode/sxhkdrc-mode-autoloads.el -(systemd-automount-mode auto-mode-alist "\\.automount\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-mount-mode auto-mode-alist "\\.mount\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-path-mode auto-mode-alist "\\.path\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-service-mode auto-mode-alist "\\.service\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-socket-mode auto-mode-alist "\\.socket\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-swap-mode auto-mode-alist "\\.swap\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd-timer-mode auto-mode-alist "\\.timer\\'") ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(vcard-mode auto-mode-alist "\\.[Vv][Cc][Ff]\\'") ;from ~/Source/elpa/packages/vcard/vcard-autoloads.el -(wisitoken-parse_table-mode auto-mode-alist "\\.parse_table.*\\'") ;from ~/Source/elpa/packages/wisi/wisi-autoloads.el -(simple-indent-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el +(systemd auto-mode-alist "\\.automount\\'" systemd-automount-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.mount\\'" systemd-mount-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.path\\'" systemd-path-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.service\\'" systemd-service-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.socket\\'" systemd-socket-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.swap\\'" systemd-swap-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(systemd auto-mode-alist "\\.timer\\'" systemd-timer-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el +(vcard auto-mode-alist "\\.[Vv][Cc][Ff]\\'" vcard-mode) ;from ~/Source/elpa/packages/vcard/vcard-autoloads.el +(wisi auto-mode-alist "\\.parse_table.*\\'" wisitoken-parse_table-mode) ;from ~/Source/elpa/packages/wisi/wisi-autoloads.el +(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'" simple-indent-mode) ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el (wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el (adoc-mode auto-mode-alist "\\.a\\(?:scii\\)?doc\\'") ;from ~/Source/nongnu/packages/adoc-mode/adoc-mode-autoloads.el (apache-mode auto-mode-alist "/\\.htaccess\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el @@ -85,18 +85,18 @@ (apache-mode auto-mode-alist "/apache2/sites-\\(?:available\\|enabled\\)/") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el (arduino-mode auto-mode-alist "\\.pde\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el (arduino-mode auto-mode-alist "\\.ino\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el -(beancount-mode auto-mode-alist "\\.beancount\\'") ;from ~/Source/nongnu/packages/beancount/beancount-autoloads.el +(beancount auto-mode-alist "\\.beancount\\'" beancount-mode) ;from ~/Source/nongnu/packages/beancount/beancount-autoloads.el (bison-mode auto-mode-alist "\\.y\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el -(flex-mode auto-mode-alist "\\.l\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el -(jison-mode auto-mode-alist "\\.jison\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el +(bison-mode auto-mode-alist "\\.l\\'" flex-mode) ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el +(bison-mode auto-mode-alist "\\.jison\\'" jison-mode) ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el (bqn-mode auto-mode-alist "\\.bqn\\'") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el (bqn-mode interpreter-mode-alist "bqn") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el (clojure-mode auto-mode-alist "\\.\\(clj\\|cljd\\|dtm\\|edn\\|lpy\\)\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojurec-mode auto-mode-alist "\\.cljc\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojurescript-mode auto-mode-alist "\\.cljs\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojure-mode auto-mode-alist "\\.cljc\\'" clojurec-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojure-mode auto-mode-alist "\\.cljs\\'" clojurescript-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el (clojure-mode auto-mode-alist "\\(?:build\\|profile\\)\\.boot\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el (clojure-mode interpreter-mode-alist "bb") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojurescript-mode interpreter-mode-alist "nbb") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el +(clojure-mode interpreter-mode-alist "nbb" clojurescript-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el (coffee-mode auto-mode-alist "\\.coffee\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el (coffee-mode auto-mode-alist "\\.iced\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el (coffee-mode auto-mode-alist "Cakefile\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el @@ -105,40 +105,40 @@ (d-mode auto-mode-alist "\\.d[i]?\\'") ;from ~/Source/nongnu/packages/d-mode/d-mode-autoloads.el (dart-mode auto-mode-alist "\\.dart\\'") ;from ~/Source/nongnu/packages/dart-mode/dart-mode-autoloads.el (dockerfile-mode auto-mode-alist "\\.dockerfile\\'") ;from ~/Source/nongnu/packages/dockerfile-mode/dockerfile-mode-autoloads.el -(php-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(conf-windows-mode auto-mode-alist "[^/]\\.info\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(drush-make-mode auto-mode-alist "[^/]\\.make\\'") ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(editorconfig-conf-mode auto-mode-alist "\\.editorconfig\\'") ;from ~/Source/nongnu/packages/editorconfig/editorconfig-autoloads.el +(drupal-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'" php-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(drupal-mode auto-mode-alist "[^/]\\.info\\'" conf-windows-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(drupal-mode auto-mode-alist "[^/]\\.make\\'" drush-make-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el +(editorconfig auto-mode-alist "\\.editorconfig\\'" editorconfig-conf-mode) ;from ~/Source/nongnu/packages/editorconfig/editorconfig-autoloads.el (elixir-mode auto-mode-alist "\\.elixir\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el (elixir-mode auto-mode-alist "\\.ex\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el (elixir-mode auto-mode-alist "\\.exs\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el (elixir-mode auto-mode-alist "mix\\.lock") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el -(ett-mode auto-mode-alist "\\.ett\\'") ;from ~/Source/nongnu/packages/ett/ett-autoloads.el +(ett auto-mode-alist "\\.ett\\'" ett-mode) ;from ~/Source/nongnu/packages/ett/ett-autoloads.el (forth-mode auto-mode-alist "\\.\\(f\\|fs\\|fth\\|4th\\)\\'") ;from ~/Source/nongnu/packages/forth-mode/forth-mode-autoloads.el -(scheme-mode auto-mode-alist "\\.rkt\\'") ;from ~/Source/nongnu/packages/geiser-racket/geiser-racket-autoloads.el +(geiser-racket auto-mode-alist "\\.rkt\\'" scheme-mode) ;from ~/Source/nongnu/packages/geiser-racket/geiser-racket-autoloads.el (gnu-apl-mode auto-mode-alist "\\.apl\\'") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el (gnu-apl-mode interpreter-mode-alist "apl") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el -(go-dot-mod-mode auto-mode-alist "go\\.mod\\'") ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el -(go-dot-work-mode auto-mode-alist "go\\.work\\'") ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el +(go-mode auto-mode-alist "go\\.mod\\'" go-dot-mod-mode) ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el +(go-mode auto-mode-alist "go\\.work\\'" go-dot-work-mode) ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el (graphql-mode auto-mode-alist "\\.graphql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el (graphql-mode auto-mode-alist "\\.gql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el (haml-mode auto-mode-alist "\\.haml\\'") ;from ~/Source/nongnu/packages/haml-mode/haml-mode-autoloads.el -(ghc-core-mode auto-mode-alist "\\.hcr\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(ghc-core-mode auto-mode-alist "\\.dump-simpl\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(ghci-script-mode auto-mode-alist "\\.ghci\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-c2hs-mode auto-mode-alist "\\.chs\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-cabal-mode auto-mode-alist "\\.cabal\\'\\|/cabal\\.project\\|/\\.cabal/config\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.hcr\\'" ghc-core-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.dump-simpl\\'" ghc-core-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.ghci\\'" ghci-script-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.chs\\'" haskell-c2hs-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.cabal\\'\\|/cabal\\.project\\|/\\.cabal/config\\'" haskell-cabal-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (haskell-mode auto-mode-alist "\\.[gh]s\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (haskell-mode auto-mode-alist "\\.hsig\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-literate-mode auto-mode-alist "\\.l[gh]s\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el +(haskell-mode auto-mode-alist "\\.l[gh]s\\'" haskell-literate-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (haskell-mode auto-mode-alist "\\.hsc\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (haskell-mode interpreter-mode-alist "runghc") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (haskell-mode interpreter-mode-alist "runhaskell") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el (j-mode auto-mode-alist "\\.ij[rsp]$") ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el -(j-lab-mode auto-mode-alist "\\.ijt$") ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el +(j-mode auto-mode-alist "\\.ijt$" j-lab-mode) ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el (jade-mode auto-mode-alist "\\.jade\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el (jade-mode auto-mode-alist "\\.pug\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el -(stylus-mode auto-mode-alist "\\.styl\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el +(jade-mode auto-mode-alist "\\.styl\\'" stylus-mode) ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el (jinja2-mode auto-mode-alist "\\.jinja2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el (jinja2-mode auto-mode-alist "\\.j2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el (julia-mode auto-mode-alist "\\.jl\\'") ;from ~/Source/nongnu/packages/julia-mode/julia-mode-autoloads.el @@ -147,13 +147,13 @@ (markdown-mode auto-mode-alist "\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'") ;from ~/Source/nongnu/packages/markdown-mode/markdown-mode-autoloads.el (nginx-mode auto-mode-alist "nginx\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el (nginx-mode auto-mode-alist "/nginx/.+\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el -(nix-drv-mode auto-mode-alist "^/nix/store/.+\\.drv\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el -(js-mode auto-mode-alist "\\flake.lock\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el +(nix-mode auto-mode-alist "^/nix/store/.+\\.drv\\'" nix-drv-mode) ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el +(nix-mode auto-mode-alist "\\flake.lock\\'" js-mode) ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el (nix-mode auto-mode-alist "\\.nix\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el (php-mode auto-mode-alist "/\\.php_cs\\(?:\\.dist\\)?\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el (php-mode auto-mode-alist "\\.\\(?:php\\.inc\\|stub\\)\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el -(php-mode-maybe auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el -(coq-mode auto-mode-alist "\\.v\\'") ;from ~/Source/nongnu/packages/proof-general/generic/proof-autoloads.el +(php-mode auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'" php-mode-maybe) ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el +(proof auto-mode-alist "\\.v\\'" coq-mode) ;from ~/Source/nongnu/packages/proof-general/generic/proof-autoloads.el (racket-mode auto-mode-alist "\\.rkt\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el (racket-mode auto-mode-alist "\\.rktd\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el (racket-mode auto-mode-alist "\\.rktl\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el @@ -167,20 +167,20 @@ (sass-mode auto-mode-alist "\\.sass\\'") ;from ~/Source/nongnu/packages/sass-mode/sass-mode-autoloads.el (scad-mode auto-mode-alist "\\.scad\\'") ;from ~/Source/nongnu/packages/scad-mode/scad-mode-autoloads.el (scala-mode auto-mode-alist "\\.\\(scala\\|sbt\\|worksheet\\.sc\\)\\'") ;from ~/Source/nongnu/packages/scala-mode/scala-mode-autoloads.el -(jade-mode auto-mode-alist "\\.jade\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el -(jade-mode auto-mode-alist "\\.pug\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el +(stylus-mode auto-mode-alist "\\.jade\\'" jade-mode) ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el +(stylus-mode auto-mode-alist "\\.pug\\'" jade-mode) ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el (stylus-mode auto-mode-alist "\\.styl\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el -(subed-ass-mode auto-mode-alist "\\.ass\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el -(subed-srt-mode auto-mode-alist "\\.srt\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el -(subed-vtt-mode auto-mode-alist "\\.vtt\\'") ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(subed auto-mode-alist "\\.ass\\'" subed-ass-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(subed auto-mode-alist "\\.srt\\'" subed-srt-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el +(subed auto-mode-alist "\\.vtt\\'" subed-vtt-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el (swift-mode auto-mode-alist "\\.swift\\(interface\\)?\\'") ;from ~/Source/nongnu/packages/swift-mode/swift-mode-autoloads.el -(systemd-mode auto-mode-alist "\\.nspawn\\'") ;from ~/Source/nongnu/packages/systemd/systemd-autoloads.el -(tuareg-mode auto-mode-alist "\\.ml[ip]?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg-mode auto-mode-alist "\\.eliomi?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg-mode interpreter-mode-alist "ocamlrun") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg-mode interpreter-mode-alist "ocaml") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg-menhir-mode auto-mode-alist "\\.mly\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg-opam-mode auto-mode-alist "[./]opam_?\\'") ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(systemd auto-mode-alist "\\.nspawn\\'" systemd-mode) ;from ~/Source/nongnu/packages/systemd/systemd-autoloads.el +(tuareg auto-mode-alist "\\.ml[ip]?\\'" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg auto-mode-alist "\\.eliomi?\\'" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg interpreter-mode-alist "ocamlrun" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg interpreter-mode-alist "ocaml" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg auto-mode-alist "\\.mly\\'" tuareg-menhir-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el +(tuareg auto-mode-alist "[./]opam_?\\'" tuareg-opam-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el (typescript-mode auto-mode-alist "\\.ts\\'") ;from ~/Source/nongnu/packages/typescript-mode/typescript-mode-autoloads.el (yaml-mode auto-mode-alist "\\.\\(e?ya?\\|ra\\)ml\\'") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el (yaml-mode magic-mode-alist "^%YAML\\s-+[0-9]+\\.[0-9]+\\(\\s-+#\\|\\s-*$\\)") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index b5c48928fc5..2ded76c0832 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4547,12 +4547,14 @@ the `Version:' header." (read (current-buffer)))) "List of hints for packages to suggest installing. Each hint has the form (PACKAGE TYPE DATA), where PACKAGE is a symbol -denoting the package the hint applies to, TYPE is one of +denoting the package and major-mode the hint applies to, TYPE is one of `auto-mode-alist', `magic-mode-alist' or `interpreter-mode-alist' indicating the type of check to be made and DATA is the value to check against TYPE in the intuitive way (e.g. for `auto-mode-alist' DATA is a regular expression matching a file name that PACKAGE should be suggested -for).") +for). If the package name and the major mode name differ, then an +optional forth element MAJOR-MODE can indicate what command to invoke to +enable the package.") (defcustom package-autosuggest-style 'mode-line "How to draw attention to `package-autosuggest-mode' suggestions. @@ -4591,15 +4593,18 @@ SUG should be an element of `package-autosuggest-database'." (pred package-installed-p)) . ,_) nil) - (`(,_ auto-mode-alist ,ext) + ((or `(,_ auto-mode-alist ,ext ,_) + `(,_ auto-mode-alist ,ext)) (and (string-match-p ext (buffer-name)) t)) - (`(,_ magic-mode-alist ,mag) + ((or `(,_ magic-mode-alist ,mag ,_) + `(,_ magic-mode-alist ,mag)) (save-restriction (widen) (save-excursion (goto-char (point-min)) (looking-at-p mag)))) - (`(,_ interpreter-mode-alist ,magic) + ((or `(,_ interpreter-mode-alist ,magic ,_) + `(,_ interpreter-mode-alist ,magic)) (save-restriction (widen) (save-excursion From 40f15ff2dd124e2f7263f0c2c14badb20222a1c3 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 16:10:13 +0100 Subject: [PATCH 016/191] Drop comments indicating origin of package sugggestions * admin/scrape-elpa.el (scrape-elpa): Do it. * etc/package-autosuggest.eld: Regenerate file. --- admin/scrape-elpa.el | 3 +- etc/package-autosuggest.eld | 362 ++++++++++++++++++------------------ 2 files changed, 182 insertions(+), 183 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index ef2b189883e..bf3846c0fcb 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -73,8 +73,7 @@ Please review the results before updating the autosuggest database!" ,(and (pred symbolp) mode))) (terpri) (prin1 (append (list pkg variable regexp) - (and (not (eq pkg mode)) (list mode)))) - (princ (concat " ;from " file)))))) + (and (not (eq pkg mode)) (list mode)))))))) (end-of-file nil)))))) (insert "\n)\n"))) diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index 38cf121a49e..cf8b8288e27 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -4,185 +4,185 @@ ;; file manually! ( -(ada-mode auto-mode-alist "\\.ad[abs]\\'") ;from ~/Source/elpa/packages/ada-mode/ada-mode-autoloads.el -(arbitools auto-mode-alist "\\.trf?\\'" arbitools-mode) ;from ~/Source/elpa/packages/arbitools/arbitools-autoloads.el -(auctex auto-mode-alist "\\.hva\\'" LaTeX-mode) ;from ~/Source/elpa/packages/auctex/auctex-autoloads.el -(bnf-mode auto-mode-alist "\\.bnf\\'") ;from ~/Source/elpa/packages/bnf-mode/bnf-mode-autoloads.el -(chess auto-mode-alist "\\.pgn\\'" chess-pgn-mode) ;from ~/Source/elpa/packages/chess/chess-autoloads.el -(cobol-mode auto-mode-alist "\\.c\\(ob\\|bl\\|py\\)\\'") ;from ~/Source/elpa/packages/cobol-mode/cobol-mode-autoloads.el -(code-cells auto-mode-alist "\\.ipynb\\'" code-cells-convert-ipynb) ;from ~/Source/elpa/packages/code-cells/code-cells-autoloads.el -(csharp-mode auto-mode-alist "\\.cs\\'") ;from ~/Source/elpa/packages/csharp-mode/csharp-mode-autoloads.el -(csv-mode auto-mode-alist "\\.[Cc][Ss][Vv]\\'") ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el -(csv-mode auto-mode-alist "\\.tsv\\'" tsv-mode) ;from ~/Source/elpa/packages/csv-mode/csv-mode-autoloads.el -(dismal auto-mode-alist "\\.dis\\'" dismal-mode) ;from ~/Source/elpa/packages/dismal/dismal-autoloads.el -(djvu auto-mode-alist "\\.djvu\\'" djvu-init-mode) ;from ~/Source/elpa/packages/djvu/djvu-autoloads.el -(dts-mode auto-mode-alist "\\.dtsi?\\'") ;from ~/Source/elpa/packages/dts-mode/dts-mode-autoloads.el -(ess auto-mode-alist "\\.[Bb][Uu][Gg]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Bb][Oo][Gg]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Bb][Mm][Dd]\\'" ess-bugs-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Jj][Aa][Gg]\\'" ess-jags-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "/R/.*\\.q\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[rR]\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[rR]profile\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "NAMESPACE\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "CITATION\\'" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Rr]out\\'" ess-r-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess interpreter-mode-alist "Rscript" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess interpreter-mode-alist "r" ess-r-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "/Makevars\\(\\.win\\)?\\'" makefile-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "DESCRIPTION\\'" conf-colon-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.Rd\\'" Rd-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Ss]t\\'" S-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.Sout\\'" S-transcript-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(ess auto-mode-alist "\\.[Ss][Aa][Ss]\\'" SAS-mode) ;from ~/Source/elpa/packages/ess/lisp/ess-autoloads.el -(gle-mode auto-mode-alist "\\.gle\\'") ;from ~/Source/elpa/packages/gle-mode/gle-mode-autoloads.el -(gpr-mode auto-mode-alist "\\.gpr\\'") ;from ~/Source/elpa/packages/gpr-mode/gpr-mode-autoloads.el -(html5-schema auto-mode-alist "\\.html?\\'" nxml-mode) ;from ~/Source/elpa/packages/html5-schema/html5-schema-autoloads.el -(jgraph-mode auto-mode-alist "\\.jgr\\'") ;from ~/Source/elpa/packages/jgraph-mode/jgraph-mode-autoloads.el -(json-mode auto-mode-alist "\\.json\\'") ;from ~/Source/elpa/packages/json-mode/json-mode-autoloads.el -(lmc auto-mode-alist "\\.elmc\\'" lmc-asm-mode) ;from ~/Source/elpa/packages/lmc/lmc-autoloads.el -(matlab-mode auto-mode-alist "\\.tlc\\'" tlc-mode) ;from ~/Source/elpa/packages/matlab-mode/matlab-mode-autoloads.el -(matlab auto-mode-alist "\\.tlc\\'" tlc-mode) ;from ~/Source/elpa/packages/matlab/matlab-autoloads.el -(muse auto-mode-alist "\\.muse\\'" muse-mode-choose-mode) ;from ~/Source/elpa/packages/muse/lisp/muse-autoloads.el -(auctex auto-mode-alist "\\.drv\\'" latex-mode) ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el -(auctex auto-mode-alist "\\.dtx\\'" doctex-mode) ;from ~/Source/elpa/packages/names/tests/auctex-11.87.7/auctex-autoloads.el -(nftables-mode auto-mode-alist "\\.nft\\(?:ables\\)?\\'") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el -(nftables-mode auto-mode-alist "/etc/nftables.conf") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el -(nftables-mode interpreter-mode-alist "nft\\(?:ables\\)?") ;from ~/Source/elpa/packages/nftables-mode/nftables-mode-autoloads.el -(omn-mode auto-mode-alist "\\.pomn\\'") ;from ~/Source/elpa/packages/omn-mode/omn-mode-autoloads.el -(omn-mode auto-mode-alist "\\.omn\\'") ;from ~/Source/elpa/packages/omn-mode/omn-mode-autoloads.el -(poke-mode auto-mode-alist "\\.pk\\'") ;from ~/Source/elpa/packages/poke-mode/poke-mode-autoloads.el -(pspp-mode auto-mode-alist "\\.sps\\'") ;from ~/Source/elpa/packages/pspp-mode/pspp-mode-autoloads.el -(python auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'" conf-mode) ;from ~/Source/elpa/packages/python/python-autoloads.el -(rec-mode auto-mode-alist "\\.rec\\'") ;from ~/Source/elpa/packages/rec-mode/rec-mode-autoloads.el -(rnc-mode auto-mode-alist "\\.rnc\\'") ;from ~/Source/elpa/packages/rnc-mode/rnc-mode-autoloads.el -(sed-mode auto-mode-alist "\\.sed\\'") ;from ~/Source/elpa/packages/sed-mode/sed-mode-autoloads.el -(sed-mode interpreter-mode-alist "sed") ;from ~/Source/elpa/packages/sed-mode/sed-mode-autoloads.el -(shen-mode auto-mode-alist "\\.shen\\'") ;from ~/Source/elpa/packages/shen-mode/shen-mode-autoloads.el -(sisu-mode auto-mode-alist "\\.ss[imt]\\'") ;from ~/Source/elpa/packages/sisu-mode/sisu-mode-autoloads.el -(smalltalk-mode auto-mode-alist "\\.st\\'") ;from ~/Source/elpa/packages/smalltalk-mode/smalltalk-mode-autoloads.el -(sml-mode auto-mode-alist "\\.s\\(ml\\|ig\\)\\'") ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sml-mode auto-mode-alist "\\.cm\\'" sml-cm-mode) ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sml-mode auto-mode-alist "\\.grm\\'" sml-yacc-mode) ;from ~/Source/elpa/packages/sml-mode/sml-mode-autoloads.el -(sql-cassandra auto-mode-alist "\\.cql\\'" sql-mode) ;from ~/Source/elpa/packages/sql-cassandra/sql-cassandra-autoloads.el -(sxhkdrc-mode auto-mode-alist "sxhkdrc\\'") ;from ~/Source/elpa/packages/sxhkdrc-mode/sxhkdrc-mode-autoloads.el -(systemd auto-mode-alist "\\.automount\\'" systemd-automount-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.mount\\'" systemd-mount-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.path\\'" systemd-path-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.service\\'" systemd-service-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.socket\\'" systemd-socket-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.swap\\'" systemd-swap-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(systemd auto-mode-alist "\\.timer\\'" systemd-timer-mode) ;from ~/Source/elpa/packages/systemd/systemd-autoloads.el -(vcard auto-mode-alist "\\.[Vv][Cc][Ff]\\'" vcard-mode) ;from ~/Source/elpa/packages/vcard/vcard-autoloads.el -(wisi auto-mode-alist "\\.parse_table.*\\'" wisitoken-parse_table-mode) ;from ~/Source/elpa/packages/wisi/wisi-autoloads.el -(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'" simple-indent-mode) ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el -(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") ;from ~/Source/elpa/packages/wisitoken-grammar-mode/wisitoken-grammar-mode-autoloads.el -(adoc-mode auto-mode-alist "\\.a\\(?:scii\\)?doc\\'") ;from ~/Source/nongnu/packages/adoc-mode/adoc-mode-autoloads.el -(apache-mode auto-mode-alist "/\\.htaccess\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el -(apache-mode auto-mode-alist "/\\(?:access\\|httpd\\|srm\\)\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el -(apache-mode auto-mode-alist "/apache2/.+\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el -(apache-mode auto-mode-alist "/httpd/conf/.+\\.conf\\'") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el -(apache-mode auto-mode-alist "/apache2/sites-\\(?:available\\|enabled\\)/") ;from ~/Source/nongnu/packages/apache-mode/apache-mode-autoloads.el -(arduino-mode auto-mode-alist "\\.pde\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el -(arduino-mode auto-mode-alist "\\.ino\\'") ;from ~/Source/nongnu/packages/arduino-mode/arduino-mode-autoloads.el -(beancount auto-mode-alist "\\.beancount\\'" beancount-mode) ;from ~/Source/nongnu/packages/beancount/beancount-autoloads.el -(bison-mode auto-mode-alist "\\.y\\'") ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el -(bison-mode auto-mode-alist "\\.l\\'" flex-mode) ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el -(bison-mode auto-mode-alist "\\.jison\\'" jison-mode) ;from ~/Source/nongnu/packages/bison-mode/bison-mode-autoloads.el -(bqn-mode auto-mode-alist "\\.bqn\\'") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el -(bqn-mode interpreter-mode-alist "bqn") ;from ~/Source/nongnu/packages/bqn-mode/bqn-mode-autoloads.el -(clojure-mode auto-mode-alist "\\.\\(clj\\|cljd\\|dtm\\|edn\\|lpy\\)\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojure-mode auto-mode-alist "\\.cljc\\'" clojurec-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojure-mode auto-mode-alist "\\.cljs\\'" clojurescript-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojure-mode auto-mode-alist "\\(?:build\\|profile\\)\\.boot\\'") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojure-mode interpreter-mode-alist "bb") ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(clojure-mode interpreter-mode-alist "nbb" clojurescript-mode) ;from ~/Source/nongnu/packages/clojure-mode/clojure-mode-autoloads.el -(coffee-mode auto-mode-alist "\\.coffee\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el -(coffee-mode auto-mode-alist "\\.iced\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el -(coffee-mode auto-mode-alist "Cakefile\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el -(coffee-mode auto-mode-alist "\\.cson\\'") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el -(coffee-mode interpreter-mode-alist "coffee") ;from ~/Source/nongnu/packages/coffee-mode/coffee-mode-autoloads.el -(d-mode auto-mode-alist "\\.d[i]?\\'") ;from ~/Source/nongnu/packages/d-mode/d-mode-autoloads.el -(dart-mode auto-mode-alist "\\.dart\\'") ;from ~/Source/nongnu/packages/dart-mode/dart-mode-autoloads.el -(dockerfile-mode auto-mode-alist "\\.dockerfile\\'") ;from ~/Source/nongnu/packages/dockerfile-mode/dockerfile-mode-autoloads.el -(drupal-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'" php-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(drupal-mode auto-mode-alist "[^/]\\.info\\'" conf-windows-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(drupal-mode auto-mode-alist "[^/]\\.make\\'" drush-make-mode) ;from ~/Source/nongnu/packages/drupal-mode/drupal-mode-autoloads.el -(editorconfig auto-mode-alist "\\.editorconfig\\'" editorconfig-conf-mode) ;from ~/Source/nongnu/packages/editorconfig/editorconfig-autoloads.el -(elixir-mode auto-mode-alist "\\.elixir\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el -(elixir-mode auto-mode-alist "\\.ex\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el -(elixir-mode auto-mode-alist "\\.exs\\'") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el -(elixir-mode auto-mode-alist "mix\\.lock") ;from ~/Source/nongnu/packages/elixir-mode/elixir-mode-autoloads.el -(ett auto-mode-alist "\\.ett\\'" ett-mode) ;from ~/Source/nongnu/packages/ett/ett-autoloads.el -(forth-mode auto-mode-alist "\\.\\(f\\|fs\\|fth\\|4th\\)\\'") ;from ~/Source/nongnu/packages/forth-mode/forth-mode-autoloads.el -(geiser-racket auto-mode-alist "\\.rkt\\'" scheme-mode) ;from ~/Source/nongnu/packages/geiser-racket/geiser-racket-autoloads.el -(gnu-apl-mode auto-mode-alist "\\.apl\\'") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el -(gnu-apl-mode interpreter-mode-alist "apl") ;from ~/Source/nongnu/packages/gnu-apl-mode/gnu-apl-mode-autoloads.el -(go-mode auto-mode-alist "go\\.mod\\'" go-dot-mod-mode) ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el -(go-mode auto-mode-alist "go\\.work\\'" go-dot-work-mode) ;from ~/Source/nongnu/packages/go-mode/go-mode-autoloads.el -(graphql-mode auto-mode-alist "\\.graphql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el -(graphql-mode auto-mode-alist "\\.gql\\'") ;from ~/Source/nongnu/packages/graphql-mode/graphql-mode-autoloads.el -(haml-mode auto-mode-alist "\\.haml\\'") ;from ~/Source/nongnu/packages/haml-mode/haml-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.hcr\\'" ghc-core-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.dump-simpl\\'" ghc-core-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.ghci\\'" ghci-script-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.chs\\'" haskell-c2hs-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.cabal\\'\\|/cabal\\.project\\|/\\.cabal/config\\'" haskell-cabal-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.[gh]s\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.hsig\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.l[gh]s\\'" haskell-literate-mode) ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode auto-mode-alist "\\.hsc\\'") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode interpreter-mode-alist "runghc") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(haskell-mode interpreter-mode-alist "runhaskell") ;from ~/Source/nongnu/packages/haskell-mode/haskell-mode-autoloads.el -(j-mode auto-mode-alist "\\.ij[rsp]$") ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el -(j-mode auto-mode-alist "\\.ijt$" j-lab-mode) ;from ~/Source/nongnu/packages/j-mode/j-mode-autoloads.el -(jade-mode auto-mode-alist "\\.jade\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el -(jade-mode auto-mode-alist "\\.pug\\'") ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el -(jade-mode auto-mode-alist "\\.styl\\'" stylus-mode) ;from ~/Source/nongnu/packages/jade-mode/jade-mode-autoloads.el -(jinja2-mode auto-mode-alist "\\.jinja2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el -(jinja2-mode auto-mode-alist "\\.j2\\'") ;from ~/Source/nongnu/packages/jinja2-mode/jinja2-mode-autoloads.el -(julia-mode auto-mode-alist "\\.jl\\'") ;from ~/Source/nongnu/packages/julia-mode/julia-mode-autoloads.el -(lua-mode auto-mode-alist "\\.lua\\'") ;from ~/Source/nongnu/packages/lua-mode/lua-mode-autoloads.el -(lua-mode interpreter-mode-alist "lua") ;from ~/Source/nongnu/packages/lua-mode/lua-mode-autoloads.el -(markdown-mode auto-mode-alist "\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'") ;from ~/Source/nongnu/packages/markdown-mode/markdown-mode-autoloads.el -(nginx-mode auto-mode-alist "nginx\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el -(nginx-mode auto-mode-alist "/nginx/.+\\.conf\\'") ;from ~/Source/nongnu/packages/nginx-mode/nginx-mode-autoloads.el -(nix-mode auto-mode-alist "^/nix/store/.+\\.drv\\'" nix-drv-mode) ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el -(nix-mode auto-mode-alist "\\flake.lock\\'" js-mode) ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el -(nix-mode auto-mode-alist "\\.nix\\'") ;from ~/Source/nongnu/packages/nix-mode/nix-mode-autoloads.el -(php-mode auto-mode-alist "/\\.php_cs\\(?:\\.dist\\)?\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el -(php-mode auto-mode-alist "\\.\\(?:php\\.inc\\|stub\\)\\'") ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el -(php-mode auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'" php-mode-maybe) ;from ~/Source/nongnu/packages/php-mode/lisp/php-mode-autoloads.el -(proof auto-mode-alist "\\.v\\'" coq-mode) ;from ~/Source/nongnu/packages/proof-general/generic/proof-autoloads.el -(racket-mode auto-mode-alist "\\.rkt\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el -(racket-mode auto-mode-alist "\\.rktd\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el -(racket-mode auto-mode-alist "\\.rktl\\'") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el -(racket-mode interpreter-mode-alist "racket") ;from ~/Source/nongnu/packages/racket-mode/racket-mode-autoloads.el -(raku-mode interpreter-mode-alist "perl6\\|raku") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el -(raku-mode auto-mode-alist "\\.p[lm]?6\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el -(raku-mode auto-mode-alist "\\.nqp\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el -(raku-mode auto-mode-alist "\\.raku\\(?:mod\\|test\\)?\\'") ;from ~/Source/nongnu/packages/raku-mode/raku-mode-autoloads.el -(rfc-mode auto-mode-alist "/rfc[0-9]+\\.txt\\'") ;from ~/Source/nongnu/packages/rfc-mode/rfc-mode-autoloads.el -(rust-mode auto-mode-alist "\\.rs\\'") ;from ~/Source/nongnu/packages/rust-mode/rust-mode-autoloads.el -(sass-mode auto-mode-alist "\\.sass\\'") ;from ~/Source/nongnu/packages/sass-mode/sass-mode-autoloads.el -(scad-mode auto-mode-alist "\\.scad\\'") ;from ~/Source/nongnu/packages/scad-mode/scad-mode-autoloads.el -(scala-mode auto-mode-alist "\\.\\(scala\\|sbt\\|worksheet\\.sc\\)\\'") ;from ~/Source/nongnu/packages/scala-mode/scala-mode-autoloads.el -(stylus-mode auto-mode-alist "\\.jade\\'" jade-mode) ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el -(stylus-mode auto-mode-alist "\\.pug\\'" jade-mode) ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el -(stylus-mode auto-mode-alist "\\.styl\\'") ;from ~/Source/nongnu/packages/stylus-mode/stylus-mode-autoloads.el -(subed auto-mode-alist "\\.ass\\'" subed-ass-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el -(subed auto-mode-alist "\\.srt\\'" subed-srt-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el -(subed auto-mode-alist "\\.vtt\\'" subed-vtt-mode) ;from ~/Source/nongnu/packages/subed/subed/subed-autoloads.el -(swift-mode auto-mode-alist "\\.swift\\(interface\\)?\\'") ;from ~/Source/nongnu/packages/swift-mode/swift-mode-autoloads.el -(systemd auto-mode-alist "\\.nspawn\\'" systemd-mode) ;from ~/Source/nongnu/packages/systemd/systemd-autoloads.el -(tuareg auto-mode-alist "\\.ml[ip]?\\'" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg auto-mode-alist "\\.eliomi?\\'" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg interpreter-mode-alist "ocamlrun" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg interpreter-mode-alist "ocaml" tuareg-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg auto-mode-alist "\\.mly\\'" tuareg-menhir-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(tuareg auto-mode-alist "[./]opam_?\\'" tuareg-opam-mode) ;from ~/Source/nongnu/packages/tuareg/tuareg-autoloads.el -(typescript-mode auto-mode-alist "\\.ts\\'") ;from ~/Source/nongnu/packages/typescript-mode/typescript-mode-autoloads.el -(yaml-mode auto-mode-alist "\\.\\(e?ya?\\|ra\\)ml\\'") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el -(yaml-mode magic-mode-alist "^%YAML\\s-+[0-9]+\\.[0-9]+\\(\\s-+#\\|\\s-*$\\)") ;from ~/Source/nongnu/packages/yaml-mode/yaml-mode-autoloads.el -(zig-mode auto-mode-alist "\\.\\(zig\\|zon\\)\\'") ;from ~/Source/nongnu/packages/zig-mode/zig-mode-autoloads.el +(ada-mode auto-mode-alist "\\.ad[abs]\\'") +(arbitools auto-mode-alist "\\.trf?\\'" arbitools-mode) +(auctex auto-mode-alist "\\.hva\\'" LaTeX-mode) +(bnf-mode auto-mode-alist "\\.bnf\\'") +(chess auto-mode-alist "\\.pgn\\'" chess-pgn-mode) +(cobol-mode auto-mode-alist "\\.c\\(ob\\|bl\\|py\\)\\'") +(code-cells auto-mode-alist "\\.ipynb\\'" code-cells-convert-ipynb) +(csharp-mode auto-mode-alist "\\.cs\\'") +(csv-mode auto-mode-alist "\\.[Cc][Ss][Vv]\\'") +(csv-mode auto-mode-alist "\\.tsv\\'" tsv-mode) +(dismal auto-mode-alist "\\.dis\\'" dismal-mode) +(djvu auto-mode-alist "\\.djvu\\'" djvu-init-mode) +(dts-mode auto-mode-alist "\\.dtsi?\\'") +(ess auto-mode-alist "\\.[Bb][Uu][Gg]\\'" ess-bugs-mode) +(ess auto-mode-alist "\\.[Bb][Oo][Gg]\\'" ess-bugs-mode) +(ess auto-mode-alist "\\.[Bb][Mm][Dd]\\'" ess-bugs-mode) +(ess auto-mode-alist "\\.[Jj][Aa][Gg]\\'" ess-jags-mode) +(ess auto-mode-alist "/R/.*\\.q\\'" ess-r-mode) +(ess auto-mode-alist "\\.[rR]\\'" ess-r-mode) +(ess auto-mode-alist "\\.[rR]profile\\'" ess-r-mode) +(ess auto-mode-alist "NAMESPACE\\'" ess-r-mode) +(ess auto-mode-alist "CITATION\\'" ess-r-mode) +(ess auto-mode-alist "\\.[Rr]out\\'" ess-r-transcript-mode) +(ess interpreter-mode-alist "Rscript" ess-r-mode) +(ess interpreter-mode-alist "r" ess-r-mode) +(ess auto-mode-alist "/Makevars\\(\\.win\\)?\\'" makefile-mode) +(ess auto-mode-alist "DESCRIPTION\\'" conf-colon-mode) +(ess auto-mode-alist "\\.Rd\\'" Rd-mode) +(ess auto-mode-alist "\\.[Ss]t\\'" S-transcript-mode) +(ess auto-mode-alist "\\.Sout\\'" S-transcript-mode) +(ess auto-mode-alist "\\.[Ss][Aa][Ss]\\'" SAS-mode) +(gle-mode auto-mode-alist "\\.gle\\'") +(gpr-mode auto-mode-alist "\\.gpr\\'") +(html5-schema auto-mode-alist "\\.html?\\'" nxml-mode) +(jgraph-mode auto-mode-alist "\\.jgr\\'") +(json-mode auto-mode-alist "\\.json\\'") +(lmc auto-mode-alist "\\.elmc\\'" lmc-asm-mode) +(matlab-mode auto-mode-alist "\\.tlc\\'" tlc-mode) +(matlab auto-mode-alist "\\.tlc\\'" tlc-mode) +(muse auto-mode-alist "\\.muse\\'" muse-mode-choose-mode) +(auctex auto-mode-alist "\\.drv\\'" latex-mode) +(auctex auto-mode-alist "\\.dtx\\'" doctex-mode) +(nftables-mode auto-mode-alist "\\.nft\\(?:ables\\)?\\'") +(nftables-mode auto-mode-alist "/etc/nftables.conf") +(nftables-mode interpreter-mode-alist "nft\\(?:ables\\)?") +(omn-mode auto-mode-alist "\\.pomn\\'") +(omn-mode auto-mode-alist "\\.omn\\'") +(poke-mode auto-mode-alist "\\.pk\\'") +(pspp-mode auto-mode-alist "\\.sps\\'") +(python auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'" conf-mode) +(rec-mode auto-mode-alist "\\.rec\\'") +(rnc-mode auto-mode-alist "\\.rnc\\'") +(sed-mode auto-mode-alist "\\.sed\\'") +(sed-mode interpreter-mode-alist "sed") +(shen-mode auto-mode-alist "\\.shen\\'") +(sisu-mode auto-mode-alist "\\.ss[imt]\\'") +(smalltalk-mode auto-mode-alist "\\.st\\'") +(sml-mode auto-mode-alist "\\.s\\(ml\\|ig\\)\\'") +(sml-mode auto-mode-alist "\\.cm\\'" sml-cm-mode) +(sml-mode auto-mode-alist "\\.grm\\'" sml-yacc-mode) +(sql-cassandra auto-mode-alist "\\.cql\\'" sql-mode) +(sxhkdrc-mode auto-mode-alist "sxhkdrc\\'") +(systemd auto-mode-alist "\\.automount\\'" systemd-automount-mode) +(systemd auto-mode-alist "\\.mount\\'" systemd-mount-mode) +(systemd auto-mode-alist "\\.path\\'" systemd-path-mode) +(systemd auto-mode-alist "\\.service\\'" systemd-service-mode) +(systemd auto-mode-alist "\\.socket\\'" systemd-socket-mode) +(systemd auto-mode-alist "\\.swap\\'" systemd-swap-mode) +(systemd auto-mode-alist "\\.timer\\'" systemd-timer-mode) +(vcard auto-mode-alist "\\.[Vv][Cc][Ff]\\'" vcard-mode) +(wisi auto-mode-alist "\\.parse_table.*\\'" wisitoken-parse_table-mode) +(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'" simple-indent-mode) +(wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") +(adoc-mode auto-mode-alist "\\.a\\(?:scii\\)?doc\\'") +(apache-mode auto-mode-alist "/\\.htaccess\\'") +(apache-mode auto-mode-alist "/\\(?:access\\|httpd\\|srm\\)\\.conf\\'") +(apache-mode auto-mode-alist "/apache2/.+\\.conf\\'") +(apache-mode auto-mode-alist "/httpd/conf/.+\\.conf\\'") +(apache-mode auto-mode-alist "/apache2/sites-\\(?:available\\|enabled\\)/") +(arduino-mode auto-mode-alist "\\.pde\\'") +(arduino-mode auto-mode-alist "\\.ino\\'") +(beancount auto-mode-alist "\\.beancount\\'" beancount-mode) +(bison-mode auto-mode-alist "\\.y\\'") +(bison-mode auto-mode-alist "\\.l\\'" flex-mode) +(bison-mode auto-mode-alist "\\.jison\\'" jison-mode) +(bqn-mode auto-mode-alist "\\.bqn\\'") +(bqn-mode interpreter-mode-alist "bqn") +(clojure-mode auto-mode-alist "\\.\\(clj\\|cljd\\|dtm\\|edn\\|lpy\\)\\'") +(clojure-mode auto-mode-alist "\\.cljc\\'" clojurec-mode) +(clojure-mode auto-mode-alist "\\.cljs\\'" clojurescript-mode) +(clojure-mode auto-mode-alist "\\(?:build\\|profile\\)\\.boot\\'") +(clojure-mode interpreter-mode-alist "bb") +(clojure-mode interpreter-mode-alist "nbb" clojurescript-mode) +(coffee-mode auto-mode-alist "\\.coffee\\'") +(coffee-mode auto-mode-alist "\\.iced\\'") +(coffee-mode auto-mode-alist "Cakefile\\'") +(coffee-mode auto-mode-alist "\\.cson\\'") +(coffee-mode interpreter-mode-alist "coffee") +(d-mode auto-mode-alist "\\.d[i]?\\'") +(dart-mode auto-mode-alist "\\.dart\\'") +(dockerfile-mode auto-mode-alist "\\.dockerfile\\'") +(drupal-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'" php-mode) +(drupal-mode auto-mode-alist "[^/]\\.info\\'" conf-windows-mode) +(drupal-mode auto-mode-alist "[^/]\\.make\\'" drush-make-mode) +(editorconfig auto-mode-alist "\\.editorconfig\\'" editorconfig-conf-mode) +(elixir-mode auto-mode-alist "\\.elixir\\'") +(elixir-mode auto-mode-alist "\\.ex\\'") +(elixir-mode auto-mode-alist "\\.exs\\'") +(elixir-mode auto-mode-alist "mix\\.lock") +(ett auto-mode-alist "\\.ett\\'" ett-mode) +(forth-mode auto-mode-alist "\\.\\(f\\|fs\\|fth\\|4th\\)\\'") +(geiser-racket auto-mode-alist "\\.rkt\\'" scheme-mode) +(gnu-apl-mode auto-mode-alist "\\.apl\\'") +(gnu-apl-mode interpreter-mode-alist "apl") +(go-mode auto-mode-alist "go\\.mod\\'" go-dot-mod-mode) +(go-mode auto-mode-alist "go\\.work\\'" go-dot-work-mode) +(graphql-mode auto-mode-alist "\\.graphql\\'") +(graphql-mode auto-mode-alist "\\.gql\\'") +(haml-mode auto-mode-alist "\\.haml\\'") +(haskell-mode auto-mode-alist "\\.hcr\\'" ghc-core-mode) +(haskell-mode auto-mode-alist "\\.dump-simpl\\'" ghc-core-mode) +(haskell-mode auto-mode-alist "\\.ghci\\'" ghci-script-mode) +(haskell-mode auto-mode-alist "\\.chs\\'" haskell-c2hs-mode) +(haskell-mode auto-mode-alist "\\.cabal\\'\\|/cabal\\.project\\|/\\.cabal/config\\'" haskell-cabal-mode) +(haskell-mode auto-mode-alist "\\.[gh]s\\'") +(haskell-mode auto-mode-alist "\\.hsig\\'") +(haskell-mode auto-mode-alist "\\.l[gh]s\\'" haskell-literate-mode) +(haskell-mode auto-mode-alist "\\.hsc\\'") +(haskell-mode interpreter-mode-alist "runghc") +(haskell-mode interpreter-mode-alist "runhaskell") +(j-mode auto-mode-alist "\\.ij[rsp]$") +(j-mode auto-mode-alist "\\.ijt$" j-lab-mode) +(jade-mode auto-mode-alist "\\.jade\\'") +(jade-mode auto-mode-alist "\\.pug\\'") +(jade-mode auto-mode-alist "\\.styl\\'" stylus-mode) +(jinja2-mode auto-mode-alist "\\.jinja2\\'") +(jinja2-mode auto-mode-alist "\\.j2\\'") +(julia-mode auto-mode-alist "\\.jl\\'") +(lua-mode auto-mode-alist "\\.lua\\'") +(lua-mode interpreter-mode-alist "lua") +(markdown-mode auto-mode-alist "\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'") +(nginx-mode auto-mode-alist "nginx\\.conf\\'") +(nginx-mode auto-mode-alist "/nginx/.+\\.conf\\'") +(nix-mode auto-mode-alist "^/nix/store/.+\\.drv\\'" nix-drv-mode) +(nix-mode auto-mode-alist "\\flake.lock\\'" js-mode) +(nix-mode auto-mode-alist "\\.nix\\'") +(php-mode auto-mode-alist "/\\.php_cs\\(?:\\.dist\\)?\\'") +(php-mode auto-mode-alist "\\.\\(?:php\\.inc\\|stub\\)\\'") +(php-mode auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'" php-mode-maybe) +(proof auto-mode-alist "\\.v\\'" coq-mode) +(racket-mode auto-mode-alist "\\.rkt\\'") +(racket-mode auto-mode-alist "\\.rktd\\'") +(racket-mode auto-mode-alist "\\.rktl\\'") +(racket-mode interpreter-mode-alist "racket") +(raku-mode interpreter-mode-alist "perl6\\|raku") +(raku-mode auto-mode-alist "\\.p[lm]?6\\'") +(raku-mode auto-mode-alist "\\.nqp\\'") +(raku-mode auto-mode-alist "\\.raku\\(?:mod\\|test\\)?\\'") +(rfc-mode auto-mode-alist "/rfc[0-9]+\\.txt\\'") +(rust-mode auto-mode-alist "\\.rs\\'") +(sass-mode auto-mode-alist "\\.sass\\'") +(scad-mode auto-mode-alist "\\.scad\\'") +(scala-mode auto-mode-alist "\\.\\(scala\\|sbt\\|worksheet\\.sc\\)\\'") +(stylus-mode auto-mode-alist "\\.jade\\'" jade-mode) +(stylus-mode auto-mode-alist "\\.pug\\'" jade-mode) +(stylus-mode auto-mode-alist "\\.styl\\'") +(subed auto-mode-alist "\\.ass\\'" subed-ass-mode) +(subed auto-mode-alist "\\.srt\\'" subed-srt-mode) +(subed auto-mode-alist "\\.vtt\\'" subed-vtt-mode) +(swift-mode auto-mode-alist "\\.swift\\(interface\\)?\\'") +(systemd auto-mode-alist "\\.nspawn\\'" systemd-mode) +(tuareg auto-mode-alist "\\.ml[ip]?\\'" tuareg-mode) +(tuareg auto-mode-alist "\\.eliomi?\\'" tuareg-mode) +(tuareg interpreter-mode-alist "ocamlrun" tuareg-mode) +(tuareg interpreter-mode-alist "ocaml" tuareg-mode) +(tuareg auto-mode-alist "\\.mly\\'" tuareg-menhir-mode) +(tuareg auto-mode-alist "[./]opam_?\\'" tuareg-opam-mode) +(typescript-mode auto-mode-alist "\\.ts\\'") +(yaml-mode auto-mode-alist "\\.\\(e?ya?\\|ra\\)ml\\'") +(yaml-mode magic-mode-alist "^%YAML\\s-+[0-9]+\\.[0-9]+\\(\\s-+#\\|\\s-*$\\)") +(zig-mode auto-mode-alist "\\.\\(zig\\|zon\\)\\'") ) From e9f8dbf19439425568198deb44e48bff150212a4 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 7 Nov 2024 16:47:31 +0100 Subject: [PATCH 017/191] Demote errors when failing to install package suggestions * lisp/emacs-lisp/package.el (package--autosuggest-install-and-enable): Wrap 'package-install' and following code in a 'with-demoted-errors'. --- lisp/emacs-lisp/package.el | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2ded76c0832..335a08b2206 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4634,11 +4634,12 @@ SUG should be an element of `package-autosuggest-database'." (when (and (eq major-mode 'fundamental-mode) (buffer-file-name) (package--suggestion-applies-p sug)) (push buf buffers-to-update)))) - (package-install (car sug)) - (dolist (buf buffers-to-update) - (with-demoted-errors "Failed to enable major mode: %S" - (with-current-buffer buf - (funcall-interactively (or (cadddr sug) (car sug)))))))) + (with-demoted-errors "Failed to install package: %S" + (package-install (car sug)) + (dolist (buf buffers-to-update) + (with-demoted-errors "Failed to enable major mode: %S" + (with-current-buffer buf + (funcall-interactively (or (cadddr sug) (car sug))))))))) (defvar package--autosugest-line-format '(:eval (package--autosugest-line-format))) From 2a88c6dc3c36f726275554f1b93e32fd726e415c Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 8 Nov 2024 11:41:47 -0500 Subject: [PATCH 018/191] Do not suggest packages outside of 'fundamental-mode' * lisp/emacs-lisp/package.el (package--autosuggest-find-candidates): Check 'major-mode' before computing suggestions. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 335a08b2206..f687839f206 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4618,7 +4618,7 @@ SUG should be an element of `package-autosuggest-database'." "Return a list of suggestions that might be interesting the current buffer. The elements of the returned list will be a subset of the elements of `package--autosuggest-suggested'." - (and package-autosuggest-mode + (and package-autosuggest-mode (eq major-mode 'fundamental-mode) (let (suggetions) (dolist (sug package-autosuggest-database) (when (package--suggestion-applies-p sug) From c685cf336a480fcd2909f2ee704b824fe5e38b74 Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Thu, 19 Dec 2024 14:30:57 +0100 Subject: [PATCH 019/191] Add full support for iCalendar (RFC5545) data This is a fix for Bug#74994 that replaces the existing support in icalendar.el. It implements a full parser, recurrence rule and time zone calculations, diary import and export, and a major mode with syntax highlighting for iCalendar data. It obsoletes most of the code in icalendar.el. In addition to Bug#74994, the proposal to update Emacs' iCalendar support was discussed on emacs-devel in this thread: https://lists.gnu.org/archive/html/emacs-devel/2024-10/msg00425.html icalendar.el pre-dates the current standard (RFC5545), contains numerous bugs, is not well documented, and could not easily be updated or extended; starting fresh was the simplest path to creating an iCalendar library that other Emacs applications and packages can rely on. It was decided to leave icalendar.el's code in place for posterity, but declare it obsolete. Most of the changes in icalendar.el simply consist of such declarations. The old To Do list has also been deleted. A few changes in icalendar.el, however, consist of new code for library-wide functions and options, especially error handling. In particular: * lisp/calendar/icalendar.el: Log iCalendar library errors in a single buffer. (icalendar-errors-mode): New mode for it. (icalendar-uid-format): Change the default value to "%h", a hash value (for privacy). (icalendar-make-uid): New function, to replace 'icalendar--create-uid'. (icalendar-debug-level, icalendar-vcalendar-prodid): New option. (icalendar-vcalendar-version): New constant. * lisp/calendar/icalendar.el (icalendar-import-format) (icalendar-import-format-summary, icalendar-import-format-description) (icalendar-import-format-location, icalendar-import-format-organizer) (icalendar-import-format-url, icalendar-import-format-uid) (icalendar-import-format-status, icalendar-import-format-class) (icalendar-recurring-start-year, icalendar-export-hidden-diary-entries) (icalendar-export-sexp-enumerate-all, icalendar-export-alarms, icalendar-debug, icalendar--weekday-array, icalendar--dmsg) (icalendar--get-unfolded-buffer icalendar--clean-up-line-endings) (icalendar--rris, icalendar--read-element) (icalendar--get-event-property, icalendar--get-event-properties) (icalendar--get-event-property-attributes) (icalendar--get-children, icalendar--all-events, icalendar--split-value) (icalendar--convert-tz-offset, icalendar--parse-vtimezone) (icalendar--get-most-recent-observance) (icalendar--convert-all-timezones, icalendar--find-time-zone) (icalendar--decode-isodatetime) (icalendar--decode-isoduration, icalendar--add-decoded-times) (icalendar--datetime-to-american-date) (icalendar--datetime-to-european-date, icalendar--datetime-to-iso-date) (icalendar--datetime-to-diary-date, icalendar--datetime-to-colontime) (icalendar--get-month-number, icalendar--get-weekday-number) (icalendar--get-weekday-numbers, icalendar--get-weekday-abbrev) (icalendar--date-to-isodate, icalendar--datestring-to-isodate) (icalendar--diarytime-to-isotime, icalendar--convert-string-for-export) (icalendar--convert-string-for-import, icalendar-export-file) (icalendar-export-region, icalendar--create-uid) (icalendar--parse-summary-and-rest, icalendar--create-ical-alarm) (icalendar--do-create-ical-alarm, icalendar--convert-ordinary-to-ical) (icalendar-first-weekday-of-year, icalendar--convert-weekly-to-ical) (icalendar--convert-yearly-to-ical, icalendar--convert-sexp-to-ical) (icalendar--convert-block-to-ical, icalendar--convert-float-to-ical) (icalendar--convert-date-to-ical, icalendar--convert-cyclic-to-ical) (icalendar--convert-anniversary-to-ical, icalendar-import-file) (icalendar-import-buffer, icalendar--format-ical-event) (icalendar--convert-to-ical, icalendar--convert-ical-to-diary) (icalendar--convert-recurring-to-diary) (icalendar--convert-non-recurring-all-day-to-diary) (icalendar--convert-non-recurring-not-all-day-to-diary) (icalendar--add-diary-entry, icalendar-import-format-sample): Mark them as obsolete. In addition to the changes above, the new iCalendar library consists of the following: * lisp/calendar/diary-icalendar.el: * lisp/calendar/icalendar-ast.el: * lisp/calendar/icalendar-macs.el: * lisp/calendar/icalendar-mode.el: * lisp/calendar/icalendar-parser.el: * lisp/calendar/icalendar-recur.el: * lisp/calendar/icalendar-utils.el: New files A few changes were made to existing files dealing with the calendar and diary: * lisp/calendar/calendar.el (calendar-date-from-day-of-year): New function, extracted from calendar-goto-day-of-year. * lisp/calendar/cal-move.el (calendar-goto-day-of-year): Use it. * lisp/calendar/cal-dst.el (calendar-dst-find-data): Improve docstring. * lisp/calendar/calendar.el (diary-date-insertion-form): New option. (diary-american-date-insertion-form, diary-european-date-insertion-form) (diary-iso-date-insertion-form): New constants. * lisp/calendar/diary-lib.el (diary-insert-entry): Use the new 'diary-date-insertion-form' option. (diary-time-regexp): Add FIXME to an existing comment. The user-facing aspects of the above changes are documented in the Emacs manual and the NEWS file: * doc/emacs/calendar.texi (Diary Conversion): Update manual section to describe the new importer and exporter. * doc/emacs/emacs.texi (Detailed node listing): Update to include the new nodes in docs/emacs/calendar.texi. * etc/NEWS: Briefly describe the new library, major mode, and options. The remainder of the changes apply to test files. The following changes introduce new test files related to the new diary importer and exporter: * test/lisp/calendar/diary-icalendar-tests.el (Diary import and export): Tests for diary-icalendar. In addition to new tests for the exporter, the existing import tests for icalendar.el have been ported here; these use the existing iCalendar files in test/lisp/calendar/icalendar-resources. (A few new input .ics files have also been added to this directory; see below.) * test/lisp/calendar/diary-icalendar-resources: New directory containing expected outputs for the import tests in diary-icalendar-tests.el. (These have the same or similar names to the output files for the old importer, in test/lisp/calendar/icalendar-resources, but different contents. Thus they live in a new directory.) * test/lisp/calendar/icalendar-resources/import-legacy-function.ics: New input file to test backward compatibility of the new importer with a function as the value of 'icalendar-import-format', now obsolete. * test/lisp/calendar/icalendar-resources/import-legacy-vars.ics: New input file to test backward compatibility of the new importer with values for options provided by icalendar.el which are now obsolete. * test/lisp/calendar/icalendar-resources/import-with-attachment.ics: New input file to test import of base64-encoded attachments. * icalendar-resources/import-time-format-12hr-blank.ics: New input file to test import with a custom value of 'diary-icalendar-time-format'. Two other new test files provide unit tests for the main functions of the library: * test/lisp/calendar/icalendar-parser-tests.el (Parser): Tests for icalendar-parser. Most of these are derived from examples in RFC5545, to ensure the parser implements the standard. * test/lisp/calendar/icalendar-recur-tests.el (Recurrence rules): Tests for icalendar-recur. Most of these are derived from examples in RFC5545, to ensure the recurrence rule interpreter implements the standard. A few of the existing test files for icalendar.el have also been modified. Besides the specific changes mentioned below, the modified .ics files also now use CR-LF line endings, as required by RFC5545: * test/lisp/calendar/icalendar-tests.el (icalendar-deftest-obsolete): New macro. * test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics: Correct a malformed VALUE parameter. * test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics: Correct representation of a recurring event. * test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics: Add a required VALUE parameter. * test/lisp/calendar/icalendar-resources/import-rrule-daily.ics: * test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics: * test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics: * test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics: Correct a malformed RRULE property. --- doc/emacs/calendar.texi | 327 +- doc/emacs/emacs.texi | 9 +- etc/NEWS | 33 + lisp/calendar/cal-dst.el | 6 +- lisp/calendar/cal-move.el | 6 +- lisp/calendar/calendar.el | 70 +- lisp/calendar/diary-icalendar.el | 3970 +++++++++++++ lisp/calendar/diary-lib.el | 6 +- lisp/calendar/icalendar-ast.el | 927 ++++ lisp/calendar/icalendar-macs.el | 1125 ++++ lisp/calendar/icalendar-mode.el | 610 ++ lisp/calendar/icalendar-parser.el | 4889 +++++++++++++++++ lisp/calendar/icalendar-recur.el | 1993 +++++++ lisp/calendar/icalendar-utils.el | 749 +++ lisp/calendar/icalendar.el | 571 +- .../import-bug-11473.diary-american | 8 + .../import-bug-11473.diary-european | 8 + .../import-bug-11473.diary-iso | 8 + .../import-bug-22092.diary-american | 6 + .../import-bug-22092.diary-european | 6 + .../import-bug-22092.diary-iso | 6 + .../import-bug-24199.diary-all | 11 + .../import-bug-33277.diary-american | 1 + .../import-bug-33277.diary-european | 1 + .../import-bug-33277.diary-iso | 1 + .../import-bug-6766.diary-all | 12 + .../import-duration-2.diary-all | 5 + .../import-duration.diary-american | 1 + .../import-duration.diary-european | 1 + .../import-duration.diary-iso | 1 + .../import-legacy-function.diary-all | 10 + .../import-legacy-vars.diary-american | 8 + .../import-legacy-vars.diary-european | 8 + .../import-legacy-vars.diary-iso | 8 + .../import-multiple-vcalendars.diary-american | 7 + .../import-multiple-vcalendars.diary-european | 7 + .../import-multiple-vcalendars.diary-iso | 7 + .../import-non-recurring-1.diary-american | 1 + .../import-non-recurring-1.diary-european | 1 + .../import-non-recurring-1.diary-iso | 1 + ...mport-non-recurring-all-day.diary-american | 1 + ...mport-non-recurring-all-day.diary-european | 1 + .../import-non-recurring-all-day.diary-iso | 1 + ...n-recurring-another-example.diary-american | 4 + ...n-recurring-another-example.diary-european | 4 + ...rt-non-recurring-another-example.diary-iso | 4 + .../import-non-recurring-block.diary-american | 4 + .../import-non-recurring-block.diary-european | 4 + .../import-non-recurring-block.diary-iso | 4 + ...on-recurring-folded-summary.diary-american | 4 + ...on-recurring-folded-summary.diary-european | 4 + ...ort-non-recurring-folded-summary.diary-iso | 4 + ...-non-recurring-long-summary.diary-american | 1 + ...-non-recurring-long-summary.diary-european | 1 + ...mport-non-recurring-long-summary.diary-iso | 1 + ...mport-real-world-2003-05-29.diary-american | 10 + ...mport-real-world-2003-05-29.diary-european | 10 + ...port-real-world-2003-06-18a.diary-american | 8 + ...port-real-world-2003-06-18a.diary-european | 8 + ...port-real-world-2003-06-18b.diary-american | 6 + ...port-real-world-2003-06-18b.diary-european | 5 + ...mport-real-world-2004-11-19.diary-american | 28 + ...mport-real-world-2004-11-19.diary-european | 28 + ...mport-real-world-2005-02-07.diary-american | 6 + ...mport-real-world-2005-02-07.diary-european | 6 + ...mport-real-world-2005-03-01.diary-american | 2 + ...mport-real-world-2005-03-01.diary-european | 2 + .../import-real-world-no-dst.diary-american | 4 + .../import-real-world-no-dst.diary-european | 4 + .../import-rrule-anniversary.diary-all | 1 + .../import-rrule-count-bi-weekly.diary-all | 3 + .../import-rrule-count-daily-long.diary-all | 3 + .../import-rrule-count-daily-short.diary-all | 3 + ...t-rrule-count-every-second-month.diary-all | 3 + ...rt-rrule-count-every-second-year.diary-all | 3 + .../import-rrule-count-monthly.diary-all | 3 + .../import-rrule-count-yearly.diary-all | 3 + .../import-rrule-daily-two-day.diary-all | 3 + ...port-rrule-daily-with-exceptions.diary-all | 4 + .../import-rrule-daily.diary-all | 2 + .../import-rrule-monthly-no-end.diary-all | 3 + .../import-rrule-monthly-with-end.diary-all | 3 + .../import-rrule-weekly.diary-all | 2 + .../import-rrule-yearly.diary-all | 3 + .../import-time-format-12hr-blank.diary-iso | 1 + .../import-with-attachment.diary-iso | 3 + .../import-with-timezone.diary-iso | 3 + .../import-with-uid.diary-american | 2 + .../import-with-uid.diary-european | 2 + .../import-with-uid.diary-iso | 2 + test/lisp/calendar/diary-icalendar-tests.el | 1277 +++++ test/lisp/calendar/icalendar-parser-tests.el | 2032 +++++++ test/lisp/calendar/icalendar-recur-tests.el | 2873 ++++++++++ .../import-legacy-function.ics | 16 + .../import-legacy-vars.ics | 16 + .../import-non-recurring-all-day.ics | 17 +- .../import-rrule-anniversary.ics | 21 +- .../import-rrule-daily-with-exceptions.ics | 23 +- .../import-rrule-daily.ics | 22 +- .../import-rrule-monthly-no-end.ics | 22 +- .../import-rrule-monthly-with-end.ics | 21 +- .../import-rrule-weekly.ics | 22 +- .../import-time-format-12hr-blank.ics | 9 + .../import-with-attachment.ics | 11 + .../import-with-timezone.ics | 54 +- test/lisp/calendar/icalendar-tests.el | 119 +- 106 files changed, 21901 insertions(+), 303 deletions(-) create mode 100644 lisp/calendar/diary-icalendar.el create mode 100644 lisp/calendar/icalendar-ast.el create mode 100644 lisp/calendar/icalendar-macs.el create mode 100644 lisp/calendar/icalendar-mode.el create mode 100644 lisp/calendar/icalendar-parser.el create mode 100644 lisp/calendar/icalendar-recur.el create mode 100644 lisp/calendar/icalendar-utils.el create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-24199.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-bug-6766.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-duration-2.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-duration.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-duration.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-duration.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-legacy-function.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-anniversary.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-bi-weekly.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-long.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-short.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-month.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-year.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-monthly.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-count-yearly.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-two-day.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-with-exceptions.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-daily.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-no-end.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-with-end.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-weekly.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-rrule-yearly.diary-all create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-time-format-12hr-blank.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-with-attachment.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-with-timezone.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-american create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-european create mode 100644 test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-iso create mode 100644 test/lisp/calendar/diary-icalendar-tests.el create mode 100644 test/lisp/calendar/icalendar-parser-tests.el create mode 100644 test/lisp/calendar/icalendar-recur-tests.el create mode 100644 test/lisp/calendar/icalendar-resources/import-legacy-function.ics create mode 100644 test/lisp/calendar/icalendar-resources/import-legacy-vars.ics create mode 100644 test/lisp/calendar/icalendar-resources/import-time-format-12hr-blank.ics create mode 100644 test/lisp/calendar/icalendar-resources/import-with-attachment.ics diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index ca9cc80b921..74dada809a5 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -1005,7 +1005,7 @@ entries. * Adding to Diary:: Commands to create diary entries. * Special Diary Entries:: Anniversaries, blocks of dates, cyclic entries, etc. * Appointments:: Reminders when it's time to do something. -* Importing Diary:: Converting diary events to/from other formats. +* Diary Conversion:: Converting diary events to/from other formats. @end menu @node Format of Diary File @@ -1549,71 +1549,286 @@ clock. The command @kbd{M-x appt-add} adds entries to the appointment list without affecting your diary file. You delete entries from the appointment list with @kbd{M-x appt-delete}. -@node Importing Diary +@node Diary Conversion @subsection Importing and Exporting Diary Entries -@cindex importing diary entries +@cindex diary import +@cindex diary export - You can transfer diary entries between Emacs diary files and a -variety of other formats. +You can transfer diary entries between Emacs diary files and other +formats. + +@menu +* Diary iCalendar Import:: Importing iCalendar data to the Diary. +* Diary iCalendar Display:: Displaying iCalendar data without importing. +* Diary iCalendar Export:: Exporting Diary entries to iCalendar. +* Diary Outlook Import:: Importing Outlook appointments to the Diary. +@end menu + +@node Diary iCalendar Import +@subsubsection Importing iCalendar data as Diary Entries +@cindex import iCalendar to diary + +@cindex iCalendar support in diary + @dfn{iCalendar} is an Internet standard format for exchanging calendar +data. Many calendar applications can export and import data in +iCalendar format. iCalendar data is also often sent as email +attachments. iCalendar data usually uses the @file{.ics} file +extension, and is sent with the `text/calendar' @acronym{MIME} type in +email. (@xref{Mail Misc}, for more information on @acronym{MIME} and +email attachments.) + +The @code{diary-icalendar} package allows you to make use of iCalendar +data with the Emacs diary. You can import and export data between +iCalendar format and your Emacs diary file, and also display iCalendar +data directly in the diary. + +The following commands will import iCalendar data to your diary file: + +@ftable @code +@item diary-icalendar-import-file +Imports an iCalendar file to an Emacs diary file. + +@item diary-icalendar-import-buffer +Imports iCalendar data from the current buffer to an Emacs diary file. +@end ftable + +@code{diary-icalendar-import-buffer} is also suitable for importing +iCalendar data from email attachments. For example, with the Rmail mail +client, you could use: + +@example +(add-hook 'rmail-show-message-hook #'diary-icalendar-import-buffer) +@end example + +Diary import depends on a number of user-customizable variables, which +are in the @code{diary-icalendar-import} customization group. You can +review and customize these variables with @kbd{M-x customize-group}. +@xref{Customization Groups}. + +iCalendar data is grouped into @dfn{components} which represent calendar +events (the VEVENT component), tasks (VTODO), and other text data +(VJOURNAL). Because these components contain different types of data, +they are imported by different functions, determined by the following +variables: + +@vtable @code +@item diary-icalendar-vevent-skeleton-command +Function to format VEVENT components for the diary. + +@item diary-icalendar-vtodo-skeleton-command +Function to format VTODO components for the diary. + +@item diary-icalendar-vjournal-skeleton-command +Function to format VJOURNAL components for the diary. +@end vtable + +You can customize the format of the imported diary entries by writing +your own formatting functions. It is convenient (but not required) to +express such functions as templates called @dfn{skeletons}. +@ifinfo +@xref{Top, Autotyping, The Autotype Manual, autotype}, for more about +skeletons. +@end ifinfo + +For example, suppose you only want to import the date, time, summary, +and location of each calendar event, and to write them on a single line +like: + +@example +2025/11/11 Summary @@ Some Location +@end example + +@noindent +Then you could write the import formatting function as a skeleton and +set it to the value of @code{diary-icalendar-vevent-skeleton-command} as +follows: + +@lisp +@group +(require 'skeleton) + +(define-skeleton simple-vevent + "Format a VEVENT summary and location on a single line" + nil + start-to-end & " " & summary & " " + (when location "@@ ") & location "\n") + +(setopt diary-icalendar-vevent-skeleton-command #'simple-vevent) +@end group +@end lisp + +The variables @code{start-to-end}, @code{summary} and @code{location} in +this example are dynamically bound to appropriate values when the +skeleton is called. See the docstring of +@code{diary-icalendar-vevent-skeleton-command} for more information. + +Any errors encountered during import will be reported in a buffer named +@file{*icalendar-errors*}. You can review these errors with the +@code{next-error} command. @xref{Compilation Mode}. If you regularly +need to import malformed iCalendar data, there are several hooks +available for this purpose; see the @code{icalendar-parser} +customization group. + +@node Diary iCalendar Display +@subsubsection Displaying iCalendar entries in the Diary +@cindex display iCalendar in diary + +If you primarily store your calendar data outside of Emacs, but still +want to see it in the Emacs calendar and diary, you can do so by +including an iCalendar file from your diary file. + +Suppose, for example, that you download your calendar from an +external server to a file called @file{Appointments.ics}. Then you can +include this file in your diary by writing a line like + +@example +#include "path/to/Appointments.ics" +@end example + +@noindent +in your diary file. You must also set up some hooks to display the +data in that file as diary entries and mark them in the calendar: + +@lisp +@group +(add-hook 'diary-mark-entries-hook + #'diary-mark-included-diary-files) +(add-hook 'diary-nongregorian-marking-hook + #'diary-icalendar-mark-entries) +(add-hook 'diary-list-entries-hook + #'diary-include-other-diary-files) +(add-hook 'diary-nongregorian-listing-hook + #'diary-icalendar-display-entries) +@end group +@end lisp + +@noindent +Events, tasks, and journal entries in @file{Appointments.ics} will then show +up on the appropriate days when you display the diary from the calendar. +@xref{Displaying the Diary}. + +The advantage of doing this is that you don't need to synchronize the +data between the calendar server and your diary file. This is simpler +and more reliable than regularly importing and exporting between diary +and iCalendar format. + +@findex diary-icalendar-mailcap-viewer + You can also display iCalendar attachments in email messages +without importing them to your diary file using the function +@code{diary-icalendar-mailcap-viewer}. You can add this function, for +example, to the variable @code{mailcap-user-mime-data}; see its docstring +for more information. + +Displaying iCalendar entries uses the same infrastructure as importing +them, so customizing the import format will also change the format of +the displayed entries. @xref{Diary iCalendar Import}. + +@node Diary iCalendar Export +@subsubsection Exporting Diary Entries to iCalendar +@cindex export diary to iCalendar + +The following commands will export diary entries in iCalendar format: + +@ftable @code +@item diary-icalendar-export-file +Exports a diary file to iCalendar format. + +@item diary-icalendar-export-region +Exports a region of diary text to iCalendar format. +@end ftable + +iCalendar export depends on a number of user-customizable variables, which +are in the @code{diary-icalendar-export} customization group. You can +review and customize these variables with @kbd{M-x customize-group}. +@xref{Customization Groups}. + +Exporting diary entries to iCalendar requires you to respect certain +conventions in your diary, so that iCalendar properties can be parsed +from your diary entries. + +By default, the exporter will use the first line of the entry (after the +date and time) as the iCalendar summary and the rest of the entry as its +iCalendar description. Other iCalendar properties can also be encoded in +the entry on separate lines, like this: + +@example +@group +2025/11/11 Bender's birthday bash + Location: Robot House + Attendees: + Fry + GĂŒnter +@end group +@end example + +@noindent +This format matches the format produced by the default import +functions. + +@vindex diary-icalendar-address-regexp +@vindex diary-icalendar-class-regexp +@vindex diary-icalendar-description-regexp +@vindex diary-icalendar-location-regexp +@vindex diary-icalendar-organizer-regexp +@vindex diary-icalendar-status-regexp +@vindex diary-icalendar-summary-regexp +@vindex diary-icalendar-todo-regexp +@vindex diary-icalendar-uid-regexp +@vindex diary-icalendar-url-regexp +If you customize the import format, or you want to export diary entries +in a different format, you will need to customize the export variables +to detect the format of your diary entries. The most common iCalendar +properties are parsed from diary entries using regular expressions. See +the variables named @code{diary-icalendar-*-regexp} in the +@code{diary-icalendar-export} customization group to modify how these +properties are parsed. + +@vindex diary-icalendar-other-properties-parser + If you need to export other iCalendar properties, or do more +complicated parsing, you can define a function to do so and set it as +the value of the variable @code{diary-icalendar-other-properties-parser}; +see its docstring for details. + +@vindex diary-icalendar-export-linewise + By default, the exporter assumes that each diary entry represents a +single iCalendar event. If you like to keep your diary in a +one-entry-per-day format, with different events on continuation +lines within the same entry, you can still export such entries as +distinct iCalendar events. To do this, set the variable +@code{diary-icalendar-export-linewise} to a non-nil value. + +For example, after setting this variable, an entry like: + +@example +@group +2025-05-03 + 9AM Lab meeting + GĂŒnter to present on new assay + Start experiment A + 12:30-1:30PM Lunch with Phil + 16:00 Experiment A finishes; move to freezer +@end group +@end example + +@noindent +will be exported as four events, each on the same day, but with +different start times (except for the second event, ``Start experiment +A'', which has no start time). See the docstring of +@code{diary-icalendar-export-linewise} for more information. + +@node Diary Outlook Import +@subsubsection Importing Outlook appointments as Diary Entries +@cindex diary outlook import @vindex diary-outlook-formats - You can import diary entries from Outlook-generated appointment +@vindex diary-from-outlook-function + You can also import diary entries from Outlook-generated appointment messages. While viewing such a message in Rmail or Gnus, do @kbd{M-x diary-from-outlook} to import the entry. You can make this command recognize additional appointment message formats by customizing the variable @code{diary-outlook-formats}. Other mail clients can set @code{diary-from-outlook-function} to an appropriate value. -@c FIXME the name of the RFC is hardly very relevant. -@cindex iCalendar support - The icalendar package allows you to transfer data between your Emacs -diary file and iCalendar files, which are defined in @cite{RFC -2445---Internet Calendaring and Scheduling Core Object Specification -(iCalendar)} (as well as the earlier vCalendar format). - -@c Importing works for ordinary (i.e., non-recurring) events, but -@c (at present) may not work correctly (if at all) for recurring events. -@c Exporting of diary files into iCalendar files should work correctly -@c for most diary entries. This feature is a work in progress, so the -@c commands may evolve in future. - -@findex icalendar-import-buffer - The command @code{icalendar-import-buffer} extracts -iCalendar data from the current buffer and adds it to your -diary file. This function is also suitable for automatic extraction of -iCalendar data; for example with the Rmail mail client one could use: - -@example -(add-hook 'rmail-show-message-hook 'icalendar-import-buffer) -@end example - -@findex icalendar-import-file - The command @code{icalendar-import-file} imports an iCalendar file -and adds the results to an Emacs diary file. For example: - -@example -(icalendar-import-file "/here/is/calendar.ics" - "/there/goes/ical-diary") -@end example - -@noindent -You can use an @code{#include} directive to add the import file contents -to the main diary file, if these are different files. -@iftex -@xref{Fancy Diary Display,,, emacs-xtra, Specialized Emacs Features}. -@end iftex -@ifnottex -@xref{Fancy Diary Display}. -@end ifnottex - - -@findex icalendar-export-file -@findex icalendar-export-region -@cindex export diary - Use @code{icalendar-export-file} to interactively export an entire -Emacs diary file to iCalendar format. To export only a part of a diary -file, mark the relevant area, and call @code{icalendar-export-region}. -In both cases, Emacs appends the result to the target file. @node Daylight Saving @section Daylight Saving Time diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 9f84f4e3978..bdd9f2753ba 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -1020,7 +1020,14 @@ The Diary * Adding to Diary:: Commands to create diary entries. * Special Diary Entries:: Anniversaries, blocks of dates, cyclic entries, etc. * Appointments:: Reminders when it's time to do something. -* Importing Diary:: Converting diary events to/from other formats. +* Diary Conversion:: Converting diary events to/from other formats. + +Diary Conversion + +* Diary iCalendar Import:: Importing iCalendar data to the Diary. +* Diary iCalendar Display:: Displaying iCalendar data without importing. +* Diary iCalendar Export:: Exporting Diary entries to iCalendar. +* Diary Outlook Import:: Importing Outlook appointments to the Diary. @ifnottex More advanced features of the Calendar and Diary diff --git a/etc/NEWS b/etc/NEWS index 7e8dbf44b9f..c7b9ec1341b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3084,6 +3084,34 @@ The user options 'calendar-mark-holidays-flag' and 'calendar-mark-diary-entries-flag' are not modified anymore when changing the marking state in the calendar buffer. +*** New library for iCalendar data. +A new library has been added to the calendar for handling iCalendar +(RFC5545) data. The library is designed for reuse in other parts of +Emacs and in third-party packages. Package authors can find the new +library in the Emacs distribution under lisp/calendar/icalendar-*.el. + +Most of the functions and variables in the older icalendar.el have been +marked obsolete and now suggest appropriate replacements from the new +library. diary-icalendar.el provides replacements for the diary-related +features from icalendar.el; see below. + +** Diary + +*** New user option 'diary-date-insertion-form'. +This user option determines how dates are inserted into the diary by +Lisp functions. Its value is a pseudo-pattern of the same type as in +'diary-date-forms'. It is used by 'diary-insert-entry' when inserting +entries from the calendar, or when importing them from other formats. + ++++ +*** New library 'diary-icalendar'. +This library reimplements features previously provided by icalendar.el: +import from iCalendar format to the diary, and export from the diary to +iCalendar. It also adds the ability to include iCalendar files in the +diary and display and mark their contents in the calendar without +importing them to the diary file. The library uses the new iCalendar +library (see above) and makes diary import and export more customizable. + ** Calc *** New user option 'calc-string-maximum-character'. @@ -3247,6 +3275,11 @@ value. Previously, only 'hi-lock-face-buffer' supported this. * New Modes and Packages in Emacs 31.1 +** New major mode 'icalendar-mode'. +A major mode for displaying and editing iCalendar (RFC5545) data. This +mode handles line unfolding and fontification, including highlighting +syntax errors in invalid data. + ** New minor mode 'delete-trailing-whitespace-mode'. A simple buffer-local mode that runs 'delete-trailing-whitespace' before saving the buffer. diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index e948bdb558e..ff62e85adf5 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -226,7 +226,7 @@ The result has the proper form for `calendar-daylight-savings-starts'." (car candidate-rules))) ;; TODO it might be better to extract this information directly from -;; the system timezone database. But cross-platform...? +;; the system timezone database. But cross-platform...? ;; See thread ;; https://lists.gnu.org/r/emacs-pretest-bug/2006-11/msg00060.html (defun calendar-dst-find-data (&optional time) @@ -309,7 +309,9 @@ system knows: UTC-DIFF is an integer specifying the number of minutes difference between standard time in the current time zone and Coordinated Universal Time (Greenwich Mean Time). A negative value means west of Greenwich. -DST-OFFSET is an integer giving the daylight saving time offset in minutes. +DST-OFFSET is an integer giving the daylight saving time offset in minutes + relative to UTC-DIFF. (That is, the total UTC offset during daylight saving + time is UTC-DIFF + DST-OFFSET minutes.) STD-ZONE is a string giving the name of the time zone when no seasonal time adjustment is in effect. DST-ZONE is a string giving the name of the time zone when there is a seasonal diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index aad05f572d6..299e6b8cf21 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -431,11 +431,7 @@ Interactively, prompt for YEAR and DAY number." (calendar-day-number (calendar-current-date)) last))) (list year day))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (if (< 0 day) - (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year))) - (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year)))))) + (calendar-goto-date (calendar-date-from-day-of-year year day)) (or noecho (calendar-print-day-of-year))) (provide 'cal-move) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 6805a84a80d..858564999ce 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -871,7 +871,15 @@ current word of the diary entry, so in no case can the pattern match more than a portion of the first word of the diary entry. For examples of three common styles, see `diary-american-date-forms', -`diary-european-date-forms', and `diary-iso-date-forms'." +`diary-european-date-forms', and `diary-iso-date-forms'. + +If you customize this variable, you should also customize the variable +`diary-date-insertion-form' to contain a pseudo-pattern which produces +dates that match one of the forms in this variable. (If +`diary-date-insertion-form' does not correspond to one of the patterns +in this variable, then the diary will not recognize such dates, +including those inserted into the diary from the calendar with +`diary-insert-entry'.)" :type '(repeat (choice (cons :tag "Backup" :value (backup . nil) (const backup) @@ -895,6 +903,52 @@ For examples of three common styles, see `diary-american-date-forms', (diary)))) :group 'diary) +(defconst diary-american-date-insertion-form '(month "/" day "/" year) + "Pseudo-pattern for American dates in `diary-date-insertion-form'") + +(defconst diary-european-date-insertion-form '(day "/" month "/" year) + "Pseudo-pattern for European dates in `diary-date-insertion-form'") + +(defconst diary-iso-date-insertion-form '(year "/" month "/" day) + "Pseudo-pattern for ISO dates in `diary-date-insertion-form'") + +(defcustom diary-date-insertion-form + (cond ((eq calendar-date-style 'iso) diary-iso-date-insertion-form) + ((eq calendar-date-style 'european) diary-european-date-insertion-form) + (t diary-american-date-insertion-form)) + "Pseudo-pattern describing how to format a date for a new diary entry. + +A pseudo-pattern is a list of expressions that can include the symbols +`month', `day', and `year' (all numbers in string form), and `monthname' +and `dayname' (both alphabetic strings). For example, a typical American +form would be + + (month \"/\" day \"/\" (substring year -2)) + +whereas + + ((format \"%9s, %9s %2s, %4s\" dayname monthname day year)) + +would give the usual American style in fixed-length fields. + +This pattern will be used by `calendar-date-string' (which see) to +format dates when inserting them with `diary-insert-entry', or when +importing them from other formats into the diary. + +If you customize this variable, you should also customize the variable +`diary-date-forms' to include a pseudo-pattern which matches dates +produced by this pattern. (If there is no corresponding pattern in +`diary-date-forms', then the diary will not recognize such dates, +including those inserted into the diary from the calendar with +`diary-insert-entry'.)" + :version "31.1" + :type 'sexp + :risky t + :set-after '(calendar-date-style diary-american-date-insertion-form + diary-european-date-insertion-form + diary-iso-date-insertion-form) + :group 'diary) + ;; Next three are provided to aid in setting calendar-date-display-form. (defcustom calendar-iso-date-display-form '((format "%s-%.2d-%.2d" year (string-to-number month) @@ -1028,7 +1082,9 @@ The valid styles are described in the documentation of `calendar-date-style'." calendar-month-header (symbol-value (intern-soft (format "calendar-%s-month-header" style))) diary-date-forms - (symbol-value (intern-soft (format "diary-%s-date-forms" style)))) + (symbol-value (intern-soft (format "diary-%s-date-forms" style))) + diary-date-insertion-form + (symbol-value (intern-soft (format "diary-%s-date-insertion-form" style)))) (calendar-redraw) (calendar-update-mode-line)) @@ -1298,6 +1354,16 @@ return negative results." (/ offset-years 400) (calendar-day-number '(12 31 -1))))))) ; days in year 1 BC +;; This function is the inverse of `calendar-day-number': +(defun calendar-date-from-day-of-year (year dayno) + "Return the date of the DAYNO-th day in YEAR. +DAYNO must be an integer between -366 and 366." + (calendar-gregorian-from-absolute + (+ (if (< dayno 0) + (+ 1 dayno (if (calendar-leap-year-p year) 366 365)) + dayno) + (calendar-absolute-from-gregorian (list 12 31 (1- year)))))) + ;;;###autoload (defun calendar (&optional arg) "Display a three-month Gregorian calendar. diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el new file mode 100644 index 00000000000..08fff66fe58 --- /dev/null +++ b/lisp/calendar/diary-icalendar.el @@ -0,0 +1,3970 @@ +;;; diary-icalendar.el --- Display iCalendar data in diary -*- lexical-binding: t; -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Richard Lawrence +;; Created: January 2025 +;; Keywords: calendar +;; Human-Keywords: diary, calendar, iCalendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file is a replacement for icalendar.el that uses a new parser +;; and offers more features. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'icalendar-macs)) +(require 'icalendar) +(require 'icalendar-parser) +(require 'icalendar-utils) +(require 'icalendar-recur) +(require 'icalendar-ast) +(require 'calendar) +(require 'cal-dst) +(require 'diary-lib) +(require 'skeleton) +(require 'seq) +(require 'rx) +(require 'pp) + +;; Customization +(defgroup diary-icalendar nil + "iCalendar import, export, and display in diary." + :version "31.1" + :group 'diary + :prefix 'diary-icalendar) + +;;; Import customizations +(defgroup diary-icalendar-import nil + "iCalendar import into diary." + :version "31.1" + :group 'diary-icalendar + :prefix 'diary-icalendar) + +(defcustom di:always-import-quietly nil + "When non-nil, diary will never ask for confirmations when importing events. + +`diary-icalendar-import-file' and `diary-icalendar-import-buffer' both +accept an optional argument, QUIETLY, which determines whether these +functions ask for confirmation when importing individual events and +saving the diary file. If you set this variable to t, you will never be +asked to confirm." + :version "31.1" + :type '(choice (const :tag "Ask for confirmations" nil) + (const :tag "Never ask for confirmations" t))) + +(defcustom di:after-mailcap-viewer-hook nil + "Hook run after `diary-icalendar-mailcap-viewer'. + +The functions in this hook will be run after formatting the contents of +iCalendar data as diary entries in a temporary buffer. You can add +functions to this hook if you want, for example, to copy these entries +somewhere else." + :version "31.1" + :type '(hook)) + +(defcustom di:attachment-directory nil + "Directory in which to save iCalendar attachments when importing. + +If the value is nil, binary attachments encoded in an ATTACH property +are never saved. If it is the name of a directory, attachments will be +saved in per-component subdirectories of this directory, with each +subdirectory named by the component's UID value." + :version "31.1" + :type '(choice + (const :tag "Do not save attachments" nil) + directory)) + +(defcustom di:time-format "%H:%M" + "Format string to use for event times. + +The value must be a valid format string for `format-time-string'; see +its docstring for more information. The value only needs to format clock +times, and should format them in a way that will be recognized by +`diary-time-regexp'. (Date information is formatted separately at the +start of the imported entry.) Examples: + + \"%H:%M\" - 24-hour, 0-padded: 09:00 or 21:00 + \"%k.%Mh\" - 24-hour, blank-padded: 9.00h or 21.00h + \"%I:%M%p\" - 12-hour, 0-padded, with AM/PM: 09:00AM or 09:00PM + \"%l.%M%p\" - 12-hour, blank-padded, with AM/PM: 9.00AM or 9.00PM" + :version "31.1" + :type '(string)) + +(defcustom di:attendee-skeleton-command 'di:attendee-skeleton + "Function to format ATTENDEE properties during diary import. + +This should be a symbol naming a function which inserts information +about an `icalendar-attendee' into the current buffer. It is convenient +to express such a function as a skeleton; see `define-skeleton' and +`skeleton-insert' for more information. + +The function will be called with no arguments and should insert +information about the attendee into the current buffer. + +The following variables will be (dynamically) bound when the function is +called. All values will be strings (unless another type is noted), or +nil: + +address - the attendee's calendar address, with \"mailto:\" removed +full-address - the attendee's calendar address, with nothing removed +cn - the attendee's common name (`icalendar-cnparam') +dir - URL of attendee's directory entry (`icalendar-directoryparam') +cutype - the attendee's user type (`icalendar-cutypeparam') +language - a language abbreviation (`icalendar-languageparam') +role - the attendee's role in the event (`icalendar-roleparam') +partstat - the attendee's participation status (`icalendar-partstatparam') +rsvp - whether an RSVP is requested (`icalendar-rsvpparam') +member-addresses (list of strings) - any groups/lists where the attendee + is a member (`icalendar-memberparam'), with \"mailto:\" removed +member-full-addresses - like member-addresses, but nothing removed +delfrom-addresses (list of strings) - addresses of users who delegated + their participation to the attendee (`icalendar-delfromparam'), with + \"mailto:\" removed +delfrom-full-addresses - like delfrom-addresses, but nothing removed +delto-addresses (list of strings) - addresses of users to whom the + attendee delegated participation (`icalendar-deltoparam'), with + \"mailto:\" removed +delto-full-addresses - like delto-addresses, but nothing removed +sentby-address - address of user who sent the invitation on someone + else's behalf (`icalendar-sentbyparam'), with \"mailto:\" removed +sentby-full-address - like sentby-address, but nothing removed" + :version "31.1" + :type '(radio (function-item di:attendee-skeleton) + (function :tag "Other function"))) + +(defcustom di:skip-addresses-regexp user-mail-address + "Regular expression matching addresses to skip when importing. + +This regular expression should match calendar addresses (which are +typically \"mailto:\" URIs) which should be skipped when importing +ATTENDEE, ORGANIZER, and other iCalendar properties that identify a +contact. + +You can make this match your own email address(es) to prevent them from +being formatted by `diary-icalendar-attendee-skeleton-command' and +listed in diary entries." + :version "31.1" + :type '(regexp)) + +(defcustom di:vevent-skeleton-command #'di:vevent-skeleton + "Function to format VEVENT components for the diary. + +This should be a symbol naming a function which inserts information +about an `icalendar-vevent' into the current buffer. It is convenient +to express such a function as a skeleton; see `define-skeleton' and +`skeleton-insert' for more information. + +The following variables will be bound when the function is called. +All values will be strings unless another type is noted, or nil: + +alarms (list of `icalendar-valarm' nodes) - notifications in the event +as-alarm (symbol) - non-nil when the event should be formatted for an + alarm notification in advance of the event. The symbol indicates the + type of alarm: `email' means to format the event as the body of an email. + (Currently only used for EMAIL alarms; see `icalendar-export-alarms'.) +attachments (list of strings) - URLs or filenames of attachments in the event +attendees (list of strings) - the participants of the event, + formatted by `diary-icalendar-attendee-skeleton-command' +categories (list of strings) - categories specified in the event +access - the event's access classification +comments (list of strings) - comments specified in the event +created-dt (an `icalendar-date-time' value) - when the event was created +created - created-dt, formatted as a local date-time string +description - the event's description +dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the event + starts +dtend (an `icalendar-date' or `icalendar-date-time' value) - when the + event ends; this is either the value of the `icalendar-dtend' + property, or the end time calculated by adding the event's + `icalendar-duration' to its `icalendar-dtstart' properties +start - start date and time in a single string. When importing, + includes the date, otherwise just the (local) time. +end - end date and time in a single string. When importing, + includes the date, otherwise just the (local) time. +start-to-end - a single string containing both start and end date and + (local) time. If the event starts and ends on the same day, the date + is not repeated. When importing, dates are included, and the string + may contain a diary s-exp; when displaying, the string contains only + the times for the displayed date. If there is no end date, same as start. +dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the event + was last revised +duration (an `icalendar-dur-value') - the event's duration +coordinates (an `icalendar-geo-coordinates' value) - the event's geographical + coordinates +geo-location - coordinates, formatted as a string with degrees N/S and E/W +importing (a boolean) - t if the event should be formatted for import. + When nil, the event should be formatted for display rather than import. + When importing it is important to include all information from the event + that you want to be saved in the diary; when displaying, information like + the date (or date-related S-expressions) and UID can be left out. +last-modified-dt (an `icalendar-date-time' value) - the date and time the event + was last modified +last-modified - last-modified-dt, formatted as a local date and time string +location - the event's location +non-marking (a boolean) - if non-nil, the diary entry should be non-marking +organizer - the event's organizer, formatted by + `diary-icalendar-attendee-skeleton-command' +priority (a number) - the event's priority (1 = highest priority, 9 = lowest; + 0 = undefined) +recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the + date or date-time of a particular recurrence of the event +recurrence-id - recurrence-id-dt, formatted as a local date and time string +related-tos (a list of `icalendar-related-to' property nodes) - + these contain the UIDs of related events and their relationship type +request-statuses (a list of `icalendar-request-status' property nodes) - + these contain status information about requests made +resources (a list of strings) - resources used or needed for the event +rrule-sexp - a string containing a diary S-expression for a recurring event. + If this is non-nil, you should normally use it instead of the start-* and + end-* variables to form the date of the entry. +revision (a number) - the revision number of the event; see + `icalendar-sequence' +status - overall status specified by the organizer (e.g. \"confirmed\") +summary - a summary of the event +transparency - the event's time transparency status; see `icalendar-transp' +uid - the unique identifier of the event +url - a URL for the event" + :version "31.1" + :type '(radio (function-item di:vevent-skeleton) + (function :tag "Other function"))) + +(defcustom di:vjournal-skeleton-command #'di:vjournal-skeleton + "Function to format VJOURNAL components for the diary. + +This should be a symbol naming a function which inserts information about +an `icalendar-vjournal' into the current buffer. It is convenient to +express such a function as a skeleton; see `define-skeleton' and +`skeleton-insert' for more information, and see +`diary-icalendar-vjournal-skeleton' for an example. + +The following variables will be bound when the function is called. +All values will be strings unless another type is noted, or nil: + +alarms (list of `icalendar-valarm' nodes) - notifications in the journal entry +attachments (list of strings) - URLs or filenames of attachments in the journal + entry +attendees (list of strings) - the participants of the journal entry, + formatted by `diary-icalendar-attendee-skeleton-command' +categories (list of strings) - categories specified in the journal entry +access - the journal entry's access classification +comments (list of strings) - comments specified in the journal entry +created-dt (an `icalendar-date-time' value) - the date and time the + journal entry was created +created - created-dt, formatted as a local date-time string +descriptions (list of strings) - the journal entry's descriptions + (more than one description is allowed in iCalendar VJOURNAL components) +dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the + journal entry was last revised +dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the journal + entry starts +start - start date and time in a single string. When importing, + includes the date, otherwise just the (local) time. +importing (a boolean) - t if the journal entry should be formatted for import. + When nil, the entry should be formatted for display rather than import. + When importing it is important to include all information from the entry + that you want to be saved in the diary; when displaying, information like + the date (or date-related S-expressions) and UID can be left out. +last-modified-dt (an `icalendar-date-time' value) - the date and time + the journal entry was last modified +last-modified - last-modified-dt, formatted as a local date and time string +non-marking (a boolean) - if non-nil, the diary entry should be non-marking +organizer - the journal entry's organizer, formatted by + `diary-icalendar-attendee-skeleton-command' +recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the + date or date-time of a particular recurrence of the journal entry +recurrence-id - recurrence-id-dt, formatted as a local date and time string +related-tos (a list of `icalendar-related-to' property nodes) - + these contain the UIDs of related journal entrys and their relationship type +request-statuses (a list of `icalendar-request-status' property nodes) - + these contain status information about requests made +rrule-sexp - a string containing a diary S-expression for a recurring + journal entry. If this is non-nil, you should normally use it instead + of the start-* variables to form the date of the entry. +revision (a number) - the revision number of the journal entry; see + `icalendar-sequence' +status - overall status specified by the organizer (e.g. \"draft\") +summary - a summary of the journal entry +uid - the unique identifier of the journal entry +url - a URL for the journal entry" + :version "31.1" + :type '(radio (function-item di:vjournal-skeleton) + (function :tag "Other function"))) + +(defcustom di:import-vjournal-as-nonmarking t + "Whether to import VJOURNAL components as nonmarking diary entries. + +If this variable is non-nil, VJOURNAL components will be imported into +the diary as \"nonmarking\" entries by prefixing +`diary-nonmarking-symbol'. This means they will not cause their date to +be marked in the calendar when the command `diary-mark-entries' is +called. See Info node `(emacs)Displaying the Diary' for more +information." + :version "31.1" + :type '(choice (const :tag "Import as nonmarking entries" t) + (const :tag "Import as normal (marking) entries" nil))) + +(defcustom di:vtodo-skeleton-command #'di:vtodo-skeleton + "Function to format VTODO components for the diary. + +This should be a symbol naming a function which inserts information about +an `icalendar-vtodo' into the current buffer. It is convenient to +express such a function as a skeleton; see `define-skeleton' and +`skeleton-insert' for more information. + +The following variables will be bound when the function is called. +All values will be strings unless another type is noted, or nil: + +alarms (list of `icalendar-valarm' nodes) - notifications in the task +as-alarm (symbol) - non-nil when the task should be formatted for an + alarm notification in advance of the task. The symbol indicates the + type of alarm: `email' means to format the task as the body of an email. + (Currently only used for EMAIL alarms; see `icalendar-export-alarms'.) +attachments (list of strings) - URLs or filenames of attachments in the task +attendees (list of strings) - the participants of the task, + formatted by `diary-icalendar-attendee-skeleton-command' +categories (list of strings) - categories specified in the task +access - the task's access classification +comments (list of strings) - comments specified in the task +completed-dt (an `icalendar-date-time' value) - when the task was completed +completed - completed-dt, formatted as a local date-time string +created-dt (an `icalendar-date-time' value) - when the task was created +created - created-dt, formatted as a local date-time string +description - the task's description +dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the task + was last revised +dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the task + starts +start - start-date and time in a single string. When importing, + includes the date, otherwise just the (local) time +start-to-end - a single string containing both start and due date and + time. If the task starts and ends on the same day, the date is not + repeated. When importing, dates are included, and the string may + contain a diary s-exp; when displaying, the string contains only the + times for the displayed date. If there is no end date, same as start. +duration (an `icalendar-dur-value') - the task's duration +due-dt (an `icalendar-date' or `icalendar-date-time' value) - when the + task is due +dtend - same as `due-dt' +due - due date and time in a single string +end - same as `due' +work-time-sexp - when the task has both a start date and a due date, + this is a %%(diary-time-block ...) diary S-expression representing the + time from the start date to the due date (only non-nil when + importing). You can use this e.g. to make a separate entry for the + task's work time, so that it shows up every day in the diary until it + is due. +coordinates (an `icalendar-geo-coordinates' value) - the task's geographical + coordinates +geo-location - coordinates, formatted as a string with degrees N/S and E/W +importing (a boolean) - t if the task should be formatted for import. + When nil, the task should be formatted for display rather than import. + When importing it is important to include all information from the task + that you want to be saved in the diary; when displaying, information like + the date (or date-related S-expressions) and UID can be left out. +last-modified-dt (an `icalendar-date-time' value) - the date and time the task + was last modified +last-modified - last-modified-dt, formatted as a local date and time string +location - the task's location +non-marking (a boolean) - if non-nil, the diary entry should be non-marking +organizer - the task's organizer, formatted by + `diary-icalendar-attendee-skeleton-command' +percent-complete (a number between 0 and 100) - the percentage of the task which + has already been completed +priority (a number) - the task's priority (1 = highest priority, 9 = lowest; + 0 = undefined) +recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the + date or date-time of a particular recurrence of the task +recurrence-id - recurrence-id-dt, formatted as a local date and time string +related-tos (a list of `icalendar-related-to' property nodes) - + these contain the UIDs of related tasks and their relationship type +request-statuses (a list of `icalendar-request-status' property nodes) - + these contain status information about requests made +resources (a list of strings) - resources used or needed for the task +rrule-sexp - a string containing a diary S-expression for a recurring task + (only non-nil when importing). When this is non-nil, you should + normally use it instead of the start and end variables to form the + date of the entry. +revision (a number) - the revision number of the task; see + `icalendar-sequence' +status - overall status specified by the organizer (e.g. \"confirmed\") +summary - a summary of the task +uid - the unique identifier of the task +url - a URL for the task" + :version "31.1" + :type '(radio (function-item di:vjournal-skeleton) + (function :tag "Other function"))) + +(defcustom di:import-predicate #'identity + "Predicate to filter iCalendar components before importing. + +This function must accept one argument, which will be an +`icalendar-vevent', `icalendar-vtodo', or `icalendar-vjournal' +component. It should return non-nil if this component should be +formatted for import, or nil if it should be skipped. + +The default value will format all the events, todos, and journal entries +in a given calendar." + :version "31.1" + :type '(radio (function-item identity) + (function :tag "Other predicate"))) + +;;; Export customization +(defgroup diary-icalendar-export nil + "iCalendar export from diary." + :version "31.1" + :group 'diary-icalendar + :prefix 'diary-icalendar) + +(defcustom di:address-regexp + (rx line-start + (one-or-more space) + (zero-or-one ;; property prefix, e.g. "Attendee:" or "Organizer:" + (seq (one-or-more word) ":")) + (group-n 2 (zero-or-more (not (any "<" "\n")))) + "<" + (group-n 1 (one-or-more (not (any "@" "\n"))) + "@" + (one-or-more (not (any ">" "\n")))) + ">") + "Regular expression to match calendar user (email) addresses. + +The full address should match group 1; \"mailto:\" will be prepended to +the full address during export, unless it or another URI scheme is +present. If there is a match in group 2, it will be used as the +common name associated with the address (see `icalendar-cnparam'). + +The default value matches names and addresses on lines like: + + Ms. Baz + +as well as on lines like: + + Property: Ms. Baz other data... + +Any matching address within a diary entry will be exported as an +iCalendar ATTENDEE property, unless the line on which it appears is also +a match for `diary-icalendar-organizer-regexp', in which case it will be +exported as the ORGANIZER property." + :version "31.1" + :type '(regexp)) + +(defcustom di:description-regexp nil + "Regular expression to match description in an entry. + +If this is nil, the entire entry (after the date and time specification) +is used as the description. Thus, it is only necessary to set this +variable if you want to export diary entries where the text to be used +as the description should not include the full entry body. In that case, +the description should match group 1 of this regexp." + :version "31.1" + :type '(regexp)) + +(defcustom di:organizer-regexp + (rx line-start + (one-or-more space) + "Organizer:") + "Regular expression to match line of an entry specifying the ORGANIZER. + +This regular expression need *not* match the name and address of the +organizer (`diary-icalendar-address-regexp' is responsible for that). +It only needs to match a line on which the organizer's address appears, +to distinguish the organizer's address from other addresses." + :version "31.1" + :type '(regexp)) + +(defcustom di:class-regexp + (rx line-start + (one-or-more space) + (or "Class:" ; for backward compatibility + "Access:") + (zero-or-more space) + (group-n 1 (or "public" "private" "confidential"))) + "Regular expression to match access classification. + +The access classification value should be matched by group 1. The default +regexp matches access classifications like: + Access: C +or + Class: C +where C can be any of: + public + private + confidential" + :version "31.1" + :type '(regexp)) + +(defcustom di:location-regexp + (rx line-start + (one-or-more space) + "Location:" + (zero-or-more space) + (group-n 1 (one-or-more not-newline))) + "Regular expression to match location of an event. + +The location value should be matched by group 1. The default regexp +matches lines like: + + Location: Some place" + :version "31.1" + :type '(regexp)) + +(defcustom di:status-regexp + (rx line-start + (one-or-more space) + "Status:" + (zero-or-more space) + (group-n 1 (or "tentative" "confirmed" "cancelled" "needs-action" "completed" + "in-process" "draft" "final"))) + "Regular expression to match status of an event. + +The status value should be matched by group 1. The default regexp +matches statuses on lines like: + + Status: S + +where S can be any of: + + tentative + confirmed + cancelled + needs-action + completed + in-process + draft + final" + :version "31.1" + :type '(regexp)) + +(defcustom di:summary-regexp nil + "Regular expression to match summary in an entry. + +If this is nil, the first line of the entry (after the date and time +specification) is used as the summary. Thus, it is only necessary to set +this variable if you want to export diary entries where the text to be +used as the summary does not appear on the first line of the entry. In +that case, the summary should match group 1 of this regexp." + :version "31.1" + :type '(regexp)) + +(defcustom di:todo-regexp nil + "Regular expression that identifies an entry as a task (VTODO). + +If this is non-nil, any diary entry that matches this regexp will be +exported as an iCalendar VTODO component (instead of VEVENT), with its +due date equal to the entry date." + :version "31.1" + :type '(radio (const :tag "Do not export VTODO tasks" nil) + (regexp :tag "Regexp for tasks"))) + +(defcustom di:uid-regexp + (rx line-start + (one-or-more space) + "UID:" + (zero-or-more space) + (group-n 1 (one-or-more not-newline))) + "Regular expression to match UID of an entry. + +The UID value should be matched by group 1. The default regexp matches +UIDs on lines like: + + UID: some-unique-identifier" + :version "31.1" + :type '(regexp)) + +(defcustom di:url-regexp + (rx line-start + (one-or-more space) + "URL:" + (zero-or-more space) + (group-n 1 (eval 'ical:uri))) + "Regular expression to match URL of an entry. + +The full URL should be matched by group 1. The default regexp matches +URLs on lines like: + + URL: http://example.com/foo/bar" + :version "31.1" + :type '(regexp)) + +(defcustom di:export-nonmarking-entries t + "Whether to export nonmarking diary entries. + +If this variable is nil, nonmarking diary entries (those prefixed with +`diary-nonmarking-symbol') are never exported. If it is non-nil, +nonmarking diary entries are exported; see also +`diary-icalendar-export-nonmarking-as-vjournal' for more control over +how they are exported." + :version "31.1" + :type '(choice (const :tag "Export nonmarking entries" t) + (const :tag "Do not export nonmarking entries" nil))) + +(defcustom di:export-nonmarking-as-vjournal nil + "Whether to export nonmarking diary entries as VJOURNAL components. + +If this variable is non-nil, nonmarking diary entries (those prefixed +with `diary-nonmarking-symbol') will be exported as iCalendar VJOURNAL +components, rather than VEVENT components. VJOURNAL components are +intended to represent notes, documents, or other data associated with a +date. External calendar applications may treat VJOURNAL components +differently than VEVENTs, so consult your application's documentation +before setting this variable to t. + +If this variable is nil, nonmarking entries will be exported as VEVENT +components which do not take up busy time in the calendar (i.e., with +the TRANSP property set to \"TRANSPARENT\"; see `icalendar-transp')." + :version "31.1" + :type '(choice (const :tag "Export nonmarking entries as VEVENT" nil) + (const :tag "Export nonmarking entries as VJOURNAL" t)) + :link '(url-link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.3")) + +(defcustom di:export-alarms + nil + "Determine whether and how alarms are included in exported diary events. + +If this variable is nil, no alarms are created during export. +If it is non-nil, it should be a list of lists like: + +\((TYPE LEAD-TIME [OPTIONS]) ...) + +In each inner list, the first element TYPE should be a symbol indicating +an alarm type to generate: one of \\='audio, \\='display, or \\='email. +The second element LEAD-TIME should be an integer specifying the amount +of time before the event, in minutes, when the alarm should be +triggered. For audio alarms, there are currently no other +OPTIONS. + +For display and email alarms, the next OPTION is a format string for the +displayed alarm, or the email subject line. In this string, \"%t\" will +be replaced with LEAD-TIME and \"%s\" with the event's summary. + +If TYPE is \\='email, the next OPTION should be a list whose members +specify the email addresses to which email alarms should be sent. These +can either be email addresses (as strings), or the symbol +\\='from-entry, meaning that these addresses should be taken from the +exported diary entry (see `diary-icalendar-address-regexp')." + :version "31.1" + :type + '(choice (const :tag "Do not include alarms when exporting diary entries" nil) + (set :tag "Create alarms of these types" + (list :tag "Audio alarms" + (const :tag "Options" audio) + (integer :tag "Advance time (in minutes)" + :value 10) + ;; TODO: specify an audio file to attach? + ;; TODO: other options we could have here and below: + ;; - whether alarm is before event start or end + ;; - repetitions and delays between repetitions + ) + (list :tag "Display alarms" + (const :tag "Options" display) + (integer :tag "Advance time (minutes)" + :value 10) + (string :tag "Display format" + :value "In %t minutes: %s") + ;; TODO: other options? + ) + (list :tag "Email alarms" + (const :tag "Options" email) + (integer :tag "Advance time (minutes)" + :value 10) + ;; TODO: other options? + (string :tag "Subject line format" + :value "In %t minutes: %s") + (set + :tag "Attendees" + (const :tag "Parse addresses from entry" + from-entry) + (repeat :tag "Other addresses" + (string :tag "Email address"))))))) + +(defcustom di:export-sexp-enumeration-days + 14 + "Number of days over which an S-expression diary entry is enumerated. + +Some S-expression entries cannot be translated to iCalendar format. +They are therefore enumerated, i.e., explicitly evaluated for a +certain number of days, and then exported. The enumeration starts +on the current day and continues for the number of days given here. + +See `icalendar-export-sexp-enumerate-all' for a list of sexp +entries which by default are NOT enumerated." + :version "31.1" + :type 'integer) + +(defcustom di:export-sexp-enumerate-all + nil + "Whether all S-expression diary entries are enumerated. + +If this variable is non-nil, all S-expression diary entries are +enumerated for `diary-icalendar-export-sexp-enumeration-days' days +instead of translating them into an iCalendar equivalent. +This causes the following S-expression entries to be enumerated +instead of translated to a recurrence rule: + `diary-anniversary' + `diary-block' + `diary-cyclic' + `diary-date' + `diary-float' + `diary-remind' + `diary-rrule' + `diary-time-block' +All other S-expression entries are enumerated in any case." + :version "31.1" + :type '(choice (const :tag "Export without enumeration when possible" nil) + (const :tag "Always enumerate S-expression entries" t))) + +(defcustom di:recurring-start-year + (1- (decoded-time-year (decode-time))) + "Start year for recurring events. + +Set this to a year just before the start of your personal calendar. +It is needed when exporting certain diary S-expressions to iCalendar +recurring events, and because some calendar browsers only propagate +recurring events for several years beyond the start time." + :version "31.1" + :type 'integer) + +(defun di:-tz-info-sexp-p (_ sexp) + "Validate that SEXP gives time zone info like from `calendar-current-time-zone'." + (and (listp sexp) + (length= sexp 8) + (let ((utc-diff (nth 0 sexp)) + (dst-offset (nth 1 sexp)) + (std-zone (nth 2 sexp)) + (dst-zone (nth 3 sexp)) + (dst-starts (nth 4 sexp)) + (dst-ends (nth 5 sexp)) + (dst-starts-time (nth 6 sexp)) + (dst-ends-time (nth 7 sexp))) + (and + (integerp utc-diff) (< (abs utc-diff) (* 60 24)) + (integerp dst-offset) (< (abs utc-diff) (* 60 24)) + (stringp std-zone) + (stringp dst-zone) + (or (and (listp dst-starts) (memq 'year (flatten-list dst-starts))) + (and (null dst-starts) (equal std-zone dst-zone))) + (or (and (listp dst-ends) (memq 'year (flatten-list dst-ends))) + (and (null dst-ends) (equal std-zone dst-zone))) + (or (and (integerp dst-starts-time) (< (abs dst-starts-time) (* 60 24))) + (null dst-starts-time)) + (or (and (integerp dst-ends-time) (< (abs dst-ends-time) (* 60 24))) + (null dst-ends-time)))))) + +(defcustom di:time-zone-export-strategy + 'local + "Strategy to use for exporting clock times in diary files. + +The symbol `local' (the default) means to assume that times are in the +time zone determined by `calendar-current-time-zone'. The time zone +information returned by that function will be exported as an iCalendar +VTIMEZONE component, and clock times in the diary file will be exported +with a reference to that time zone definition. + +On some systems, `calendar-current-time-zone' cannot determine time zone +information for the local time zone. In that case, you can set this +variable to a list in the format returned by that function: + + (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE + DST-STARTS DST-ENDS DST-STARTS-TIME DST-ENDS-TIME) + +This list describes the time zone you would like to use for export. See +the docstring of `calendar-current-time-zone' for details. Times in the +diary file will be exported like with `local' for this time zone. + +The other possible values for this variable avoid the need to include +any time zone information in the exported iCalendar data: + +The symbol `to-utc' means to re-encode all exported times to UTC +time. In this case, export will assume that times are in Emacs local +time, and rely on `encode-time' and `decode-time' to convert them to UTC +times. + +The symbol `floating' means to export clock times without any time +zone identifier, which the iCalendar standard (RFC5545) calls +\"floating\" times. RFC5545 specifies that floating times should be +interpreted as local to whichever time zone the recipient of the +iCalendar data is currently in (which might be different from your local +time zone). You should only use this if that behavior makes sense for +the events you are exporting." + :version "31.1" + :type + '(radio (const :tag "Use TZ from `calendar-current-time-zone'" local) + (const :tag "Convert local times to UTC" to-utc) + (const :tag "Use floating times" floating) + (sexp :tag "User-provided TZ information" + :match di:-tz-info-sexp-p + :type-error + "See `calendar-current-time-zone' for format")) + :link '(url-link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.5")) + +(defcustom di:export-linewise + nil + "Export entries with multiple lines to distinct events. + +If this is non-nil, each line of a diary entry will be exported as a +separate iCalendar event. + +If you write your diary entries in a one-entry-per-day style, with +multiple events or appointments per day, you can use this variable to +export these individual events to iCalendar format. For example, an +entry like: + +2025-05-03 + 9AM Lab meeting + GĂŒnter to present on new assay + Start experiment A + 12:30-1:30PM Lunch with Phil + 16:00 Experiment A finishes; move to freezer + +will be exported as four events, each on 2025-05-03 but with different +start times (except for the second event, \"Start experiment A\", which +has no start time). An event line can be continued onto subsequent lines +via additional indentation, as in the first event in this entry. + +If this variable is non-nil, each distinct event must begin on a +continuation line of the entry (below the date); any text on the same +line as the date is ignored. A time specification can only appear at +the beginning of each continuation line of the entry, immediately after +the leading whitespace. + +If this variable is nil, each entry will be exported as exactly one +event, and only a time specification immediately following the date will +determine the start and end times for that event. Thus, in the example +above, the exported event would have a start date but no start time or +end time. The times in the entry would be preserved as text in the +event description." + :version "31.1" + :type '(radio (const :tag "Do not export linewise" nil) + (const :tag "Export linewise" t))) + +(defcustom di:other-properties-parser nil + "Function to parse additional iCalendar properties from diary entries. + +If you like to keep your diary entries in a particular format, you can +set this to a function which parses that format to iCalendar properties +during iCalendar export, so that other calendar applications can use +them. + +The parsing function will be called with no arguments, with the current +restriction set to the boundaries of a diary entry. If +`diary-icalendar-export-linewise' is true, the restriction will +correspond to a single event in a multi-line diary entry. + +The function should return a list of iCalendar property nodes, which +will be incorporated into the `icalendar-vevent', `icalendar-vjournal', +or `icalendar-vtodo' component node created from the current entry. See +the docstrings of those symbols for more information on the properties +they can contain, and the `icalendar-make-property' macro for a simple +way to create property nodes from values parsed from the entry. + +When the function is called, the variables `type' and `properties' will +be dynamically bound. `type' is bound to the iCalendar type symbol (one +of \\='icalendar-vevent, \\='icalendar-vjournal, or \\='icalendar-vtodo) +for the component being generated for the entry. `properties' is bound +to the list of property nodes that `diary-icalendar-parse-entry' has +already parsed from the entry and will be included in the exported +component." + :version "31.1" + :type '(radio (const :tag "Do not parse additional properties" nil) + (function :tag "Parsing function"))) + + +;; Utilities for display and import + +;;; Error handling +(define-error 'ical:diary-import-error "Unable to import iCalendar data" + 'ical:error) + +(cl-defun di:signal-import-error (msg &key (diary-buffer (current-buffer)) + (position (point)) + line + (severity 2)) + (let ((err-data + (list :message msg + :buffer diary-buffer + :position position + :line line + :severity severity))) + (signal 'ical:diary-import-error err-data))) + +;;; Backward compatibility with icalendar.el + +;; icalendar.el provided the following customization variables: +;; `icalendar-import-format' +;; `icalendar-import-format-class' +;; `icalendar-import-format-description' +;; `icalendar-import-format-location' +;; `icalendar-import-format-organizer' +;; `icalendar-import-format-summary' +;; `icalendar-import-format-status' +;; `icalendar-import-format-url' +;; `icalendar-import-format-uid' +;; These were all format strings: `icalendar-import-format' was the +;; top-level format string, which would potentially incorporate the +;; formatted output from the others. This approach to customization +;; isn't very flexible, though, and doing it right requires a +;; separate defcustom variable for each iCalendar property. (The above +;; list is not nearly exhaustive.) I have abandoned this approach in +;; what follows in favor of skeleton.el templates, but the following two +;; functions provide backward compatibility for anyone who had +;; customized the values of the above variables: +(defun di:-use-legacy-vars-p () + "Return non-nil if user has set `icalendar-import-format*' variables. +If any of these variables have non-default values, they will be used by +`diary-icalendar-import-format-entry' to import events. This function +is for backward compatibility; please do not rely on it in new code." + (declare (obsolete nil "31.1")) + (with-suppressed-warnings + ((obsolete ical:import-format + ical:import-format-class + ical:import-format-description + ical:import-format-location + ical:import-format-organizer + ical:import-format-summary + ical:import-format-status + ical:import-format-url + ical:import-format-uid)) + (or + (and (boundp 'ical:import-format) + (not (equal ical:import-format + (custom--standard-value 'ical:import-format)))) + (and (boundp 'ical:import-format-class) + (not (equal ical:import-format-class + (custom--standard-value 'ical:import-format-class)))) + (and (boundp 'ical:import-format-description) + (not (equal ical:import-format-description + (custom--standard-value + 'ical:import-format-description)))) + (and (boundp 'ical:import-format-location) + (not (equal ical:import-format-location + (custom--standard-value 'ical:import-format-location)))) + (and (boundp 'ical:import-format-organizer) + (not (equal ical:import-format-organizer + (custom--standard-value 'ical:import-format-organizer)))) + (and (boundp 'ical:import-format-summary) + (not (equal ical:import-format-summary + (custom--standard-value 'ical:import-format-summary)))) + (and (boundp 'ical:import-format-status) + (not (equal ical:import-format-status + (custom--standard-value 'ical:import-format-status)))) + (and (boundp 'ical:import-format-url) + (not (equal ical:import-format-url + (custom--standard-value 'ical:import-format-url)))) + (and (boundp 'ical:import-format-uid) + (not (equal ical:import-format-uid + (custom--standard-value 'ical:import-format-uid))))))) + +(defun di:-format-vevent-legacy (date class desc location organizer + summary status url uid) + "Format an entry on DATE using the values of obsolete import variables. +This function is for backward compatibility; please do not rely on it in +new code." + (declare (obsolete nil "31.1")) + (with-suppressed-warnings + ((obsolete ical:import-format + ical:import-format-class + ical:import-format-description + ical:import-format-location + ical:import-format-organizer + ical:import-format-summary + ical:import-format-status + ical:import-format-url + ical:import-format-uid)) + + (insert ical:import-format) + (replace-regexp-in-region "%c" + (format ical:import-format-class class) + (point-min) (point-max)) + (replace-regexp-in-region "%d" + (format ical:import-format-description desc) + (point-min) (point-max)) + (replace-regexp-in-region "%l" + (format ical:import-format-location location) + (point-min) (point-max)) + (replace-regexp-in-region "%o" + (format ical:import-format-organizer organizer) + (point-min) (point-max)) + (replace-regexp-in-region "%s" + (format ical:import-format-summary summary) + (point-min) (point-max)) + (replace-regexp-in-region "%t" + (format ical:import-format-status status) + (point-min) (point-max)) + (replace-regexp-in-region "%u" + (format ical:import-format-url url) + (point-min) (point-max)) + (replace-regexp-in-region "%U" + (format ical:import-format-uid uid) + (point-min) (point-max)) + (goto-char (point-min)) + (insert date " "))) + +(defun di:-vevent-to-legacy-alist (vevent) + "Convert an `icalendar-vevent' to an alist of the kind used by icalendar.el. +This function is for backward compatibility; please do not rely on it in +new code." + (declare (obsolete nil "31.1")) + ;; function values of `icalendar-import-format' expect a list like: + ;; ((VEVENT nil + ;; ((PROP1 params val) + ;; (PROP2 params val) + ;; ...))) + (let ((vevent-children (ical:ast-node-children vevent)) + children) + (dolist (p vevent-children) + (let* ((type (ical:ast-node-type p)) + (list-sep (get type 'ical:list-sep)) + (name (intern (car (rassq type ical:property-types)))) + ;; icalendar.el did not interpret values when parsing, so we + ;; convert back to string representation: + (value (ical:ast-node-value p)) + (value-str + (or (ical:ast-node-meta-get :original-value p) + (if list-sep + (string-join (mapcar #'ical:default-value-printer value) + list-sep) + (ical:default-value-printer value)))) + params) + (when (ical:ast-node-children p) + (dolist (param (ical:ast-node-children p)) + (let* ((par-str (ical:print-param-node param)) + (split (string-split par-str "[;=]")) + (parname (intern (nth 1 split))) + (parval (nth 2 split))) + (push `(,parname nil ,parval) params))) + (setq params (nreverse params))) + (push `(,name ,params ,value-str) children))) + (setq children (nreverse children)) + ;; Return the legacy alist: + `((VEVENT nil ,children)))) + +;;; Other utilities + +(defsubst di:-nonempty (s) + "Ensure that string S is nonempty once trimmed: return the trimmed S, or nil." + (when (and s (stringp s)) + (let ((trimmed (string-trim s))) + (unless (equal "" trimmed) trimmed)))) + +(defconst di:entry-regexp + (rx line-start + (group-n 1 ; first line of entry + (or (group-n 2 (regexp diary-nonmarking-symbol)) + (not (any "\t\n #"))) + (one-or-more not-newline)) + (group-n 3 ; continuation lines of entry + (zero-or-more "\n" (any space) (zero-or-more not-newline)))) + "Regular expression to match a full diary entry. + +Group 1 matches the first line of the entry. Group 2 contains +`diary-nonmarking-symbol', if it was present at the start of the first +line. Group 3 contains any continuation lines of the entry.") + +;; TODO: move to diary-lib.el? +(defun di:entry-bounds () + "Return markers (START END) bounding the diary entry around point. +If point is not in an entry, return nil." + (save-excursion + (let* ((pt (point)) + (bound (point-min)) + (start (make-marker)) + (end (make-marker))) + (when (re-search-backward "^[[:space:]]*$" nil t) + (setq bound (match-end 0))) + (goto-char pt) + (cond ((looking-at di:entry-regexp) + (set-marker start (match-beginning 0)) + (set-marker end (match-end 0))) + ((re-search-backward di:entry-regexp bound t) + (set-marker start (match-beginning 0)) + ;; match again forward, to ensure we get the full entry; + ;; see `re-search-backward': + (goto-char start) + (when (looking-at di:entry-regexp) + (set-marker end (match-end 0)))) + (t nil)) + (when (and (marker-position start) (marker-position end)) + (list start end))))) + +(defun di:find-entry-with-uid (uid &optional diary-filename) + "Search DIARY-FILENAME (default: `diary-file') for an entry containing UID. + +The UID must occur on a line matching `diary-icalendar-uid-regexp'. If +such an entry exists, return markers (START END) bounding it. +Otherwise, return nil." + (let* ((diary-file (or diary-filename diary-file)) + (diary-buffer (or (find-buffer-visiting diary-file) + (find-file-noselect diary-file)))) + (with-current-buffer diary-buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (catch 'found + (while (re-search-forward di:uid-regexp nil t) + (when (equal uid (match-string 1)) + (throw 'found (di:entry-bounds)))) + ;; continue search in included files: + ;; TODO: is this a good idea? + ;; (goto-char (point-min)) + ;; (while (re-search-forward + ;; (rx line-start (regexp diary-include-string) + ;; ?\" (group-n 1 (one-or-more (not ?\")) ?\")) + ;; nil t) + ;; (let ((entry (di:find-entry-with-uid uid (match-string 1)))) + ;; (when entry + ;; (throw 'found entry)))) + ;; nothing to return: + nil)))))) + +(defun di:y-or-n-or-edit-p (prompt) + "Like `y-or-n-p', but with the option to enter a recursive edit. +Adds a message to current binding of `help-form' explaining how." + (let* ((allow-edits-map + (let ((map (make-sparse-keymap))) + (define-key map [remap edit] + (lambda () + (interactive) + (save-excursion + (save-window-excursion + (recursive-edit))))) + map)) + (y-or-n-p-map (make-composed-keymap allow-edits-map + y-or-n-p-map)) + (help-form + (concat (when (stringp help-form) (concat help-form "\n\n")) + ;; FIXME: should use substitute-command-keys here, but + ;; for some reason, even with \, it + ;; doesn't find the C-r and C-M-c bindings and only + ;; suggests M-x ... + "Type C-r to enter recursive edit before answering " + "(C-M-c to exit)."))) + (save-excursion + (save-restriction + (y-or-n-p prompt))))) + +;;; Skeletons +;; +;; We use skeleton.el's templating facilities to make formatting of +;; different iCalendar elements in the diary simple and easy to +;; customize. There are default skeletons for each major type of +;; iCalendar component (`di:vevent-skeleton', `di:vtodo-skeleton', +;; `di:vjournal-skeleton'), and a corresponding defcustom pointing to +;; each of these skeletons (`di:vevent-skeleton-command', etc.). +;; `di:format-entry' calls these skeletons, or user-provided functions, +;; to format individual components as diary entries. Since properties +;; representing people (`icalendar-attendee', `icalendar-organizer') are +;; important and relatively complex, another skeleton +;; (`di:attendee-skeleton') takes care of formatting these for the +;; top-level component skeletons. +(define-skeleton di:attendee-skeleton + "Default skeleton to format an `icalendar-attendee' for the diary. + +Includes any data from the attendee's `icalendar-cnparam' and +`icalendar-partstatparam', and does not insert any data if its +`icalendar-cutypeparam' is non-nil and anything other than +\"INDIVIDUAL\" or \"GROUP\". + +The result looks like: + +or + Baz Foo +or + Baz Foo (declined)" + nil + ;; skip non-human "attendees": + (when (or (not cutype) (equal cutype "INDIVIDUAL") (equal cutype "GROUP")) + (skeleton-insert + '(nil + cn + (format " <%s>" address) + (when partstat (format " (%s)" (downcase partstat))))))) + +(defun di:format-attendee (attendee) + "Format ATTENDEE for the diary. + +ATTENDEE should be an `icalendar-attendee' or `icalendar-organizer' +property node. Returns a string representing an entry for the attendee, +formatted by `diary-icalendar-attendee-skeleton-command', unless the +attendee's address matches the regexp in +`diary-icalendar-skip-addresses-regexp'; in that case, nil is returned." + (ical:with-property attendee + ((ical:cutypeparam :value cutype) + (ical:cnparam :value cn) + (ical:memberparam :values member) + (ical:roleparam :value role) + (ical:partstatparam :value partstat) + (ical:rsvpparam :value rsvp) + (ical:deltoparam :values delto) + (ical:delfromparam :values delfrom) + (ical:sentbyparam :value sentby) + (ical:dirparam :value dir) + (ical:languageparam :value language)) + (calendar-dlet + ((full-address value) + (address (ical:strip-mailto value)) + (cn (when cn (string-trim cn))) + (cutype cutype) + (dir dir) + (role role) + (partstat partstat) + (rsvp rsvp) + (delfrom-full-addresses delfrom) + (delfrom-addresses + (mapcar #'ical:strip-mailto delfrom)) + (delto-full-addresses delto) + (delto-addresses + (mapcar #'ical:strip-mailto delto)) + (member-full-addresses member) + (member-addresses + (mapcar #'ical:strip-mailto member)) + (sentby-full-address sentby) + (sentby-address + (when sentby (ical:strip-mailto sentby))) + (language language)) + (unless (and di:skip-addresses-regexp + (string-match-p di:skip-addresses-regexp full-address)) + (with-temp-buffer + (funcall di:attendee-skeleton-command) + (buffer-string)))))) + +(define-skeleton di:vevent-skeleton + "Default skeleton to format an `icalendar-vevent' for the diary." + nil + (when (or non-marking (equal transparency "TRANSPARENT")) + diary-nonmarking-symbol) + (or rrule-sexp start-to-end start) & " " + summary "\n" + @ ; start of body (for indentation) + (when (or location geo-location) "Location: ") (or location geo-location) + & "\n" (when url "URL: ") & url + & "\n" (when status "Status: ") & status + & "\n" (when organizer "Organizer: ") & organizer + & "\n" (di:format-list attendees "Attendee") + & "\n" (di:format-list categories "Category" "Categories") + & "\n" (di:format-list comments "Comment") + & "\n" (di:format-list contacts "Contact") + & "\n" (di:format-list attachments "Attachment") + & "\n" (when (and importing access) "Access: ") & access + & "\n" (when (and importing uid) "UID: ") & uid + & "\n" (when description "Description: ") & description + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + ;; TODO: should diary define a customizable indentation level? + ;; For now, we use 1 because that's what icalendar.el chose + (indent-code-rigidly start end 1)) + (when importing "\n")) + +(define-skeleton di:vjournal-skeleton + "Default skeleton to format an `icalendar-vjournal' for the diary." + nil + (when (or non-marking di:import-vjournal-as-nonmarking) + diary-nonmarking-symbol) + (or rrule-sexp start) & " " + summary "\n" + @ ; start of body (for indentation) + & "\n" (when url "URL: ") & url + & "\n" (when status "Status: ") & status + & "\n" (when organizer "Organizer: ") & organizer + & "\n" (di:format-list attendees "Attendee") + & "\n" (di:format-list categories "Category" "Categories") + & "\n" (di:format-list comments "Comment") + & "\n" (di:format-list contacts "Contact") + & "\n" (di:format-list attachments "Attachment") + & "\n" (when (and importing access) "Access: ") & access + & "\n" (when (and importing uid) "UID: ") & uid + ;; In a vjournal, multiple `icalendar-description's are allowed: + & "\n" (di:format-list descriptions "Description") + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + (indent-code-rigidly start end 1)) + (when importing "\n")) + +(define-skeleton di:vtodo-skeleton + "Default skeleton to format an `icalendar-vtodo' for the diary." + nil + (when non-marking diary-nonmarking-symbol) + (or rrule-sexp due) & " " + (when due "Due: ") summary + (when start (concat " (Start: " start ")")) + "\n" + @ ; start of body (for indentation) + & "\n" (when url "URL: ") & url + & "\n" (when status "Status: ") & status + & "\n" (when completed "Completed: ") & completed + & "\n" (when percent-complete (format "Progress: %d%%" percent-complete)) + & "\n" (when organizer "Organizer: ") & organizer + & "\n" (di:format-list attendees "Attendee") + & "\n" (di:format-list categories "Category" "Categories") + & "\n" (di:format-list comments "Comment") + & "\n" (di:format-list contacts "Contact") + & "\n" (di:format-list attachments "Attachment") + & "\n" (when (and importing access) "Access: ") & access + & "\n" (when (and importing uid) "UID: ") & uid + & "\n" (when description "Description: ") & description + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + (indent-code-rigidly start end 1)) + (when importing "\n")) + +;;; Further utilities for formatting/importing special kinds of values: +(defun di:format-geo-coordinates (geo) + "Format an `icalendar-geo-coordinates' value as degrees N/S and E/W." + (format "%.6f°%s %.6f°%s" ; RFC5545 says we may truncate after 6 decimal places + (abs (car geo)) (if (< 0 (car geo)) "N" "S") + (abs (cdr geo)) (if (< 0 (cdr geo)) "E" "W"))) + +(defun ical:save-binary-attachment (base64-data dir &optional mimetype) + "Decode and save BASE64-DATA to a new file in DIR. + +The file will be named based on a unique prefix of BASE64-DATA with an +extension based on MIMETYPE. It will be saved in a subdirectory named +DIR of `diary-icalendar-attachment-directory', which will be created if +necessary. Returns the (non-directory part of) the saved filename." + (require 'mailcap) + ;; Create the subdirectory for the attachment if necessary: + (unless (and (directory-name-p di:attachment-directory) + (file-writable-p di:attachment-directory)) + (di:signal-import-error + (format "Cannot write to directory: %s" di:attachment-directory))) + (make-directory (file-name-concat di:attachment-directory dir) t) + ;; Create a unique filename for the attachment. Unfortunately RFC5545 + ;; has no mechanism for suggesting a filename, so we just use a unique + ;; prefix of BASE64-DATA, or a random number as a fallback. + (let* ((nchars 4) + (max-chars (length base64-data)) + (prefix (substring base64-data 0 nchars)) + (extn (when mimetype + (concat "." (symbol-name + (mailcap-mime-type-to-extension mimetype))))) + (path (file-name-concat di:attachment-directory dir + (concat prefix extn)))) + (while (file-exists-p path) + (cl-incf nchars) + (setq prefix (if (< nchars max-chars) + (substring base64-data 0 nchars) + (number-to-string (random max-chars)))) + (setq path (file-name-concat di:attachment-directory dir + (concat prefix extn)))) + ;; Save the file and return its name: + (let ((data (base64-decode-string base64-data)) + (coding-system-for-write 'no-conversion)) + (write-region data nil path) + (file-name-nondirectory path)))) + +(defun di:save-attachments-from (attachment-nodes uid) + "Save attachments in ATTACHMENT-NODES and return a list of attachments. + +If these nodes contain binary data, rather than an URL, save the data to +a file in `diary-icalendar-attachment-directory' (unless this variable +is nil). UID should be the universal ID of the component containing +ATTACHMENT-NODES; the attachments will be saved in a subdirectory of the +same name. The returned list is a list of strings, which are either +URLs or filenames." + (let (entry-attachments) + (dolist (node attachment-nodes) + (ical:with-property node + ((ical:fmttypeparam :value fmttype)) + (when (and (eq 'ical:binary value-type) + di:attachment-directory) + (let ((filename (ical:save-binary-attachment value uid fmttype))) + (push filename entry-attachments))) + (when (eq 'ical:url value-type) + (push value entry-attachments)))) + ;; Return the list of filenames and URLs: + entry-attachments)) + +(defun di:format-list (values &optional title plural-form sep indent) + "Smartly format VALUES for the diary. + +VALUES should be a list of strings. nil elements will be ignored, and an +empty list will return nil. + +TITLE is a string to add to the beginning of the list; a colon will be +appended. PLURAL-FORM is the plural of TITLE, to be used when VALUES +contains more than one element (default: TITLE+\"s\"). + +The strings in VALUES are first joined with SEP (default: \", \"), with +\"TITLE: \" prepended. If the result is longer than the current value of +`fill-column', the values are instead formatted one per line, with the +title on its own line at the beginning, and the whole list indented +relative to the title by INDENT spaces (default: 2). Thus, in the first +case, the result looks like: + TITLE(s): VAL1, VAL2, ... +and in the second: + TITLE(s): + VAL1 + VAL2 + ..." + (when (cdr values) + (setq title (when title (or plural-form (concat title "s"))))) + (unless indent + (setq indent 2)) + ;; Remove nil values and extra whitespace: + (setq values (mapcar #'string-trim (delq nil values))) + (when values + (let ((line (concat + (when title (concat title ": ")) + (string-join values (or sep ", "))))) + (if (< (length line) fill-column) + line + ;; Otherwise, one value per line: + (with-temp-buffer + (insert (string-join values "\n")) + (indent-code-rigidly (point-min) (point-max) indent) + (goto-char (point-min)) + (when title + (insert title ":\n")) + (buffer-string)))))) + +(defun di:format-time (dt &optional tzname) + "Format the `icalendar-date-time' DT for the diary. +The time is formatted according to `diary-icalendar-time-format', which see. +TZNAME, if specified, should be a string naming the time zone observance +in which DT occurs." + ;; Diary does not support seconds, so silently truncate: + (let ((time (format-time-string di:time-format (encode-time dt)))) + (if tzname + (concat time " " tzname) + time))) + +(defun di:format-time-as-local (dt &optional original-tzname) + "Format the time in `icalendar-date-time' DT for the diary. + +DT is translated to the system local time zone if necessary, and the +original time specification is preserved in parentheses if it was given +in a different zone. ORIGINAL-TZNAME, if specified, should be a string +naming the time zone observance in which DT was originally encoded in +the iCalendar data." + (cl-typecase dt + (ical:date "") + (ical:date-time + (let* ((ts (encode-time dt)) + (original-offset (decoded-time-zone dt)) + (local-tz (current-time-zone ts)) + (local-offset (car local-tz)) + (local-dt (decode-time ts local-tz)) + (local-str (di:format-time local-dt))) + (if (and original-tzname original-offset + (not (= original-offset local-offset))) + (format "%s (%s)" local-str (di:format-time dt original-tzname)) + local-str))))) + +(defun di:format-date (dt) + "Format the `icalendar-date' or `icalendar-date-time' DT for the diary. +If DT is a date-time, only the date part is considered. The date is +formatted with `calendar-date-string' according to the pattern in +`diary-date-insertion-form'." + (calendar-dlet ((calendar-date-display-form diary-date-insertion-form)) + (cl-typecase dt + (ical:date (calendar-date-string dt t t)) + (ical:date-time (calendar-date-string (ical:date-time-to-date dt) t t))))) + +(defun di:format-date/time-as-local (dt &optional original-tzname) + "Format the `icalendar-date' or `icalendar-date-time' DT for the diary. + +If DT is a plain date, only the date will be formatted. If DT is a +date-time, both the date and the time will formatted, after translating +DT into a date and time into the system local time. + +If specified, ORIGINAL-TZNAME should be a string naming the time zone +observance in which DT was originally encoded in the iCalendar data. In +this case, the original clock time in DT will also be added in +parentheses, with date if necessary. For example: + 2025/05/01 09:00 (08:00 GMT) +or + 2025/05/01 18:00 (2025/05/02 08:00 JST)" + (let ((local-dt (ical:date/time-to-local dt))) + (cl-typecase local-dt + (ical:date (di:format-date local-dt)) + (ical:date-time + (let ((date (di:format-date local-dt)) + (time (di:format-time local-dt)) + (orig-date (di:format-date dt)) + (orig-time (di:format-time dt original-tzname))) + (if original-tzname + (format "%s %s (%s)" date time + (if (equal date orig-date) + orig-time + (format "%s %s" orig-date orig-time))) + (format "%s %s" date time))))))) + +(defun di:format-time-range (start end &optional omit-start-date) + "Format a time range for the diary. + +START and END should be `icalendar-date-time' values where the date part +is the same. (If they are not on the same date, nil is returned; use +`diary-icalendar-format-time-block-sexp' to make a diary S-exp for this +range instead.) + +The date is only formatted once, and the time is formatted as a range, like: + STARTDATE STARTTIME-ENDTIME +If OMIT-START-DATE is non-nil, STARTDATE will be omitted." + (when (equal (ical:date/time-to-date start) (ical:date/time-to-date end)) + (format "%s%s-%s" + (if omit-start-date "" + (concat (di:format-date start) " ")) + (di:format-time-as-local start) + (di:format-time-as-local end)))) + +(defun di:format-block-sexp (start end) + "Format a `diary-block' diary S-expression between START and END. + +START and END may be `icalendar-date' or `icalendar-date-time' +values. If they are date-times, only the date parts will be considered. +Returns a string like \"%%(diary-block ...)\" with the arguments properly +ordered for the current value of `calendar-date-style'." + (unless (cl-typep start 'ical:date) + (setq start (ical:date-time-to-date start))) + (unless (cl-typep end 'ical:date) + (setq end (ical:date-time-to-date end))) + (concat + diary-sexp-entry-symbol + (apply #'format "(diary-block %d %d %d %d %d %d)" + (cl-case calendar-date-style + ;; M/D/Y + (american (list (calendar-extract-month start) + (calendar-extract-day start) + (calendar-extract-year start) + (calendar-extract-month end) + (calendar-extract-day end) + (calendar-extract-year end))) + ;; D/M/Y + (european (list (calendar-extract-day start) + (calendar-extract-month start) + (calendar-extract-year start) + (calendar-extract-day end) + (calendar-extract-month end) + (calendar-extract-year end))) + ;; Y/M/D + (iso (list (calendar-extract-year start) + (calendar-extract-month start) + (calendar-extract-day start) + (calendar-extract-year end) + (calendar-extract-month end) + (calendar-extract-day end))))))) + +(defun di:format-time-block-sexp (start end) + "Format a `diary-time-block' diary S-expression for times between START and END." + (concat + diary-sexp-entry-symbol + (format "(diary-time-block :start '%s :end '%s)" start end))) + +(defun di:format-rrule-sexp (component) + "Format the recurrence rule data in COMPONENT as a diary S-expression. + +The returned string looks like \"%%(diary-rrule ...)\", and contains the +necessary data from COMPONENT for the calendar to compute recurrences of +the event." + (ical:with-component component + ((ical:dtstart :value dtstart) + (ical:dtend :value dtend) + (ical:duration :value duration) + (ical:rrule :value rrule) + (ical:rdate :all rdate-nodes) + (ical:exdate :all exdate-nodes)) + (unless (or rrule rdate-nodes) + (di:signal-import-error "No recurrence data in component")) + (let ((exdates + (mapcar #'ical:ast-node-value + (apply #'append + (mapcar #'ical:ast-node-value exdate-nodes)))) + (rdates + (mapcar #'ical:ast-node-value + (apply #'append + (mapcar #'ical:ast-node-value rdate-nodes)))) + ;; N.B. we intentionally *don't* add any clock times to the + ;; imported diary entry, since they could conflict with the + ;; times generated by the recurrence rule, e.g. if the rule is + ;; an 'HOURLY rule. Instead we always specify the end time + ;; (if any) via a duration, and take care of displaying the + ;; correct clocks times after computing recurrences during + ;; diary display (see `diary-rrule'). + (dur-value (cond (duration duration) + (dtend (unless (equal dtstart dtend) + (ical:duration-between dtstart dtend))) + (t nil))) + (arg-plist nil)) + + (when exdates + (setq arg-plist (plist-put arg-plist :exclude `(quote ,exdates)))) + (when rdates + (setq arg-plist (plist-put arg-plist :include `(quote ,rdates)))) + (when dtstart + (setq arg-plist (plist-put arg-plist :start `(quote ,dtstart)))) + (when dur-value + (setq arg-plist (plist-put arg-plist :duration `(quote ,dur-value)))) + (when rrule + ;; TODO: make this prettier to look at? + (setq arg-plist (append (list :rule `(quote ,rrule)) arg-plist))) + ;; TODO: timezones?? + + (setq arg-plist (cons 'diary-rrule arg-plist)) + (string-trim ; removing trailing \n added by pp + (concat diary-sexp-entry-symbol + (with-output-to-string (pp arg-plist))))))) + +;; This function puts all of the above together to format individual +;; iCalendar components as diary entries. The final formatting is done +;; by the appropriate skeleton command for the component, or by +;; `di:-format-vevent-legacy' if the legacy format string variables from +;; icalendar.el are set. +(defun di:format-entry (component index &optional non-marking) + "Format an iCalendar component for the diary. + +COMPONENT should be an `icalendar-vevent', `icalendar-vtodo', or +`icalendar-vjournal'. INDEX should be an index into the calendar where +COMPONENT occurs, as returned by `icalendar-parse-and-index'. + +Depending on the type of COMPONENT, the body will be formatted by one of: +`diary-icalendar-vevent-skeleton-command' +`diary-icalendar-vtodo-skeleton-command' +`diary-icalendar-vjournal-skeleton-command' +which see. + +The variable `non-marking' will be bound to the value of NON-MARKING in +the relevant skeleton command. If it is non-nil, the user requested the +entry to be non-marking. + +Returns a string containing the diary entry." + (ical:with-component component + ((ical:attach :all attach-nodes) + (ical:attendee :all attendee-nodes) + (ical:categories :all categories-nodes) + (ical:class :value access) + (ical:comment :all comment-nodes) + (ical:completed :value completed-dt) + (ical:contact :all contact-nodes) + (ical:created :value created-dt) + (ical:description :value description) + ;; in `icalendar-vjournal', multiple `icalendar-description' + ;; nodes are allowed: + (ical:description :all description-nodes) + (ical:dtend :first dtend-node :value dtend) + (ical:dtstamp :value dtstamp) + (ical:dtstart :first dtstart-node :value dtstart) + (ical:duration :value duration) + (ical:due :first due-node :value due-dt) + (ical:geo :value geo) + (ical:last-modified :value last-modified-dt) + (ical:location :value location) + (ical:organizer :first organizer-node ; for skeleton formatting + :value organizer-addr) ; for legacy formatting + (ical:percent-complete :value percent-complete) + (ical:priority :value priority) + (ical:recurrence-id :first recurrence-id-node :value recurrence-id-dt) + (ical:related-to :all related-to-nodes) + (ical:request-status :all request-status-nodes) + (ical:resources :all resources-nodes) + (ical:rrule :value rrule) + (ical:rdate :all rdate-nodes) + (ical:sequence :value revision) + (ical:status :value status) + (ical:summary :value summary) + (ical:transp :value transp) + (ical:uid :value uid) + (ical:url :value url) + (ical:valarm :all alarms)) + (let* ((is-recurring (or rdate-nodes rrule)) + (start-tz (when dtstart-node + (ical:with-property dtstart-node + ((ical:tzidparam :value tzid)) + (when tzid (ical:index-get index :tzid tzid))))) + (start-tzname (when start-tz (icr:tzname-on dtstart start-tz))) + (dtstart-local (ical:date/time-to-local dtstart)) + (due-tz (when due-node + (ical:with-property due-node + ((ical:tzidparam :value tzid)) + (when tzid (ical:index-get index :tzid tzid))))) + (due-tzname (when due-tz (icr:tzname-on due-dt due-tz))) + (dtend + (cond (dtend dtend) + ;; DTEND and DUE never occur in the same component, + ;; so we alias dtend to due: + (due-dt due-dt) + (duration + (ical:date/time-add-duration dtstart duration start-tz)))) + (dtend-local (ical:date/time-to-local dtend)) + (end-tz + (cond (dtend-node + (ical:with-property dtend-node + ((ical:tzidparam :value tzid)) + (when tzid (ical:index-get index :tzid tzid)))) + (due-node due-tz) + (duration start-tz))) + (end-tzname (when end-tz (icr:tzname-on dtend end-tz))) + (component-type (ical:ast-node-type component))) + (calendar-dlet + (;; TODO: interpret alarms? Diary has its own mechanism for + ;; this (but no syntax). We could theoretically use alarms to + ;; set up notifications. For now we just pass them on to + ;; user skeletons, so users can do this if desired. + (alarms alarms) + (attachments + (when attach-nodes + (di:save-attachments-from attach-nodes uid))) + (attendees (mapcar #'di:format-attendee attendee-nodes)) + (categories + (mapcan + (lambda (node) + (mapcar #'ical:text-to-string (ical:ast-node-value node))) + categories-nodes)) + (access (when access (downcase access))) + (comments + (mapcar + (lambda (node) (ical:text-to-string (ical:ast-node-value node))) + comment-nodes)) + (contacts + (mapcar + (lambda (node) (ical:text-to-string (ical:ast-node-value node))) + contact-nodes)) + (completed-dt completed-dt) + (completed + (when completed-dt (di:format-date/time-as-local completed-dt))) + (created-dt created-dt) + (created + (when created-dt (di:format-date/time-as-local created-dt))) + (description (when description (di:-nonempty description))) + (descriptions + (when (eq 'icalendar-vjournal component-type) + (mapcar + (lambda (node) + (di:-nonempty (ical:text-to-string (ical:ast-node-value node)))) + description-nodes))) + (dtstart dtstart) + (start + (when dtstart + (if (bound-and-true-p importing) + (di:format-date/time-as-local dtstart start-tzname) + (di:format-time-as-local dtstart start-tzname)))) + (dtend dtend) + (end + (when dtend + (if (bound-and-true-p importing) + (di:format-date/time-as-local dtend end-tzname) + (di:format-time-as-local dtend end-tzname)))) + (dtstamp dtstamp) + (start-to-end + (with-suppressed-warnings ((lexical date) (free-vars date)) + (cond + ((not dtstart) nil) + ((or (not dtend) (equal dtstart dtend)) + ;; without a distinct DTEND/DUE, same as start: + (if (bound-and-true-p importing) + (di:format-date/time-as-local dtstart start-tzname) + (di:format-time-as-local dtstart start-tzname))) + ((and (bound-and-true-p importing) + (cl-typep dtstart 'ical:date) + (cl-typep dtend 'ical:date)) + ;; Importing two dates: + ;; %%(diary-block ...) + (di:format-block-sexp + dtstart + ;; DTEND is an exclusive bound, while + ;; diary-block needs an inclusive bound, so + ;; subtract a day: + (ical:date-add dtend :day -1))) + ((and (bound-and-true-p importing) + (equal (ical:date/time-to-date dtstart-local) + (ical:date/time-to-date dtend-local))) + ;; Importing, start and end times on same day: + ;; DATE HH:MM-HH:MM + (di:format-time-range dtstart-local dtend-local)) + ((bound-and-true-p importing) + ;; Importing at least one date-time, on different days: + ;; %%(diary-time-block :start ... :end ...) + (di:format-time-block-sexp dtstart-local dtend-local)) + ((and (boundp 'date) ; bound when displaying diary + (cl-typep dtstart-local 'ical:date-time) + (cl-typep dtend-local 'ical:date-time) + (equal date (ical:date-time-to-date dtstart-local)) + (equal date (ical:date-time-to-date dtend-local))) + ;; Displaying, start and end times on the day displayed: + ;; HH:MM-HH:MM + (di:format-time-range dtstart-local dtend-local t)) + ((and (boundp 'date) ; bound when displaying diary + (cl-typep dtstart-local 'ical:date-time) + (cl-typep dtend-local 'ical:date-time)) + ;; Displaying, start and/or end time on other days: + ;; HH:MM-HH:MM for just the times on `date' + (di:format-time-range + (ical:date/time-max dtstart-local + (ical:make-date-time + :year (calendar-extract-year date) + :month (calendar-extract-month date) + :day (calendar-extract-day date) + :hour 0 :minute 0 :second 0 + :zone + (decoded-time-zone dtstart-local))) + (ical:date/time-min dtend-local + (ical:make-date-time + :year (calendar-extract-year date) + :month (calendar-extract-month date) + :day (calendar-extract-day date) + :hour 23 :minute 59 :second 59 + :zone + (decoded-time-zone dtend-local))))) + (t + ;; That's all the cases we care about here. + nil)))) + (duration duration) + (due-dt + (when (eq component-type 'ical:vtodo) + ;; in VTODO, DUE does the job of DTEND, so we alias them; + ;; see above + dtend)) + (due + (when (eq component-type 'ical:vtodo) + (if due-node + (di:format-date/time-as-local due-dt due-tzname) + ;; here we use start-tzname because due/dtend is calculated from + ;; dtstart, not its own node with a tzid: + (di:format-date/time-as-local dtend start-tzname)))) + (work-time-sexp + (when (and dtstart due-dt (bound-and-true-p importing)) + (di:format-time-block-sexp dtstart-local due-dt))) + (coordinates geo) + (geo-location (when geo (di:format-geo-coordinates geo))) + (importing (bound-and-true-p importing)) + (last-modified-dt last-modified-dt) + (last-modified (di:format-date/time-as-local last-modified-dt)) + (location (di:-nonempty location)) + (non-marking non-marking) + (organizer (di:format-attendee organizer-node)) + (percent-complete percent-complete) + (priority priority) + (recurrence-id-dt recurrence-id-dt) + (recurrence-id + (di:format-date/time-as-local recurrence-id-dt)) + (related-tos related-to-nodes) + (request-statuses request-status-nodes) + (resources + (mapcan + (lambda (node) + (mapcar #'ical:text-to-string (ical:ast-node-value node))) + resources-nodes)) + (rrule-sexp + (when (and is-recurring (bound-and-true-p importing)) + (di:format-rrule-sexp component))) + (revision revision) + (status (when status (di:-nonempty (downcase status)))) + (summary (di:-nonempty summary)) + (transparency transp) + (uid (di:-nonempty uid)) + (url (di:-nonempty url))) + (with-temp-buffer + (cl-case (ical:ast-node-type component) + (ical:vevent + (with-suppressed-warnings + ((obsolete ical:import-format + di:-use-legacy-vars-p + di:-vevent-to-legacy-alist + di:-format-vevent-legacy)) + ;; N.B. icalendar.el *only* imported VEVENT components + (if (di:-use-legacy-vars-p) + (if (functionp ical:import-format) + (insert (funcall ical:import-format + (di:-vevent-to-legacy-alist component))) + (di:-format-vevent-legacy (or rrule-sexp start-to-end start) + access description location + organizer-addr + summary status url uid)) + (funcall di:vevent-skeleton-command)))) + (ical:vtodo (funcall di:vtodo-skeleton-command)) + (ical:vjournal (funcall di:vjournal-skeleton-command))) + (buffer-string)))))) + + +;; Import to Diary +;; +;; `di:import-file' and `di:import-buffer' are the main user commands +;; for import. (These replace `icalendar-import-file' and +;; `icalendar-import-buffer' defined by icalendar.el, which are now +;; obsolete aliases to these commands.) `di:import-buffer-to-buffer' is +;; the function underlying these commands; it is the main import +;; function available for external Lisp code. + +;; `di:import-buffer-to-buffer' is the underlying function that formats +;; a complete `icalendar-vcalendar' as diary entries. This function runs +;; `di:post-entry-format-hook' after formatting each component as an +;; entry, and it runs `di:post-calendar-format-hook' after all entries +;; have been formatted. These hooks enable e.g. user review and +;; confirmation of each imported entry and of the whole imported +;; calendar. +(defvar di:post-entry-format-hook nil + "Hook run after formatting a single iCalendar component as a diary entry. + +The functions in this hook are run by `diary-icalendar-import-buffer-to-buffer' +\(which see) after each component it formats. Each function will be +called in a (narrowed) buffer whose contents represent a single diary +entry.") + +(defvar di:post-calendar-format-hook nil + "Hook run after formatting a complete `icalendar-vcalendar' as diary entries. + +The functions in this hook are run by `diary-icalendar-import-buffer-to-buffer' +\(which see) after formatting all the diary entries created from the +calendar. Each function will be called in a buffer containing all the +diary entries.") + +(defun di:sort-by-start-ascending (c1 c2) + "Sort iCalendar component C1 before C2 if C1 starts strictly before C2. +Components with no start date/time are sorted after components that do." + (let ((c1start (ical:with-property-of c1 'ical:dtstart nil value)) + (c2start (ical:with-property-of c2 'ical:dtstart nil value))) + (cond ((and c1start c2start) + (ical:date/time< c1start c2start)) + ;; order anything with a start before anything without: + (c1start t) + (c2start nil) + ;; otherwise they can stay as-is: + (t t)))) + +(defcustom di:import-comparison-function #'di:sort-by-start-ascending + "Comparison function for sorting imported iCalendar components. +See the :lessp argument of `sort' for more information." + :version "31.1" + :type '(radio (function-item di:sort-by-start-ascending) + (function :tag "Other comparison function"))) + +(defun di:import-buffer-to-buffer (&optional all-non-marking) + "Format iCalendar data in current buffer as diary entries. + +This function parses the first iCalendar VCALENDAR in the current buffer +and formats its VEVENT, VJOURNAL, and VTODO components as diary entries. +It returns a new buffer containing those diary entries. The caller +should kill this buffer when it is no longer needed. + +If ALL-NON-MARKING is non-nil, all diary entries will be non-marking. + +The list of components to import can be filtered by binding +`diary-icalendar-import-predicate'. After each component is formatted as +a diary entry, `diary-icalendar-post-entry-format-hook' is run in a (narrowed) +buffer containing that entry. After all components have been formatted, +`diary-icalendar-post-calendar-format-hook' is run in the (widened) buffer +containing all the entries. + +The formatting of imported entries depends on a number of +user-customizable variables, including: `diary-date-forms', +`calendar-date-style', `calendar-date-display-form' and customizations +in the `diary-icalendar' group." + (unless (ical:contains-vcalendar-p (current-buffer)) + (di:signal-import-error (format "No VCALENDAR object in buffer %s" + (buffer-name)))) + (save-excursion + (goto-char (point-min)) + (let (vcalendar index) + (ical:init-error-buffer) + (let ((vcal/idx (ical:parse-and-index (current-buffer)))) + (when vcal/idx + (setq vcalendar (car vcal/idx)) + (setq index (cadr vcal/idx)) + (let* ((import-buf (generate-new-buffer " *diary-import*")) + (to-import + (sort + (seq-filter + (lambda (c) + (and (or (ical:vevent-component-p c) + (ical:vjournal-component-p c) + (ical:vtodo-component-p c)) + (funcall di:import-predicate c))) + (ical:ast-node-children vcalendar)) + :lessp di:import-comparison-function + :in-place t)) + ;; prevent point from being reset from window-point + ;; when narrowed buffer is displayed for confirmation: + (window-point-insertion-type t) + ;; position at start of each entry: + entry-start) + + (with-current-buffer import-buf + (calendar-dlet ((importing t)) ; inform skeletons we're importing + (dolist (component to-import) + (setq entry-start (point)) + (insert (di:format-entry component index all-non-marking)) + (with-restriction entry-start (point) + (save-excursion + (run-hooks 'di:post-entry-format-hook))) + (unless (bolp) (insert "\n")))) + (save-excursion + (run-hooks 'di:post-calendar-format-hook)) + import-buf))))))) + +;; Internal variables needed by `di:-entry-import'. They are dynamically +;; bound in `di:import-buffer'. +(defvar di:-no-queries nil) +(defvar di:-entry-count nil) + +(defun di:-entry-import () + ;; Adds the formatted entry in the current restriction to the diary, + ;; after getting confirmation from the user. + ;; Used via `di:post-entry-format-hook' in `di:import-buffer', below. + (unless di:-no-queries + (display-buffer (current-buffer))) + (when (or di:-no-queries + (let ((help-form + "Type y to add this entry to the diary, n to skip to next.")) + (di:y-or-n-or-edit-p "Add this entry to the diary?"))) + (ical:condition-case err + (let* ((uid (save-excursion + (goto-char (point-min)) + (when (re-search-forward di:uid-regexp nil t) + (match-string 1)))) + (other-entry (di:find-entry-with-uid uid)) + (entry (buffer-string))) + (if (and other-entry + (not di:-no-queries) + (y-or-n-p "Replace existing entry with same UID?")) + (with-current-buffer (marker-buffer (car other-entry)) + (replace-region-contents + (car other-entry) (cadr other-entry) entry)) + ;; Otherwise, diary-make-entry inserts the new entry at the end + ;; of the main diary file: + (diary-make-entry + entry + nil ; skeleton has already interpreted non-marking + nil ; use dynamic value of `diary-file' + t ; skeleton responsible for final spaces + t)) ; no need to show diary file while importing + (when other-entry + (set-marker (car other-entry) nil) + (set-marker (cadr other-entry) nil)) + (cl-incf di:-entry-count))))) + +;;;###autoload +(defun di:import-buffer (&optional diary-filename quietly all-non-marking) + "Import iCalendar events from current buffer into diary. + +This function parses the first iCalendar VCALENDAR in the current buffer +and imports VEVENT, VJOURNAL, and VTODO components to the diary file +DIARY-FILENAME (default: `diary-file'). + +For each entry, you are asked whether to add it to the diary unless +QUIETLY is non-nil. After all entries are imported, you are also asked +if you want to save the diary file unless QUIETLY is non-nil. When +called interactively, you are asked if you want to confirm each entry +individually; answer No to make QUIETLY non-nil. + +ALL-NON-MARKING determines whether all diary events are created as +non-marking entries. When called interactively, you are asked whether +you want to make all entries non-marking. + +The formatting of imported entries in the diary depends on a number of +user-customizable variables. Before running this command for the first +time, you may especially wish to check the values of: +`diary-file' +`diary-date-forms' +`diary-date-insertion-form' +`calendar-date-style' +`calendar-date-display-form' +as well as variables in the customization group `diary-icalendar-import'." + (interactive + (list (read-file-name "Diary file: " + (when diary-file (file-name-directory diary-file)) + (cons diary-file diary-included-files)) + (or di:always-import-quietly + (not (y-or-n-p "Confirm entries individually?"))) + (y-or-n-p "Make all entries non-marking?"))) + + (let* ((diary-file diary-filename) ; dynamically bound for `di:-entry-import', + (di:-entry-count 0) ; see above + (di:-no-queries quietly) ; + (di:post-entry-format-hook + (append di:post-entry-format-hook (list #'di:-entry-import))) + (diary-buffer (or (find-buffer-visiting diary-filename) + (find-file-noselect diary-filename))) + import-buffer) + (unwind-protect + (setq import-buffer (di:import-buffer-to-buffer all-non-marking)) + (when (bufferp import-buffer) + (kill-buffer import-buffer))) + (display-buffer diary-buffer) + (when (or quietly + (y-or-n-p (format "%d entries imported. Save diary file?" + di:-entry-count))) + (with-current-buffer diary-buffer + (goto-char (point-max)) + (save-buffer))))) + +;;;###autoload +(defun di:import-file (filename &optional diary-filename quietly non-marking) + "Import iCalendar diary entries from FILENAME into DIARY-FILENAME. + +This function parses the first iCalendar VCALENDAR in FILENAME and +imports VEVENT, VJOURNAL, and VTODO components to the diary +DIARY-FILENAME (default: `diary-file'). + +For each entry, you are asked whether to add it to the diary unless +QUIETLY is non-nil. After all entries are imported, you are also asked +if you want to save the diary file unless QUIETLY is non-nil. When +called interactively, you are asked if you want to confirm each entry +individually; answer No to make QUIETLY non-nil. + +NON-MARKING determines whether all diary events are created as +non-marking entries. When called interactively, you are asked whether +you want to make all entries non-marking. + +The formatting of imported entries in the diary depends on a number of +user-customizable variables. Before running this command for the first +time, you may especially wish to check the values of: +`diary-file' +`diary-date-forms' +`diary-date-insertion-form' +`calendar-date-style' +`calendar-date-display-form' +as well as variables in the customization group `diary-icalendar-import'." + (interactive + (list (read-file-name "iCalendar file: " nil nil 'confirm) + (read-file-name "Diary file: " + (when diary-file (file-name-directory diary-file)) + (cons diary-file diary-included-files)) + (or di:always-import-quietly + (not (y-or-n-p "Confirm entries individually?"))) + (y-or-n-p "Make all entries non-marking?"))) + (let ((parse-buf (ical:find-unfolded-buffer-visiting filename))) + (unless parse-buf + (ical:condition-case err + (setq parse-buf + (ical:unfolded-buffer-from-file (expand-file-name filename))))) + ;; Hand off to `di:import-buffer' for the actual import: + (if parse-buf + (with-current-buffer parse-buf + (di:import-buffer diary-filename quietly non-marking)) + ;; If we get here, we weren't able to open the file for parsing: + (warn "Unable to open file %s; see %s" + filename (buffer-name (ical:error-buffer)))))) + +;; Some simple support for viewing iCalendar data in MIME message +;; parts. Mail readers may want to build their own viewer using the +;; import functions above, but this is a good starting point: +(defun di:mailcap-viewer () + "View iCalendar data in the current message part as diary entries. + +This function is a suitable viewer for text/calendar parts in MIME +messages, such as email attachments. To use this function as a viewer, +customize the variable `mailcap-user-mime-data' and add an entry +containing this function for the MIME type \"text/calendar\". + +To extend the behavior of this function, see +`diary-icalendar-after-mailcap-viewer-hook'." + (let ((entries-buf (diary-icalendar-import-buffer-to-buffer))) + (unwind-protect + (progn + ;; Since this is already a temporary viewer buffer, we replace + ;; its contents with the imported entries, so we can (a) keep + ;; the window configuration setup by the calling mailcap code + ;; and (b) already kill the import buffer here. + (erase-buffer) + (insert-buffer-substring entries-buf) + (diary-mode) + (run-hooks di:after-mailcap-viewer-hook)) + (kill-buffer entries-buf)))) + + +;; Export + +;;; Error handling +(define-error 'ical:diary-export-error "Unable to export diary data" 'ical:error) + +(cl-defun di:signal-export-error (msg &key (diary-buffer (current-buffer)) + (position (point)) + line + (severity 2)) + (let ((err-data + (list :message msg + :buffer diary-buffer + :position position + :line line + :severity severity))) + (signal 'ical:diary-export-error err-data))) + +;;; Export utility functions +(defun di:parse-attendees-and-organizer () + "Parse `icalendar-attendee' and `icalendar-organizer' nodes from entry. + +Searches the entry in the current restriction for addresses matching +`diary-icalendar-address-regexp'. If an address is found on a +line that also matches `diary-icalendar-organizer-regexp', it will be +parsed as an `icalendar-organizer' node, or otherwise as an +`icalendar-attendee'. Returns the list of nodes for all addresses found." + (goto-char (point-min)) + (let (attendees organizer) + (while (re-search-forward di:address-regexp nil t) + (let ((addr (match-string 1)) + (cn (match-string 2))) + (unless (string-match ":" addr) ; URI scheme already present + (setq addr (concat "mailto:" addr))) + (when cn + (setq cn (di:-nonempty cn))) + (if (string-match di:organizer-regexp + (buffer-substring (line-beginning-position) + (line-end-position))) + (setq organizer + (ical:make-property ical:organizer addr (ical:cnparam cn))) + (push (ical:make-property ical:attendee addr (ical:cnparam cn)) + attendees)))) + (if organizer + (cons organizer attendees) + attendees))) + +(defun di:parse-location () + "Parse `icalendar-location' node from entry. + +Searches the entry in the current restriction for a location matching +`diary-icalendar-location-regexp'. If a location is found, it will be +parsed as an `icalendar-location' node. Returns a list containing just +this node, or nil." + (goto-char (point-min)) + (when (and di:location-regexp + (re-search-forward di:location-regexp nil t)) + (ical:make-property ical:location (di:-nonempty (match-string 1))))) + +(defun di:parse-class () + "Parse `icalendar-class' node from entry. + +Searches the entry in the current restriction for an access +classification matching `diary-icalendar-class-regexp'. If a +classification is found, it will be parsed as an `icalendar-class' +node. Return this node, or nil." + (goto-char (point-min)) + (when (and di:class-regexp + (re-search-forward di:class-regexp nil t)) + (ical:make-property ical:class + (upcase (string-trim (match-string 1)))))) + +(defun di:parse-status () + "Parse `icalendar-status' node from entry. + +Searches the entry in the current restriction for a status matching +`diary-icalendar-status-regexp'. If a status is found, it will be parsed +as an `icalendar-status' node. Return this node, or nil." + (goto-char (point-min)) + (when (and di:status-regexp + (re-search-forward di:status-regexp nil t)) + (ical:make-property ical:status + (upcase (string-trim (match-string 1)))))) + +(defun di:parse-url () + "Parse `icalendar-url' node from entry. + +Searches the entry in the current restriction for an URL matching +`diary-icalendar-url-regexp'. If an URL is found, it will be parsed as an +`icalendar-url' node. Return this node, or nil." + (goto-char (point-min)) + (when (and di:url-regexp + (re-search-forward di:url-regexp nil t)) + (ical:make-property ical:url (di:-nonempty (match-string 1))))) + +(defun di:parse-uid () + "Parse `icalendar-uid' node from entry. + +Searches the entry in the current restriction for a UID matching +`diary-icalendar-uid-regexp'. If a UID is found, it will be parsed as an +`icalendar-uid' node. Return this node, or nil." + (goto-char (point-min)) + (when (and di:uid-regexp + (re-search-forward di:uid-regexp nil t)) + (ical:make-property ical:uid (di:-nonempty (match-string 1))))) + +(defun di:parse-summary-and-description () + "Parse summary and description nodes from current restriction. + +When `diary-icalendar-summary-regexp' or +`diary-icalendar-description-regexp' are non-nil, and the entry matches +them, the matches will be used to generate the summary and description. + +Otherwise, the first line of the entry (after any nonmarking symbol and +date and time specification) is used as the summary. The description is +the full body of the entry, excluding the nonmarking symbol, date and +time, but including the summary. + +Returns a list containing an `icalendar-summary' node and +`icalendar-description' node, or nil." + (goto-char (point-min)) + (let (summary description) + (when (and di:summary-regexp + (re-search-forward di:summary-regexp nil t)) + (setq summary (match-string 1))) + (goto-char (point-min)) + (when (and di:description-regexp + (re-search-forward di:description-regexp nil t)) + (setq description (match-string 1))) + ;; Fall back to using first line and entire entry: + (goto-char (point-min)) + (while (looking-at-p "[[:space:]]") + (forward-char)) + (unless summary + (setq summary (buffer-substring (point) (line-end-position)))) + (unless description + (setq description (buffer-substring (point) (point-max)))) + ;; Remove any indentation on subsequent lines from description: + (setq description (replace-regexp-in-string "^[[:space:]]+" "" description)) + + (list (ical:make-property ical:summary summary) + (ical:make-property ical:description description)))) + +(defun di:parse-entry-type () + "Return the type symbol for the component type used to export an entry. + +Default is `icalendar-vevent'. If the entry is nonmarking and +`diary-icalendar-export-nonmarking-as-vjournal' is non-nil, +`icalendar-vjournal' is returned. If `diary-icalendar-todo-regexp' is +non-nil and the entry matches it, `icalendar-vtodo' is returned. + +If the entry is nonmarking and `diary-icalendar-export-nonmarking-entries' +is nil, nil is returned, indicating that the entry should not be +exported." + (let (type) + (goto-char (point-min)) + (unless (and (looking-at-p diary-nonmarking-symbol) + (not di:export-nonmarking-entries)) + (setq type 'ical:vevent) + (when (and (looking-at-p diary-nonmarking-symbol) + di:export-nonmarking-as-vjournal) + (setq type 'ical:vjournal)) + (when (and di:todo-regexp (re-search-forward di:todo-regexp nil t)) + (setq type 'ical:vtodo))) + type)) + +(defun di:parse-transparency (type) + "Return the iCalendar time transparency of an entry. + +TYPE should be the type symbol for the component to be exported, as +returned by `diary-icalendar-parse-entry-type'. If the entry is +non-marking (i.e., begins with `diary-nonmarking-symbol'), and it is to +be exported as an `icalendar-vevent' (according to TYPE), then this +function returns a list containing the appropriate `icalendar-transp' +property node to mark the event as transparent, and moves the current +restriction past the non-marking symbol. Otherwise it returns nil." + (save-excursion + (goto-char (point-min)) + (when (and (eq type 'ical:vevent) + (re-search-forward (concat "^" diary-nonmarking-symbol) + (line-end-position) t)) + (narrow-to-region (point) (point-max)) + (list + (ical:make-property ical:transp "TRANSPARENT"))))) + +;; TODO: move to diary-lib? +(defun di:parse-date-form () + "Parse a date matching `diary-date-forms' on the current line. + +If a date is found, moves the current restriction past the end of the +date and returns a list (MONTH DAY YEAR), where each value is an integer +or t if the date is generic in that unit. Otherwise returns nil." + (goto-char (point-min)) + (catch 'date + (let (date-regexp backup) + (dolist (date-sexp diary-date-forms) + (when (eq 'backup (car date-sexp)) + (setq date-sexp (cdr date-sexp)) + (setq backup t)) + (setq date-regexp (di:date-form-to-regexp date-sexp)) + (when backup (beginning-of-line)) + (when (let ((case-fold-search t)) + (re-search-forward date-regexp nil t)) + (let ((year + (let ((match (match-string 1))) + (if (or (null match) (equal match "*")) + t + (if (and diary-abbreviated-year-flag (length= match 2)) + ;; from diary-lib.el: + ;; 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. + (let* ((current-y + (calendar-extract-year (calendar-current-date))) + (y (+ (string-to-number match) + ;; Current century, eg 2000. + (* 100 (/ current-y 100)))) + (offset (- y current-y))) + (cond ((> offset 50) + (- y 100)) + ((< offset -50) + (+ y 100)) + (t y))) + (string-to-number match))))) + (month + (let ((month-num (match-string 2)) + (month-name (match-string 4))) + (cond ((or (equal month-name "*") (equal month-num "*")) t) + (month-num (string-to-number month-num)) + (month-name + (alist-get + (capitalize month-name) + (calendar-make-alist + calendar-month-name-array + 1 nil + calendar-month-abbrev-array + (mapcar (lambda (e) (format "%s." e)) + calendar-month-abbrev-array)) + nil nil #'equal))))) + (day + (let ((day-num (match-string 3)) + (day-name (match-string 5))) + (cond + ;; We don't care about the day name here, unless it + ;; is "*", since it won't help us identify a day of + ;; the month. Weekly entries under a weekday name + ;; are parsed by `di:parse-weekday-name', below. + ((or (equal day-name "*") (equal day-num "*")) t) + (day-num (string-to-number day-num)))))) + (when (and year month day) + (narrow-to-region (match-end 0) (point-max)) + (throw 'date (list month day year))))))))) + +(defun di:date-form-to-regexp (date-sexp) + "Convert DATE-SEXP to a regular expression. + +DATE-SEXP should be an S-expression in the variables `year', `month', +`day', `monthname', and `dayname', as found e.g. in `diary-date-forms'. +The returned regular expression matches dates of this form, including +generic dates specified with \"*\", and abbreviated and long-form month +and day names (based on `calendar-month-name-array' and +`calendar-month-abbrev-array', and similarly for day names). The match +groups contain the following data: + +Group 1: the 2-4 digit year, or a literal * +Group 2: the 1-2 digit month number, or a literal * +Group 3: the 1-2 digit day number, or a literal * +Group 4: the (long-form or abbreviated) month name, or a literal * +Group 5: the (long-form or abbreviated) day name, or a literal *" + (when (eq 'backup (car date-sexp)) + (setq date-sexp (cdr date-sexp))) + (let ((month-names-regexp + (rx + (group-n 4 + (or (regexp (diary-name-pattern calendar-month-name-array + calendar-month-abbrev-array)) + "*")))) + (day-names-regexp + (rx + (group-n 5 + (or (regexp (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) + "*")))) + date-regexp) + (calendar-dlet + ((prefix (rx line-start + (zero-or-one (regexp diary-nonmarking-symbol)))) + (year (rx (group-n 1 (or (** 2 4 digit) "*")))) + (month (rx (group-n 2 (or (** 1 2 digit) "*")))) + (day (rx (group-n 3 (or (** 1 2 digit) "*")))) + (monthname month-names-regexp) + (dayname day-names-regexp)) + (setq date-regexp (apply #'concat (cons prefix (mapcar #'eval date-sexp))))) + date-regexp)) + +(defun di:parse-weekday-name () + "Parse a weekday name on the current line. + +The day name must appear in `calendar-day-name-array' or +`calendar-day-abbrev-array'. If a day name is found, move the current +restriction past it, and return a day number between 0 (=Sunday) and +6 (=Saturday). Otherwise, return nil." + (goto-char (point-min)) + (let ((day-names-regexp + (rx line-start + (zero-or-one (regexp diary-nonmarking-symbol)) + (group-n 1 + (regexp (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)))))) + (when (re-search-forward day-names-regexp (line-end-position) t) + (let ((day-name (capitalize (match-string 1)))) + (narrow-to-region (match-end 0) (point-max)) + (alist-get + day-name + (calendar-make-alist calendar-day-name-array 0 nil + calendar-day-abbrev-array + (mapcar (lambda (e) (format "%s." e)) + calendar-day-abbrev-array)) + nil nil #'equal))))) + +(defun di:weekday-to-recurrence (weekday) + "Convert WEEKDAY to a WEEKLY iCalendar recurrence rule. + +WEEKDAY must be an integer between 0 (=Sunday) and 6 (=Saturday). +Returns a list (START RRULE), with START being an `icalendar-dtstart' +property and RRULE an `icalendar-rrule'." + (let ((dtstart (calendar-nth-named-day 1 weekday 1 di:recurring-start-year)) + (rrule `((FREQ WEEKLY) + (BYDAY (,weekday))))) + (list (ical:make-property ical:dtstart dtstart) + (ical:make-property ical:rrule rrule)))) + +;; TODO: give this value to diary-time-regexp? +(defconst di:time-regexp + (rx-let ((hours (or (seq (any "0-2") (any "0-9")) + (any "0-9"))) + (minutes (seq (any "0-5") (any "0-9"))) + (am/pm (seq (any "ap") "m"))) ;; am, pm + (rx + (group-n 1 ;; START + (group-n 11 hours) ;; start hour + (or + ;; 10:00 or 10h00: + (seq (or ":" "h") (group-n 12 minutes) (opt (group-n 13 am/pm))) + ;; 10.00h or 10.00am: (a bare "10.00" should not match) + (seq "." (group-n 12 minutes) (or (group-n 13 am/pm) "h")) + ;; 10am + (group-n 13 am/pm) + ;; 10h + "h")) + (zero-or-one + (one-or-more "-") + (group-n 2 ;; END + (group-n 21 hours) ;; end hour + (or + ;; 10:00 or 10h00: + (seq (or ":" "h") (group-n 22 minutes) (opt (group-n 23 am/pm))) + ;; 10.00h or 10.00am: + (seq "." (group-n 22 minutes) (or "h" (group-n 23 am/pm))) + ;; 10am + (group-n 23 am/pm) + ;; 10h + "h"))) + (one-or-more space))) + "Regular expression to match diary appointment times. + +Accepted time formats look like e.g.: + 9AM 9:00 09:00 9h 9h00 9.00am 9.00h + 9PM 9:00pm 21:00 21h00 21.00pm 21.00h + 9AM-1PM 09:00-13:00 + +Group 1 matches the start time: + Group 11 matches the hours digits + Group 12 matches the minutes digits + Group 13 matches an AM/PM specification + +Group 2 matches the end time: + Group 21 matches the hours digits + Group 22 matches the minutes digits + Group 23 matches an AM/PM specification") + +(defun di:parse-time () + "Parse diary time string in the current restriction. + +If a time specification is found, move the current restriction past it, +and return a list (START END), where START and END are decoded-time +values containing the hours and minutes slots parsed from the time +specification. END may be nil if no end time was specified." + (goto-char (point-min)) + (let ((regexp di:time-regexp) + (case-fold-search t)) + (when di:export-linewise + ;; In this case, only look for a time following whitespace, + ;; at the beginning of a continuation line of the full entry: + (setq regexp (concat "^[[:space:]]+" di:time-regexp))) + + (when (re-search-forward regexp (line-end-position) t) + (let* ((start-hh (string-to-number (match-string 11))) + (start-am/pm (when (match-string 13) + (upcase (match-string 13)))) + (start-hours (if (and (equal start-am/pm "PM") (< start-hh 12)) + (+ 12 start-hh) + start-hh)) + (start-minutes (string-to-number (or (match-string 12) "0"))) + (start + (when (and start-hours start-minutes) + (make-decoded-time :hour start-hours + :minute start-minutes + :second 0))) + (end-hh (when (match-string 21) + (string-to-number (match-string 21)))) + (end-am/pm (when (match-string 23) + (upcase (match-string 23)))) + (end-hours (if (and end-hh (equal end-am/pm "PM") (< end-hh 12)) + (+ 12 end-hh) + end-hh)) + (end-minutes (when end-hours + (string-to-number (or (match-string 22) "0")))) + (end (when (and end-hours end-minutes) + (make-decoded-time :hour end-hours + :minute end-minutes + :second 0)))) + (narrow-to-region (match-end 0) (point-max)) + ;; Return the times: + (list start end))))) + +(defun di:convert-time-via-strategy (dt &optional vtimezone) + "Reinterpret the local time DT per the time zone export strategy. + +The export strategy is determined by +`diary-icalendar-time-zone-export-strategy', which see. + +DT may be an `icalendar-date' or `icalendar-date-time'. If it is a +date, it is returned unmodified. If it is a date-time, depending on the +strategy and any existing zone information in DT, it will be converted +to a correct local, UTC, or floating time. VTIMEZONE should be the +`icalendar-vtimezone' which defines the local time zone, if the time +zone export strategy requires it." + (cl-typecase dt + (ical:date dt) + (ical:date-time + (cond + ((or (eq 'local di:time-zone-export-strategy) + (listp di:time-zone-export-strategy)) + (unless (ical:vtimezone-component-p vtimezone) + (di:signal-export-error + (format + "%s time export strategy requires a time zone definition;\n%s" + (if (eq 'local di:time-zone-export-strategy) "`local'" "list-based") + (concat + "check the value of `diary-icalendar-time-zone-export-strategy'\n" + "and the output of `calendar-current-time-zone'")))) + (if (decoded-time-zone dt) + (icr:tz-decode-time (encode-time dt) vtimezone) + (icr:tz-set-zone dt vtimezone :error))) + ((eq 'to-utc di:time-zone-export-strategy) + (decode-time (encode-time dt) t)) + ((eq 'floating di:time-zone-export-strategy) + (setf (decoded-time-zone dt) nil) + dt))))) + +(defun di:parse-sexp () + "Parse a diary S-expression at the beginning of the current restriction. + +The S-expression must appear at the start of line, immediately after +`diary-sexp-entry-symbol'. If an S-expression is found, move the +current restriction past it, and return the S-expression. Otherwise, +return nil." + (goto-char (point-min)) + (let ((regexp (rx line-start + (regexp diary-sexp-entry-symbol)))) + (when (re-search-forward regexp (line-end-position) t) + (let ((sexp (read (current-buffer)))) + (narrow-to-region (point) (point-max)) + sexp)))) + +(defun di:anniversary-sexp-to-recurrence (sexp) + "Convert `diary-anniversary' SEXP to `icalendar-dtstart' and `icalendar-rrule'. +Returns a pair of nodes (START RRULE)." + (let* ((d1 (nth 1 sexp)) + (d2 (nth 2 sexp)) + (d3 (nth 3 sexp)) + (dtstart (diary-make-date d1 d2 (or d3 di:recurring-start-year))) + (rrule '((FREQ YEARLY)))) + (list + (ical:make-property ical:dtstart dtstart (ical:valuetypeparam 'ical:date)) + (ical:make-property ical:rrule rrule)))) + +(defun di:block-sexp-to-recurrence (sexp) + "Convert `diary-block' SEXP to `icalendar-dtstart' and `icalendar-rrule' nodes. +Returns a pair of nodes (START RRULE)." + (let* ((dtstart (diary-make-date (nth 1 sexp) (nth 2 sexp) (nth 3 sexp))) + (end (diary-make-date (nth 4 sexp) (nth 5 sexp) (nth 6 sexp))) + (rrule `((FREQ DAILY) + (UNTIL ,end)))) + (list (ical:make-property ical:dtstart dtstart + (ical:valuetypeparam 'ical:date)) + (ical:make-property ical:rrule rrule)))) + +(defun di:time-block-sexp-to-start-end (sexp &optional vtimezone) + "Convert `diary-time-block' SEXP to `icalendar-dtstart' and `icalendar-dtend'. +Returns a pair of nodes (START END). + +VTIMEZONE, if specified, should be an `icalendar-vtimezone'. Times in +SEXP will be reinterpreted as local to VTIMEZONE, as UTC, or as floating +times according to `diary-icalendar-time-zone-export-strategy'." + (let* ((start (plist-get sexp :start)) + (dtstart (di:convert-time-via-strategy start vtimezone)) + (end (plist-get sexp :end)) + (dtend (di:convert-time-via-strategy end vtimezone)) + (tzid (ical:with-property-of vtimezone 'ical:tzid))) + (list (ical:make-property ical:dtstart dtstart (ical:tzidparam tzid)) + (ical:make-property ical:dtend dtend (ical:tzidparam tzid))))) + +(defun di:cyclic-sexp-to-recurrence (sexp) + "Convert `diary-cyclic' SEXP to `icalendar-dtstart' and `icalendar-rrule'. +Returns a pair of nodes (START RRULE)." + (let* ((ndays (nth 1 sexp)) + (dtstart (diary-make-date (nth 2 sexp) (nth 3 sexp) (nth 4 sexp))) + (rrule `((FREQ DAILY) + (INTERVAL ,ndays)))) + (list + (ical:make-property ical:dtstart dtstart (ical:valuetypeparam 'ical:date)) + (ical:make-property ical:rrule rrule)))) + +(defun di:float-sexp-to-recurrence (sexp) + "Convert `diary-float' SEXP to `icalendar-dtstart' and `icalendar-rrule'. +Returns a pair of nodes (START RRULE)." + (let* ((month-exp (nth 1 sexp)) + (months (cond ((eq month-exp t) nil) ; don't add a BYMONTH clause + ((integerp month-exp) (list month-exp)) + ((and (listp month-exp) (eq 'quote (car month-exp))) + (eval month-exp nil)) ; unquote a literal list of ints + (t month-exp))) + (_ (unless (seq-every-p #'integerp months) + (di:signal-export-error + (format "Malformed month(s) in `diary-float' S-expression:\n%s" + sexp)))) + (dow (nth 2 sexp)) + (n (nth 3 sexp)) + (day (or (nth 4 sexp) + (if (< 0 n) 1 + 'last))) ; = "last day of the month" for any month + ;; Calculate the offset within the month from day, n: + (offset + (cond ((eq day 'last) n) + ((and (< 0 day) (< 0 n)) + ;; In this case, to get the offset relative to + ;; the start of the month, we need to add to n + ;; the number of weeks in the month before day: + ;; e.g. if day = 8, n = 2, then we are looking + ;; for the second DOW after the 8th of the + ;; month, which is the 3rd DOW after the 1st of + ;; the month + (+ n (/ (1- day) 7))) + ((and (< 0 day) (< n 0) (< day (* 7 (abs n)))) + ;; In this case, we need to cross into the + ;; previous month and adjust the offset + ;; accordingly to reflect the correct number of + ;; weeks before the end of the month. + ;; e.g. if day = 15, n = -3, we're looking for the + ;; 3rd DOW before the 15th of the month, + ;; which is the 1st DOW "before" the end of the + ;; previous month (where "before" is inclusive, + ;; e.g offset = -1 will work when DOW is the last + ;; day of the month) + (when months + (setq months + (sort + :in-place t + (mapcar + (lambda (m) (if (eql m 1) 12 (1- m))) + months)))) + (+ n (/ (1- day) 7))))) + (rrule (delq nil + `((FREQ MONTHLY) + ,(when months + (list 'BYMONTH months)) + (BYDAY ((,dow . ,offset)))))) + (dtstart + (calendar-nth-named-day n dow + (if months (apply #'min months) 1) + di:recurring-start-year + (unless (eq day 'last) day)))) + + ;; if at this point we have an offset which could put us outside the + ;; month boundaries, warn the user that this may not be supported: + (when (< 4 (abs offset)) + (ical:warn + (format + "`diary-float' with large N=%d may not be supported on other systems" n))) + + (list (ical:make-property ical:dtstart dtstart + (ical:valuetypeparam 'ical:date)) + (ical:make-property ical:rrule rrule)))) + +(defun di:offset-sexp-to-nodes (sexp) + "Convert a `diary-offset' SEXP to a list of property nodes. + +SEXP must have the form (diary-offset INNER-SEXP NDAYS). The conversion +is only possible for relatively simple cases of INNER-SEXP. The +INNER-SEXP is first converted to a list of property nodes (see +`diary-icalendar-export-sexp'), and then any date, time, period, and +recurrence rule values in these nodes are adjusted NDAYS forward." + (let* ((arg1 (nth 1 sexp)) + (inner-sexp (if (eq (car arg1) 'quote) + (eval arg1 nil) ; unquote a quoted inner sexp + arg1)) + (nodes (di:sexp-to-nodes inner-sexp)) + (ndays (nth 2 sexp))) + (dolist (node nodes) + (ical:with-property node nil + (cl-case (ical:ast-node-type node) + ((ical:dtstart ical:dtend) + (ical:ast-node-set-value + value-node + (ical:date/time-add value :day ndays))) + (ical:exdate + (dolist (val-node value-nodes) + (ical:with-node-value val-node nil + (ical:ast-node-set-value + val-node + (ical:date/time-add value :day ndays))))) + (ical:rdate + (dolist (val-node value-nodes) + (ical:ast-node-set-value + val-node + (ical:with-node-value val-node nil + (cl-typecase value + (ical:period + (ical:make-period + (ical:date/time-add (ical:period-start value) :day ndays) + :end (when (ical:period--defined-end value) + (ical:date/time-add + (ical:period--defined-end value) :day ndays)) + :duration (ical:period-dur-value value))) + (t (ical:date/time-add value :day ndays))))))) + (ical:rrule + (let ((mdays (ical:recur-by* 'BYMONTHDAY value)) + (ydays (ical:recur-by* 'BYYEARDAY value)) + (dows (ical:recur-by* 'BYDAY value)) + (bad-clause + (cond ((ical:recur-by* 'BYSETPOS value) 'BYSETPOS) + ((ical:recur-by* 'BYWEEKNO value) 'BYWEEKNO)))) + ;; We can't reliably subtract days in the following cases, so bail: + (when (< 28 ndays) + (di:signal-export-error + (format "Cannot export `diary-offset' with large offset %d" ndays))) + (when bad-clause + (di:signal-export-error + (format "Cannot export `diary-offset': inner SEXP %s contains %s" + sexp bad-clause))) + (when (seq-some (lambda (md) + (or (and (< 0 md) (< 28 (+ md ndays))) + (and (< md 0) (< 0 (+ md ndays))))) + mdays) + (di:signal-export-error + (format "Cannot export `diary-offset': inner SEXP %s contains %s" + inner-sexp + "BYMONTHDAY clause that could cross month bounds"))) + (when (seq-some (lambda (yd) + (or (and (< 0 yd) (< 365 (+ yd ndays))) + (and (< yd 0) (< 0 (+ yd ndays))))) + ydays) + (di:signal-export-error + (format "Cannot export `diary-offset': inner SEXP %s contains %s" + inner-sexp + "BYYEARDAY clause that could cross year bounds"))) + ;; Adjust the rule's clauses to account for the offset: + (when mdays + (setf (alist-get 'BYMONTHDAY value) + (list + (mapcar (apply-partially #'+ ndays) mdays)))) + (when ydays + (setf (alist-get 'BYYEARDAY value) + (list + (mapcar (apply-partially #'+ ndays) ydays)))) + (when dows + (setf (alist-get 'BYDAY value) + (list + (mapcar + (lambda (dow) + (if (integerp dow) + (mod (+ dow ndays) 7) + (let* ((wkday (car dow)) + (shifted (+ wkday ndays)) + (new-wkday (mod shifted 7)) + (new-offs + (cond + ;; if shifted is not between 0 and 7, + ;; we moved into another week, so we need + ;; to modify the offset within the month/year + ;; by the number of weeks moved: + ((< 7 shifted) + (+ (/ shifted 7) (cdr dow))) + ((< shifted 0) + (+ -1 (/ shifted 7) (cdr dow))) + ;; otherwise it stays the same: + (t (cdr dow))))) + (cons new-wkday new-offs)))) + dows))))))))) + ;; Return the modified nodes: + nodes)) + +;; Converts a legacy value of `icalendar-export-alarms' to new format of +;; `diary-icalendar-export-alarms': +(defun di:-convert-legacy-alarm-options (alarm-options) + (declare (obsolete nil "31.1")) + (let ((lead-time (car alarm-options)) + (by-types (cadr alarm-options))) + (mapcar + (lambda (l) + (cl-case (car l) + (audio `(audio ,lead-time)) + (display `(display ,lead-time "%s")) + (email `(email ,lead-time "%s" ,(cadr l))))) + by-types))) + +(defun di:add-valarms (component &optional vtimezone) + "Add VALARMs to COMPONENT according to `diary-icalendar-export-alarms'. + +COMPONENT should be an `icalendar-vevent' or `icalendar-vtodo'. The +generated VALARM components will be added to this node's children. +VTIMEZONE should define the local timezone; it is required when +formatting alarms as mail messages. Returns the modified COMPONENT." + (let* ((alarm-options + (if (and (bound-and-true-p icalendar-export-alarms) + (null di:export-alarms)) + ;; For backward compatibility with icalendar.el: + (with-suppressed-warnings + ((obsolete ical:export-alarms + di:-convert-legacy-alarm-options)) + (di:-convert-legacy-alarm-options ical:export-alarms)) + di:export-alarms)) + valarms) + (dolist (opts alarm-options) + (let* ((type (nth 0 opts)) + (minutes (nth 1 opts))) + (cl-case type + (audio + (push (ical:make-valarm + (ical:action "AUDIO") + (ical:trigger (make-decoded-time :minute (* -1 minutes)))) + valarms)) + (display + (ical:with-component component + ((ical:summary :value summary) + (ical:description :value description)) + (let* ((displayed-summary + (replace-regexp-in-string + "%t" (number-to-string minutes) + (replace-regexp-in-string + "%s" summary + (nth 2 opts))))) + (push (ical:make-valarm + (ical:action "DISPLAY") + (ical:trigger (make-decoded-time :minute (* -1 minutes))) + (ical:summary displayed-summary) + (ical:description description)) + valarms)))) + (email + (ical:with-component component + ((ical:summary :value summary) + (ical:attendee :all entry-attendees)) + (let* ((subject + (replace-regexp-in-string + "%t" (number-to-string minutes) + (replace-regexp-in-string + "%s" summary + (nth 2 opts)))) + (index (ical:index-insert-tz (ical:make-index) vtimezone)) + (body + (calendar-dlet ((as-alarm 'email)) + (di:format-entry component index))) + (addresses (nth 3 opts)) + all-attendees) + (dolist (address addresses) + (cond + ((eq address 'from-entry) + (setq all-attendees (append entry-attendees all-attendees))) + ((stringp address) + (push (ical:make-property ical:attendee + (concat "mailto:" address)) + all-attendees)))) + (push (ical:make-valarm + (ical:action "EMAIL") + (ical:trigger (make-decoded-time :minute (* -1 minutes))) + (ical:summary subject) + (ical:description body) + (@ all-attendees)) + valarms))))))) + (apply #'ical:ast-node-adopt-children component valarms) + component)) + +(defun di:rrule-sexp-to-recurrence (sexp &optional vtimezone) + "Convert a `diary-rrule' SEXP to iCalendar recurrence rule properties. +Returns a list containing at least `icalendar-dtstart' and +`icalendar-rrule' nodes, and zero or more `icalendar-rdate', +`icalendar-exdate', and `icalendar-duration' nodes. + +VTIMEZONE, if specified, should be an `icalendar-vtimezone'. Times in +SEXP will be reinterpreted as local to VTIMEZONE, as UTC, or as floating +times according to `diary-icalendar-time-zone-export-strategy'." + (let* ((args (cdr sexp)) + (start (plist-get args :start)) + (dtstart (di:convert-time-via-strategy + (if (eq 'quote (car start)) (eval start nil) start) + vtimezone)) + (rule (plist-get args :rule)) + (rrule (if (eq 'quote (car rule)) (eval rule nil) rule)) + (included (plist-get args :include)) + (rdates (mapcar + (lambda (dt) (di:convert-time-via-strategy dt vtimezone)) + (if (eq 'quote (car included)) (eval included nil) included))) + (excluded (plist-get args :exclude)) + (exdates (mapcar + (lambda (dt) (di:convert-time-via-strategy dt vtimezone)) + (if (eq 'quote (car excluded)) (eval excluded nil) excluded))) + (duration (eval (plist-get args :duration))) + (dur-value + (if (eq 'quote (car duration)) (eval duration nil) duration)) + (tzid + (when (cl-typep dtstart 'ical:date-time) + (ical:with-property-of vtimezone 'ical:tzid))) + nodes) + (push (ical:make-property ical:rrule rrule) nodes) + (push (ical:make-property ical:dtstart dtstart (ical:tzidparam tzid)) + nodes) + (when rdates + (push (ical:make-property ical:rdate rdates (ical:tzidparam tzid)) + nodes)) + (when exdates + (push (ical:make-property ical:exdate exdates (ical:tzidparam tzid)) + nodes)) + (when duration + (push (ical:make-property ical:duration dur-value) nodes)) + nodes)) + +(defun di:dates-to-recurrence (months days years) + "Convert values representing one or more dates to iCalendar recurrences. + +MONTHS, DAYS, and YEARS should either be integers, lists of integers, or +the symbol t. + +Returns a pair of nodes (START R), where START is an `icalendar-dtstart' +node and R is an `icalendar-rrule' node or `icalendar-rdate' node (or +nil, if MONTHS, DAYS and YEARS are all integers)." + (if (and (integerp months) (integerp days) (integerp years)) + ;; just a regular date, without recurrence data: + (list + (ical:make-property ical:dtstart (list months days years)) + nil) + + (when (integerp months) (setq months (list months))) + (when (integerp days) (setq days (list days))) + (when (integerp years) (setq years (list years))) + (let (dtstart freq bymonth bymonthday rdates rdate-type) + (cond ((and (eq days t) (eq months t) (eq years t)) + (setq freq 'DAILY + dtstart (list 1 1 di:recurring-start-year))) + ((and (eq months t) (eq years t)) + (setq freq 'MONTHLY + bymonthday days + dtstart (list 1 (car days) di:recurring-start-year))) + ((and (eq years t) (eq days t)) + (setq freq 'DAILY + bymonth months + dtstart (list (apply #'min months) + 1 + di:recurring-start-year))) + ((eq years t) + (setq freq 'YEARLY + bymonth months + bymonthday days + dtstart + (list (apply #'min months) + (apply #'min days) + di:recurring-start-year))) + ;; The remaining cases are not representable as RRULEs, + ;; because there is no BYYEAR clause. So we generate an RDATE + ;; covering each specified date. + ((and (eq months t) (eq days t)) + ;; In this case we represent each of the specified years as a period: + (setq rdate-type 'ical:period + rdates + (mapcar + (lambda (y) + (ical:make-period + (ical:make-date-time :year y :month 1 :day 1 + :hour 0 :minute 0 :second 0) + :end + (ical:make-date-time :year (1+ y) :month 1 :day 1 + :hour 0 :minute 0 :second 0))) + years) + dtstart (ical:date-time-to-date + (ical:period-start (car rdates))))) + (t + ;; Otherwise, represent each date individually: + (setq rdate-type 'ical:date + rdates + (mapcan + (lambda (y) + (mapcan + (lambda (m) + (mapcar + (lambda (d) (list m d y)) + (if (listp days) days + ;; days = t: + (number-sequence 1 (calendar-last-day-of-month m y))))) + (if (listp months) months + ;; months = t: + (number-sequence 1 12)))) + years) + ;; ensure dtstart is the earliest recurrence: + dtstart (apply #'ical:date/time-min rdates) + rdates (seq-remove (apply-partially #'equal dtstart) rdates)))) + + ;; Return the pair of nodes (DTSTART RRULE) or (DTSTART RDATE): + (let* ((recur-value + (delq nil + `((FREQ ,freq) + ,(when bymonth (list 'BYMONTH bymonth)) + ,(when bymonthday (list 'BYMONTHDAY bymonthday))))) + (rrule-node (when freq (ical:make-property ical:rrule recur-value))) + (rdate-node (when rdates + (ical:make-property ical:rdate rdates + (ical:valuetypeparam rdate-type)))) + (dtstart-node (ical:make-property ical:dtstart dtstart))) + (list dtstart-node (or rrule-node rdate-node)))))) + +(defun di:date-sexp-to-recurrence (sexp) + "Convert a `diary-date' SEXP to an `icalendar-rrule' or `icalendar-rdate' node. +Returns a pair of nodes (START R), where START is an `icalendar-dtstart' +node and R is the RRULE or RDATE node." + (let* ((d1 (nth 1 sexp)) + (d2 (nth 2 sexp)) + (d3 (nth 3 sexp)) + years months days) + (cl-case calendar-date-style + (iso (setq years (if (integerp d1) (list d1) d1) + months (if (integerp d2) (list d2) d2) + days (if (integerp d3) (list d3) d3))) + (american (setq months (if (integerp d1) (list d1) d1) + days (if (integerp d2) (list d2) d2) + years (if (integerp d3) (list d3) d3))) + (european (setq days (if (integerp d1) (list d1) d1) + months (if (integerp d2) (list d2) d2) + years (if (integerp d3) (list d3) d3)))) + + ;; unquote lists of integers read as quoted lists: + (when (and (listp months) (eq 'quote (car months))) + (setq months (eval months nil))) + (when (and (listp days) (eq 'quote (car days))) + (setq days (eval days nil))) + (when (and (listp years) (eq 'quote (car years))) + (setq years (eval years nil))) + + ;; if at this point we don't have lists of integers or "t", user + ;; entered a malformed diary-date sexp: + (unless (or (eq months t) (seq-every-p #'integerp months)) + (di:signal-export-error + (format "Malformed months in `diary-date' S-expression:\n%s" sexp))) + (unless (or (eq days t) (seq-every-p #'integerp days)) + (di:signal-export-error + (format "Malformed days in `diary-date' S-expression:\n%s" sexp))) + (unless (or (eq years t) (seq-every-p #'integerp years)) + (di:signal-export-error + (format "Malformed years in `diary-date' S-expression:\n%s" sexp))) + + (di:dates-to-recurrence months days years))) + +(defun di:other-sexp-to-recurrence (sexp) + "Convert diary SEXP to `icalendar-rdate' by enumerating its recurrences. + +The enumeration starts on the current date and includes recurrences in +the next `diary-icalendar-export-sexp-enumeration-days' days. Returns a +list (START COMMENT RDATE), where START is an `icalendar-dtstart', +COMMENT is an `icalendar-comment' containing SEXP, and RDATE is an +`icalendar-rdate' containing the enumerated recurrences. If there are +no recurrences, (START COMMENT EXDATE) is returned, where START is the +current date, and EXDATE is an `icalendar-exdate' excluding that start +date as a recurrence. (This is because `icalendar-dtstart' is a required +property and must be present even if the recurrence set is empty.)" + (let* ((today (calendar-absolute-from-gregorian (calendar-current-date))) + (end (+ today (1- di:export-sexp-enumeration-days))) + dtstart rdates exdates) + (dolist (absdate (number-sequence today end)) + (calendar-dlet ((date (calendar-gregorian-from-absolute absdate))) + (when (eval sexp) + (push date rdates)))) + (if rdates + (progn + (setq rdates (nreverse rdates)) + (setq dtstart (car rdates) + rdates (cdr rdates))) + (ical:warn + (format "No recurrences in the next %d days: %s" + di:export-sexp-enumeration-days + sexp) + :severity 0) + ;; When there are no recurrences, we still need a DTSTART, but we + ;; can exclude it via an EXDATE: + (setq dtstart (calendar-current-date) + exdates (list dtstart))) + + (append + (list + (ical:make-property ical:dtstart dtstart + (ical:valuetypeparam 'ical:date)) + ;; TODO: should we maybe use an X-name property for this? + (ical:make-property ical:comment (format "%s" sexp))) + (if rdates + (list + (ical:make-property ical:rdate rdates + (ical:valuetypeparam 'ical:date))) + (list + (ical:make-property ical:exdate exdates + (ical:valuetypeparam 'ical:date))))))) + +(defun di:sexp-to-nodes (sexp &optional vtimezone) + "Convert a diary S-expression SEXP to a list of iCalendar property nodes. + +The fully supported S-expressions are: +`diary-anniversary' +`diary-block' +`diary-cyclic' +`diary-date' +`diary-float' +`diary-remind' +`diary-rrule' +`diary-time-block' + +There is partial support for `diary-offset' S-expressions; see +`diary-icalendar-offset-to-nodes'. + +Other S-expressions are only supported via enumeration. Their +recurrences are enumerated for +`diary-icalendar-export-sexp-enumeration-days' starting from the current +date; see `diary-icalendar-other-sexp-to-recurrence'. If +`diary-icalendar-export-sexp-enumerate-all' is non-nil, all +S-expressions are enumerated rather than converted to recurrence rules. + +VTIMEZONE, if specified, should be an `icalendar-vtimezone'. Times in +SEXP will be reinterpreted as local to VTIMEZONE, as UTC, or as floating +times according to `diary-icalendar-time-zone-export-strategy'." + (if di:export-sexp-enumerate-all ;; see Bug#7911 for motivation + (di:other-sexp-to-recurrence sexp) + (cl-case (car sexp) + (diary-anniversary (di:anniversary-sexp-to-recurrence sexp)) + (diary-block (di:block-sexp-to-recurrence sexp)) + (diary-cyclic (di:cyclic-sexp-to-recurrence sexp)) + (diary-date (di:date-sexp-to-recurrence sexp)) + (diary-float (di:float-sexp-to-recurrence sexp)) + (diary-offset (di:offset-sexp-to-nodes sexp)) + (diary-rrule (di:rrule-sexp-to-recurrence sexp vtimezone)) + (diary-time-block (di:time-block-sexp-to-start-end sexp vtimezone)) + ;; For `diary-remind' we only handle the inner sexp: + (diary-remind (di:sexp-to-nodes (nth 1 sexp) vtimezone)) + (t (di:other-sexp-to-recurrence sexp))))) + +;;; Time zone handling during export: + +(defconst di:-tz-warning + "This time zone information was inferred from incomplete system information; it should be correct for the date-times within this calendar file referencing this zone, but you should not rely on it more widely.") + +(defconst di:-emacs-local-tzid + "Emacs_Local_") + +(defun di:current-tz-to-vtimezone (&optional tz tzid start-year) + "Convert TZ to an `icalendar-vtimezone'. + +TZ defaults to the output of `calendar-current-time-zone'; if specified, +it should be a list of the same form as that function returns. + +TZID, if specified, should be a string to identify this time zone; it +defaults to `diary-icalendar--emacs-local-tzid' plus the name of the +standard observance according to `calendar-current-time-zone'. + +START-YEAR, if specified, should be an integer giving the year in which +to start the observances in the time zone. It defaults to 1970." + (when (and tz (not (di:-tz-info-sexp-p nil tz))) + (di:signal-export-error + (format "Invalid time zone data: %s.\n%s." tz + "Check the value of `diary-icalendar-time-zone-export-strategy'"))) + (let* ((tzdata (or tz (calendar-current-time-zone))) + (std-offset (* 60 (nth 0 tzdata))) + (dst-offset (+ std-offset + (* 60 (nth 1 tzdata)))) + (std-name (nth 2 tzdata)) + (dst-name (nth 3 tzdata)) + (dst-starts (nth 4 tzdata)) + (dst-ends (nth 5 tzdata)) + (dst-start-minutes (nth 6 tzdata)) + (dst-end-minutes (nth 7 tzdata))) + + (unless (and std-offset + (or (equal std-name dst-name) + (and dst-starts dst-ends dst-start-minutes dst-end-minutes))) + (di:signal-export-error + "Insufficient time zone information to create VTIMEZONE")) + + (if (equal std-name dst-name) + ;; Local time zone doesn't use DST: + (ical:make-vtimezone + (ical:tzid (or tzid (concat di:-emacs-local-tzid std-name))) + (ical:make-standard + (ical:tzname std-name) + (ical:dtstart (ical:make-date-time :year (or start-year 1970) + :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (ical:tzoffsetfrom std-offset) + (ical:tzoffsetto std-offset) + (ical:comment di:-tz-warning))) + + ;; Otherwise we can provide both STANDARD and DAYLIGHT subcomponents: + (let* ((std->dst-rule + (if (eq (car dst-starts) 'calendar-nth-named-day) + `((FREQ YEARLY) + (BYMONTH (,(nth 3 dst-starts))) + (BYDAY (,(cons (nth 2 dst-starts) + (nth 1 dst-starts))))) + ;; The only other rules that `calendar-current-time-zone' + ;; can return are based on the Persian calendar, which we + ;; cannot express in an `icalendar-recur' value, at least + ;; pending an implementation of RFC 7529 + (di:signal-export-error + (format "Unable to export DST rule for current time zone: %s" + dst-starts)))) + (dst-start-date (calendar-dlet ((year (or start-year 1970))) + (eval dst-starts))) + (dst-start + (ical:date-to-date-time dst-start-date + :hour (/ dst-start-minutes 60) + :minute (mod dst-start-minutes 60) + :second 0)) + (dst->std-rule + (if (eq (car dst-ends) 'calendar-nth-named-day) + `((FREQ YEARLY) + (BYMONTH (,(nth 3 dst-ends))) + (BYDAY (,(cons (nth 2 dst-ends) + (nth 1 dst-ends))))) + (di:signal-export-error + (format "Unable to export DST rule for current time zone: %s" + dst-ends)))) + (std-start-date (calendar-dlet ((year (1- (or start-year 1970)))) + (eval dst-ends))) + (std-start + (ical:date-to-date-time std-start-date + :hour (/ dst-end-minutes 60) + :minute (mod dst-end-minutes 60) + :second 0))) + + (ical:make-vtimezone + (ical:tzid (or tzid (concat di:-emacs-local-tzid std-name))) + (ical:make-standard + (ical:tzname std-name) + (ical:dtstart std-start) + (ical:rrule dst->std-rule) + (ical:tzoffsetfrom dst-offset) + (ical:tzoffsetto std-offset) + (ical:comment di:-tz-warning)) + (ical:make-daylight + (ical:tzname dst-name) + (ical:dtstart dst-start) + (ical:rrule std->dst-rule) + (ical:tzoffsetfrom std-offset) + (ical:tzoffsetto dst-offset) + (ical:comment di:-tz-warning))))))) + +;;; Parsing complete diary entries: + +(defun di:parse-entry-linewise (begin end vtimezone type date-nodes) + "Convert the entry between BEGIN and END linewise to iCalendar components. + +\"Linewise\" means each line of a diary entry will be exported as a +distinct event; see `diary-icalendar-export-linewise'. +Returns a list of component nodes representing the events. + +VTIMEZONE must be the `icalendar-vtimezone' in which times in the entry +appear (or nil). TYPE and DATE-NODES must contain the iCalendar component +type and date information parsed from the beginning of the entry which +apply to all of the events. These arguments are passed on in recursive +calls to `diary-icalendar-parse-entry'." + (save-restriction + (narrow-to-region begin end) + (goto-char (point-min)) + (let ((subentry-regexp + ;; match to the end of lines which have indentation equal to + ;; or greater than the current one: + (rx line-start + (group-n 1 (+ space)) + (* not-newline) + (* "\n" (backref 1) (+ space) (* not-newline)))) + components) + + (while (re-search-forward subentry-regexp end t) + (let ((next-pos (1+ (match-end 0)))) + (setq components + (append + (di:parse-entry (match-beginning 0) (match-end 0) + vtimezone type date-nodes) + components)) + (goto-char next-pos))) + components))) + +(defun di:parse-entry (begin end &optional vtimezone type date-nodes) + "Convert the entry between BEGIN and END to a list of iCalendar components. + +The region between BEGIN and END will be parsed for a date, time, +summary, description, attendees, and UID. This information will be +combined into an `icalendar-vevent' (or `icalendar-vjournal' or +`icalendar-vtodo', depending on the values of +`diary-icalendar-export-nonmarking-entries', +`diary-icalendar-export-nonmarking-as-vjournal' and +`diary-icalendar-todo-regexp') and that component will be returned +wrapped in a list. Returns nil if the entry should not be exported +according to `diary-icalendar-export-nonmarking-entries'. + +If `diary-icalendar-export-linewise' is non-nil, then a top-level call +to this function will return a list of several such components. (Thus, +the function always returns a list of components.) + +VTIMEZONE, if specified, should be the `icalendar-vtimezone' in which +times in the entry appear. If +`diary-icalendar-time-zone-export-strategy' is not either \\='to-utc or +\\='floating, VTIMEZONE must be provided. + +DATE-NODES and TYPE should be nil in a top-level call; they are used in +recursive calls to this function made by +`diary-icalendar-parse-entry-linewise'." + (save-restriction + (narrow-to-region begin end) + (goto-char (point-min)) + (let (sexp dateform weekday tzid transparency all-props should-recurse) + (setq should-recurse (and di:export-linewise (not date-nodes) (not type))) + (when (ical:vtimezone-component-p vtimezone) + (setq tzid (ical:with-property-of vtimezone 'ical:tzid))) + (unless date-nodes + ;; If we don't already have date information, we are in a + ;; top-level call and need to collect the date and type + ;; information from the start of the entry: + (setq type (di:parse-entry-type)) + ;; N.B. the following four parsing functions successively + ;; narrow the current restriction past anything they parse: + (setq transparency (di:parse-transparency type)) + (setq sexp (di:parse-sexp)) + (setq dateform (di:parse-date-form)) + (setq weekday (di:parse-weekday-name)) + (setq date-nodes + (append + transparency + (when sexp (di:sexp-to-nodes sexp vtimezone)) + (when dateform + (apply #'di:dates-to-recurrence dateform)) + (when (and weekday (not dateform)) + (di:weekday-to-recurrence weekday))))) + + (when type ; nil means entry should not be exported + (if should-recurse + ;; If we are in a top level call and should export linewise, + ;; do that recursively now: + (di:parse-entry-linewise (point) end vtimezone type date-nodes) + + ;; Otherwise, we are either in a recursive call with a + ;; narrower restriction, or don't need to export linewise. In + ;; both cases, we gather the remaining data from the current + ;; restriction and combine everything into a component node: + (let* ((times (di:parse-time)) + (start-time (when times (car times))) + (end-time (when times (cadr times)))) + ;; Combine clock time values in the current restriction with + ;; date information parsed at the top level. Doing this here + ;; allows us to combine a different time on each line of an + ;; entry exported linewise with the date information for the + ;; whole entry: + (dolist (node date-nodes) + (ical:with-property node nil + (cond + ((and (ical:dtstart-property-p node) + (eq 'ical:date value-type) + start-time) + (let ((dtstart + (di:convert-time-via-strategy + (ical:date-time-variant + start-time + :year (calendar-extract-year value) + :month (calendar-extract-month value) + :day (calendar-extract-day value)) + vtimezone))) + (push (ical:make-property ical:dtstart dtstart + (ical:tzidparam tzid)) + all-props) + (when end-time + ;; an end time parsed from a time specification + ;; in the entry is always on the same day as + ;; DTSTART. + (let* ((dtend + (di:convert-time-via-strategy + (ical:date-time-variant + end-time + :year (calendar-extract-year value) + :month (calendar-extract-month value) + :day (calendar-extract-day value)) + vtimezone)) + (is-recurring + (seq-find + (lambda (n) (or (ical:rrule-property-p n) + (ical:rdate-property-p n))) + date-nodes))) + (if is-recurring + ;; If the entry is recurring, we interpret + ;; the end time as giving us a duration for all + ;; recurrences: + (progn + (when (seq-find #'ical:duration-property-p + date-nodes) + (ical:warn + (concat "Parsed both duration and end time; " + "ignoring end time specification") + :buffer (current-buffer) + :position (point))) + (push (ical:make-property ical:duration + (ical:duration-between dtstart dtend)) + all-props)) + ;; Otherwise we make a normal DTEND: + (push (ical:make-property ical:dtend dtend) + all-props)))))) + + ((and (ical:rdate-property-p node) + start-time + (seq-every-p (apply-partially #'eq 'ical:date) + value-types)) + (let ((rdates + (mapcar + (lambda (dt) + (if end-time + (ical:make-period + (di:convert-time-via-strategy + (ical:date-time-variant + start-time + :year (calendar-extract-year dt) + :month (calendar-extract-month dt) + :day (calendar-extract-day dt)) + vtimezone) + :end + (di:convert-time-via-strategy + (ical:date-time-variant + end-time + :year (calendar-extract-year dt) + :month (calendar-extract-month dt) + :day (calendar-extract-day dt)) + vtimezone)) + (di:convert-time-via-strategy + (ical:date-time-variant + start-time + :year (calendar-extract-year dt) + :month (calendar-extract-month dt) + :day (calendar-extract-day dt)) + vtimezone))) + values))) + (push (ical:make-property ical:rdate rdates + (ical:tzidparam tzid)) + all-props))) + + ;; preserve any other node read from date, e.g. RRULE, as is: + (node (push node all-props)))))) + + ;; In a VTODO, entry date must become the DUE date; either + ;; DTEND becomes DUE, or if there is no DTEND, then DTSTART: + (when (eq type 'ical:vtodo) + (unless (catch 'found-dtend + (dolist (node all-props) + (when (ical:dtend-property-p node) + (ical:ast-node-set-type node 'ical:due) + (throw 'found-dtend t)))) + (dolist (node all-props) + (when (ical:dtstart-property-p node) + (ical:ast-node-set-type node 'ical:due))))) + + ;; Collect the remaining properties: + (setq all-props (append (di:parse-summary-and-description) all-props)) + (setq all-props (append (di:parse-attendees-and-organizer) all-props)) + (push (ical:make-property ical:dtstamp (decode-time nil t)) all-props) + (let ((class (di:parse-class)) + (location (di:parse-location)) + (status (di:parse-status)) + (url (di:parse-url))) + (when class (push class all-props)) + (when location (push location all-props)) + (when status (push status all-props)) + (when url (push url all-props))) + (push (or (di:parse-uid) + (ical:make-property ical:uid + (ical:make-uid all-props))) + all-props) + + ;; Allow users to add to the properties parsed: + (when (functionp di:other-properties-parser) + (calendar-dlet + ((type type) + (properties all-props)) + (let ((others (funcall di:other-properties-parser))) + (dolist (p others) + (condition-case nil + (push (ical:ast-node-valid-p p) + all-props) + (ical:validation-error + (ical:warn + (format "`%s' returned invalid `%s' property; ignoring" + di:other-properties-parser + (ical:ast-node-type p)) + :buffer (current-buffer) + :position (point)))))))) + + ;; Construct, validate and return a component of the appropriate type: + (let ((component + (ical:ast-node-valid-p + (ical:make-ast-node type nil all-props)))) + + ;; Add alarms per `diary-icalendar-export-alarms', except for + ;; in VJOURNAL, where alarms are not allowed: + ;; TODO: should we also add alarms for `diary-remind' sexps? + (when (not (eq type 'ical:vjournal)) + (di:add-valarms component vtimezone)) + + ;; Return the component wrapped in a list (for type consistency): + (list component))))))) + +;;;###autoload +(defun di:export-region (begin end filename &optional erase) + "Export diary entries between BEGIN and END to iCalendar format in FILENAME. + +If FILENAME exists and is not empty, this function asks whether to erase +its contents first. If ERASE is non-nil, the contents of FILENAME will +always be erased without asking. Otherwise the exported data will be +appended to the end of FILENAME. + +The export depends on a number of user-customizable variables. Before +running this command for the first time, you may especially wish to +check the values of: +`diary-file' +`diary-date-forms' +`calendar-date-style' +as well as variables in the customization group `diary-icalendar-export'." + (interactive (list (region-beginning) + (region-end) + (expand-file-name + (read-file-name "iCalendar file: ")))) + + (ical:init-error-buffer) + (let (output-buffer local-tz components vcalendar) + (when (and (null erase) + (file-exists-p filename) + (< 0 (file-attribute-size (file-attributes filename))) + (y-or-n-p (format "Delete existing contents of %s?" filename))) + (setq erase t)) + (ical:condition-case err + (setq output-buffer (find-file-noselect filename))) + (when output-buffer + (save-excursion + (save-restriction + (narrow-to-region begin end) + (goto-char (point-min)) + (cond ((eq 'local di:time-zone-export-strategy) + (setq local-tz (di:current-tz-to-vtimezone))) + ((listp di:time-zone-export-strategy) + (setq local-tz (di:current-tz-to-vtimezone + di:time-zone-export-strategy)))) + (while (re-search-forward di:entry-regexp nil t) + (let ((entry-start (match-beginning 0)) + (entry-end (match-end 0)) + (first-line (match-string 1))) + (ical:condition-case err-data + (setq components + (append (di:parse-entry entry-start entry-end local-tz) + components)) + (ical:export-error + (ical:warn + (concat + (format "Unable to export entry \"%s...\"; skipping" first-line) + "\nError was:\n" + (plist-get err-data :message)) + :position entry-start + :buffer (current-buffer)))) + (goto-char (1+ entry-end)))) + (setq components (nreverse components)) + (when local-tz (push local-tz components)) + (ical:condition-case err-data + (setq vcalendar (ical:make-vcalendar (@ components)))) + + (when vcalendar + (with-current-buffer output-buffer + (when erase (erase-buffer)) + (goto-char (point-max)) ; append, if user chose not to erase + (unless (bolp) (insert "\n")) + (ical:condition-case err-data + (insert (ical:print-calendar-node vcalendar))) + (let ((coding-system-for-write 'utf-8-dos)) + (save-buffer)))))))) + + (message + (if (ical:errors-p) + (format "iCalendar export completed with errors; see buffer %s" + (buffer-name (ical:error-buffer))) + "iCalendar export completed successfully."))) + +;;;###autoload +(defun di:export-file (diary-filename filename &optional erase) + "Export DIARY-FILENAME to iCalendar format in FILENAME. + +The diary entries in DIARY-FILENAME will be exported to iCalendar format +and the resulting calendar will be saved to FILENAME. + +If FILENAME exists and is not empty, this function asks whether to erase +its contents first. If ERASE is non-nil, the contents of FILENAME will +always be erased without asking. Otherwise the exported data will be +appended to the end of FILENAME. + +The export depends on a number of user-customizable variables. Before +running this command for the first time, you may especially wish to +check the values of: +`diary-file' +`diary-date-forms' +`calendar-date-style' +as well as variables in the customization group `diary-icalendar-export'." + (interactive (list + (read-file-name "Diary file: " + (when diary-file (file-name-directory diary-file)) + (cons diary-file diary-included-files) + 'confirm) + (read-file-name "iCalendar file: " + (when diary-file (file-name-directory diary-file)) + (when diary-file + (concat + (file-name-sans-extension diary-file) + ".ics"))))) + (when (and (null erase) + (file-exists-p filename) + (< 0 (file-attribute-size (file-attributes filename))) + (y-or-n-p (format "Delete existing contents of %s?" filename))) + (setq erase t)) + (with-current-buffer (find-file-noselect diary-filename) + (di:export-region (point-min) (point-max) filename erase))) + + +;; Display in Diary + +;;; Functions implementing diary-icalendar sexps. +;;; TODO: move these to diary-lib.el? + +;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. +(cl-defun diary-time-block (&key start end) + "Diary S-expression for time blocks. + +Entry applies if the queried date occurs between START and END, +inclusive. START and END may be `icalendar-date' or +`icalendar-date-time' values." + (with-no-warnings (defvar date) (defvar entry)) + (when (and (ical:date/time<= start date) (ical:date/time<= date end)) + entry)) + +;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. +(cl-defun diary-rrule (&key rule start duration include exclude) + "Diary S-expression for iCalendar recurrence rules. + +Entry applies if the queried date matches the recurrence rule. + +The keyword arguments RULE, START, INCLUDE and EXCLUDE should contain +the recurrence data from an iCalendar component. RULE should be an +`icalendar-recur' value, START an `icalendar-date' or +`icalendar-date-time', DURATION an `icalendar-dur-value', and INCLUDE +and EXCLUDE should be lists of `icalendar-date' or `icalendar-date-time' +values (of the same type as START)." + ;; TODO: also support a format that is nicer to read and type by hand. + ;; e.g. just letting a rule be specified in a recur-value string like + ;; :rule "FREQ=MONTHLY;BYDAY=1SU" + ;; is perhaps already better than the raw Lisp format. We could at least + ;; support specifying the clauses with keywords, e.g. + ;; :freq :monthly :byday '("Sunday" . 1) + ;; would be better than the current + ;; :rule '((FREQ MONTHLY) (BYDAY ((0 . 1)))) + (with-no-warnings (defvar date) (defvar entry)) + (when (ical:date<= start date) + (let* ((vevent (ical:make-vevent + (ical:rrule rule) + (ical:dtstart start) + (ical:rdate include) + (ical:exdate exclude))) + (interval (icr:find-interval date start rule))) + (cl-typecase start + (ical:date + (when (member date (icr:recurrences-in-interval interval vevent)) + entry)) + (ical:date-time + ;; TODO. If start is a date-time, it was probably imported from + ;; an iCalendar file, but in order to calculate recurrences, we + ;; really need all the time zone information from that file, + ;; not just the rule, start, include and exclude. But encoding + ;; all that tz info in a diary s-exp is cumbersome and ugly and + ;; probably not worth the trouble. Since this is the diary, we + ;; assume that all we really care about here is whether there + ;; are recurrences on a particular day. Thus we convert + ;; HOURLY/MINUTELY/SECONDLY rules to a DAILY rule, and all + ;; values to plain dates. This keeps things simple (and + ;; hopefully quicker) but means that information gets lost. I + ;; hope this can be changed to do things right at some point, + ;; but that will require first adding more robust time zone + ;; support to the diary somehow -- perhaps via #included + ;; iCalendar files? + (let* ((date-rule (copy-sequence rule)) + (start-date (ical:date-time-to-date start)) + (include-dates (mapcar #'ical:date-time-to-date include)) + (exclude-dates (mapcar #'ical:date-time-to-date exclude)) + ;; Preserve the clock times in the entry: + (entry-time + (if duration + (di:format-time-range + start + (ical:date/time-add-duration start duration)) + (di:format-time-as-local start))) + (date-entry (concat entry-time " " entry))) + (when (memq (ical:recur-freq date-rule) '(HOURLY MINUTELY SECONDLY)) + (setf (alist-get 'FREQ date-rule) 'DAILY) + (setf (alist-get 'INTERVAL date-rule) 1) + (setf (alist-get 'BYHOUR date-rule nil t) nil) + (setf (alist-get 'BYMINUTE date-rule nil t) nil) + (setf (alist-get 'BYSECOND date-rule nil t) nil)) + ;; Recurse with the plain date values: + (calendar-dlet + ((date date) + (entry date-entry)) + (diary-rrule :rule date-rule :start start-date + :include include-dates :exclude exclude-dates)))))))) + +(defun di:display-entries () + "Display iCalendar data from a file in the diary. + +This function allows you to display the data in an iCalendar-formatted +file in the diary without importing it. The data is read directly from +the currently value of `diary-file'. If this file contains iCalendar +data, any events, tasks, and journal entries in the file which occur on +`original-date' and `number' of days after are formatted for display in +the diary. (All three of these variables are dynamically bound by the +diary when this function is called.) + +To use this function, add an '#include \"FILE\"' entry in your diary +file for each iCalendar file you want to display (see +`diary-include-string'). Then add `diary-include-other-diary-files' to +`diary-list-entries-hook'. (Consider also adding `diary-sort-entries' at +the end of this hook if you want entries to be displayed in order.) +Finally, add this function to `diary-nongregorian-listing-hook', so that +it is called once for each included file when the diary is displayed." + (with-no-warnings (defvar original-date) ; the start date + (defvar number) ; number of days to generate entries for + (defvar diary-file)) ; dyn. bound to included file name + (let ((diary-buffer (or (find-buffer-visiting diary-file) + (find-file-noselect diary-file)))) + (when (ical:contains-vcalendar-p diary-buffer) + (let ((vcal/idx (ical:parse-and-index diary-file))) + (when vcal/idx + (let* ((index (cadr vcal/idx)) + (absstart (calendar-absolute-from-gregorian original-date)) + (absend (+ absstart (1- number)))) + + (dolist (absdate (number-sequence absstart absend)) + (let* ((date (calendar-gregorian-from-absolute absdate)) + (to-format (ical:index-get index :date date))) + (dolist (component to-format) + ;; Format the entry, with a pointer back to its location + ;; in the parsed buffer: + (let ((marker (make-marker))) + (set-marker marker + (ical:ast-node-meta-get :begin component) + (ical:ast-node-meta-get :buffer component)) + (diary-add-to-list + date + (di:format-entry component index) + "" + marker))))))))))) + +(defun di:marking-dates-of (component index) + "Return the dates in COMPONENT that should be marked in the calendar. + +INDEX should be a parse tree index containing the time zone definition +relevant to COMPONENT; see `icalendar-parse-and-index'. The dates to +mark are derived from COMPONENT's start and end date and time, and any +recurrences it has within the year currently displayed by the calendar. + +No dates are returned if COMPONENT's `icalendar-transp' property has the +value \"TRANSPARENT\" (which means the component does not form a block +of busy time on a schedule), or if COMPONENT is an `icalendar-vjournal' +and `diary-icalendar-import-vjournal-as-nonmarking' is non-nil." + (ical:with-component component + ((ical:dtstart :first dtstart-node :value dtstart) + (ical:dtend :first dtend-node :value dtend) + (ical:due :value due) + (ical:duration :value duration) + (ical:rdate :first rdate) + (ical:rrule :first rrule) + (ical:transp :value transparency)) + (let* ((start-tz (ical:with-param-of dtstart-node 'ical:tzidparam + (ical:index-get index :tzid value))) + (end + (cond + (dtend dtend) + (due due) + (duration (ical:date/time-add-duration dtstart duration start-tz)))) + dates) + + (unless (or (equal transparency "TRANSPARENT") + (and di:import-vjournal-as-nonmarking + (ical:vjournal-component-p component))) + ;; Mark the start date(s) for every (marking) entry: + (setq dates (if end + (ical:dates-until dtstart end t) + (list (ical:date/time-to-date + (ical:date/time-to-local dtstart))))) + ;; Mark the dates for any recurrences in the displayed calendar year: + (let ((year (when (boundp 'displayed-year) ; bound by calendar + displayed-year))) + (when (and year (or rdate rrule)) + (let* ((low (list 1 1 year)) + (high (list 12 31 year)) + (recs (icr:recurrences-in-window-w/end-times + low high component start-tz))) + (dolist (rec recs) + (setq dates (append (ical:dates-until (car rec) (cadr rec) t) + dates))))))) + dates))) + +(defun di:mark-entries () + "Mark calendar dates for iCalendar data from a file. + +This function allows you to mark the dates in an iCalendar-formatted +file in the calendar without importing it. The data is read directly +from the current value of `diary-file' (which is dynamically bound by +the diary when this function is called). + +To use this function, add an '#include \"FILE\"' entry in your diary +file for each iCalendar file you want to display (see +`diary-include-string'). Then add `diary-mark-included-diary-files' to +`diary-mark-entries-hook'. Finally, add this function to +`diary-nongregorian-marking-hook', so that it is called once for each +included file when dates are marked in the calendar." + (with-no-warnings (defvar diary-file)) ; dyn. bound to included file name + (let ((diary-buffer (or (find-buffer-visiting diary-file) + (find-file-noselect diary-file)))) + (when (ical:contains-vcalendar-p diary-buffer) + (let ((vcal/idx (ical:parse-and-index diary-buffer))) + (when vcal/idx + (let* ((index (cadr vcal/idx)) + (vcalendar (car vcal/idx)) + (to-mark + (append (ical:ast-node-children-of 'ical:vevent vcalendar) + (ical:ast-node-children-of 'ical:vjournal vcalendar) + (ical:ast-node-children-of 'ical:vtodo vcalendar))) + (all-dates (mapcan (lambda (c) (di:marking-dates-of c index)) + to-mark)) + (dates (seq-uniq + (sort all-dates :lessp #'ical:date< :in-place t)))) + + (dolist (date dates) + (let ((month (calendar-extract-month date)) + (year (calendar-extract-year date))) + ;; avoid marking outside the displayed months, + ;; to speed things up: + (with-current-buffer calendar-buffer + (with-suppressed-warnings + ((free-vars displayed-year + displayed-month)) + (when (and (= year displayed-year) + (<= (1- displayed-month) month) + (<= month (1+ displayed-month))) + (calendar-mark-visible-date date)))))))))))) + + + +(provide 'diary-icalendar) + +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-") ("icr:" . "icalendar-recur-") ("di:" . "diary-icalendar-")) +;; End: +;;; diary-icalendar.el ends here diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 51a2977f583..9fe3ca44336 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -2120,8 +2120,9 @@ show the diary buffer." Prefix argument ARG makes the entry nonmarking." (interactive (list current-prefix-arg last-nonmenu-event)) - (diary-make-entry (calendar-date-string (calendar-cursor-to-date t event) t t) - arg)) + (calendar-dlet ((calendar-date-display-form diary-date-insertion-form)) + (diary-make-entry (calendar-date-string (calendar-cursor-to-date t event) t t) + arg))) ;;;###cal-autoload (defun diary-insert-weekly-entry (arg) @@ -2318,6 +2319,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." ;; Accepted formats: 10:00 10.00 10h00 10h 10am 10:00am 10.00am ;; Use of "." as a separator annoyingly matches numbers, eg "123.45". ;; Hence often prefix this with "\\(^\\|\\s-\\)." + ;; FIXME. (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\(" "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]" "\\)\\([AaPp][Mm]\\)?\\)") diff --git a/lisp/calendar/icalendar-ast.el b/lisp/calendar/icalendar-ast.el new file mode 100644 index 00000000000..35c9e4b1f1f --- /dev/null +++ b/lisp/calendar/icalendar-ast.el @@ -0,0 +1,927 @@ +;;; icalendar-ast.el --- Syntax trees for iCalendar -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Richard Lawrence +;; Created: October 2024 +;; Keywords: calendar +;; Human-Keywords: calendar, iCalendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file defines the abstract syntax tree representation for +;; iCalendar data. The AST is based on `org-element-ast' (which see; +;; that feature will eventually be renamed and moved out of the Org tree +;; into the main tree). + +;; This file contains low-level functions for constructing and +;; manipulating the AST, most of which are minimal wrappers around the +;; functions provided by `org-element-ast'. This low-level API is +;; primarily used by `icalendar-parser'. It also contains a higher-level +;; API for constructing AST nodes in Lisp code. Finally, it defines +;; functions for validating AST nodes. + +;; There are three main pieces of data in an AST node: its type, its +;; value, and its child nodes. Nodes which represent iCalendar +;; components have no values; they are simply containers for their +;; children. Nodes which represent data of the base iCalendar data +;; types have no children; they are the leaf nodes in the syntax tree. +;; The main low-level accessors for these data in AST nodes are: +;; +;; `icalendar-ast-node-type' +;; `icalendar-ast-node-value' +;; `icalendar-ast-node-children' +;; `icalendar-ast-node-children-of' +;; `icalendar-ast-node-first-child-of' + +;; To construct AST nodes in Lisp code, see especially the high-level macros: +;; +;; `icalendar-make-vcalendar' +;; `icalendar-make-vtimezone' +;; `icalendar-make-vevent' +;; `icalendar-make-vtodo' +;; `icalendar-make-vjournal' +;; `icalendar-make-property' +;; `icalendar-make-param' +;; +;; These macros wrap the macro `icalendar-make-node-from-templates', +;; which allows writing iCalendar syntax tree nodes as Lisp templates. + +;; Constructing nodes with these macros automatically validates them +;; with the function `icalendar-ast-node-valid-p', which signals an +;; `icalendar-validation-error' if the node is not valid acccording to +;; RFC5545. + + +;;; Code: +(eval-when-compile (require 'icalendar-macs)) +(require 'icalendar) +(require 'org-element-ast) +(require 'cl-lib) + +;;; Type symbols and metadata + +;; All nodes in the syntax tree have a type symbol as their first element. +;; We use the following symbol properties (all prefixed with 'icalendar-') +;; to associate type symbols with various important data about the type: +;; +;; is-type - t (marks this symbol as an icalendar type) +;; is-value, is-param, is-property, or is-component - t +;; (specifies what sort of value this type represents) +;; list-sep - for property and parameters types, a string (typically +;; "," or ";") which separates individual printed values, if the +;; type allows lists of values. If this is non-nil, syntax nodes of +;; this type should always have a list of values in their VALUE +;; field (even if there is only one value) +;; matcher - a function to match this type. This function matches the +;; regular expression defined under the type's name; it is used to provide +;; syntax highlighting in `icalendar-mode' +;; begin-rx, end-rx - for component-types, an `rx' regular expression which +;; matches the BEGIN and END lines that form its boundaries +;; value-rx - an `rx' regular expression which matches individual values +;; of this type, with no consideration for quoting or lists of values. +;; (For value types, this is just a synonym for the rx definition +;; under the type's symbol) +;; values-rx - for types that accept lists of values, an `rx' regular +;; expression which matches the whole list (including quotes, if required) +;; full-value-rx - for property and parameter types, an `rx' regular +;; expression which matches a valid value expression in group 2, or +;; an invalid value in group 3 +;; value-reader - for value types, a function which creates syntax +;; nodes of this type given a string representing their value +;; value-printer - for value types, a function to print individual +;; values of this type. It accepts a value and returns its string +;; representation. +;; default-value - for property and parameter types, a string +;; representing a default value for nodes of this type. This is the +;; value assumed when no node of this type is present in the +;; relevant part of the syntax tree. +;; substitute-value - for parameter types, a string representing a value +;; which will be substituted at parse times for unrecognized values. +;; (This is normally the same as default-value, but differs from it +;; in at least one case in RFC5545, thus it is stored separately.) +;; default-type - for property types which can accept values of multiple +;; types, this is the default type when no type for the value is +;; specified in the parameters. Any type of value other than this +;; one requires a VALUE=... parameter when the property is read or printed. +;; other-types - for property types which can accept values of multiple types, +;; this is a list of other types that the property can accept. +;; value-type - for param types, this is the value type which the parameter +;; can accept. +;; child-spec - for property and component types, a plist describing the +;; required and optional child nodes. See `icalendar-define-property' and +;; `icalendar-define-component' for details. +;; other-validator - a function to perform type-specific validation +;; for nodes of this type. If present, this function will be called +;; by `icalendar-ast-node-valid-p' during validation. +;; type-documentation - a string documenting the type. This documentation is +;; printed in the help buffer when `describe-symbol' is called on TYPE. +;; link - a hyperlink to the documentation of the type in the relevant standard + +(defun ical:type-symbol-p (symbol) + "Return non-nil if SYMBOL is an iCalendar type symbol. + +This function only checks that SYMBOL has been marked as a type; +it returns t for value types defined by `icalendar-define-type', +but also e.g. for types defined by `icalendar-define-param' and +`icalendar-define-property'. To check that SYMBOL names a value +type for property or parameter values, see +`icalendar-value-type-symbol-p' and +`icalendar-printable-value-type-symbol-p'." + (and (symbolp symbol) + (get symbol 'ical:is-type))) + +(defun ical:value-type-symbol-p (symbol) + "Return non-nil if SYMBOL is a type symbol for a value type. + +This means that SYMBOL must both satisfy `icalendar-type-symbol-p' and +have the property `icalendar-is-value'. It does not require the type to +be associated with a print name in `icalendar-value-types'; for that see +`icalendar-printable-value-type-symbol-p'." + (and (ical:type-symbol-p symbol) + (get symbol 'ical:is-value))) + +(defun ical:expects-list-of-values-p (type) + "Return non-nil if TYPE expects a list of values. + +This is never t for value types or component types. For property and +parameter types defined with `icalendar-define-param' and +`icalendar-define-property', it is true if the :list-sep argument was +specified in the definition." + (and (ical:type-symbol-p type) + (get type 'ical:list-sep))) + +(defun ical:param-type-symbol-p (type) + "Return non-nil if TYPE is a type symbol for an iCalendar parameter." + (and (ical:type-symbol-p type) + (get type 'ical:is-param))) + +(defun ical:property-type-symbol-p (type) + "Return non-nil if TYPE is a type symbol for an iCalendar property." + (and (ical:type-symbol-p type) + (get type 'ical:is-property))) + +(defun ical:component-type-symbol-p (type) + "Return non-nil if TYPE is a type symbol for an iCalendar component." + (and (ical:type-symbol-p type) + (get type 'ical:is-component))) + +;; TODO: we could define other accessors here for the other metadata +;; properties, but at the moment I see no advantage to this; they would +;; all just be long-winded wrappers around `get'. + + +;; The basic, low-level API for the AST, mostly intended for use by +;; `icalendar-parser'. These functions are mostly aliases and simple +;; wrappers around functions provided by `org-element-ast', which does +;; the heavy lifting. +(defalias 'ical:ast-node-type #'org-element-type) + +(defsubst ical:ast-node-value (node) + "Return the value of iCalendar syntax node NODE. +In component nodes, this is nil. Otherwise, it is a syntax node +representing an iCalendar (property or parameter) value." + (org-element-property :value node)) + +(defalias 'ical:ast-node-children #'org-element-contents) + +;; TODO: probably don't want &rest form for this +(defalias 'ical:ast-node-set-children #'org-element-set-contents) + +(defalias 'ical:ast-node-adopt-children #'org-element-adopt-elements) + +(defalias 'ical:ast-node-meta-get #'org-element-property) + +(defalias 'ical:ast-node-meta-set #'org-element-put-property) + +(defun ical:ast-node-set-type (node type) + "Set the type of iCalendar syntax node NODE to TYPE. + +This function is probably not what you want! It directly modifies the +type of NODE in-place, which could make the node invalid if its value or +children do not match the new TYPE. If you do not know in advance that +the data in NODE is compatible with the new TYPE, it is better to +construct a new syntax node." + (setcar node type)) + +(defun ical:ast-node-set-value (node value) + "Set the value of iCalendar syntax node NODE to VALUE." + (ical:ast-node-meta-set node :value value)) + +(defun ical:make-ast-node (type props &optional children) + "Construct a syntax node of TYPE with meta-properties PROPS and CHILDREN. + +This is a low-level constructor. If you are constructing iCalendar +syntax nodes directly in Lisp code, consider using one of the +higher-level macros based on `icalendar-make-node-from-templates' +instead, which expand to calls to this function but also perform type +checking and validation. + +TYPE should be an iCalendar type symbol. CHILDREN, if given, should be +a list of syntax nodes. In property nodes, these should be the +parameters of the property. In component nodes, these should be the +properties or subcomponents of the component. CHILDREN should otherwise +be nil. + +PROPS should be a plist with any of the following keywords: + +:value - in value nodes, this should be the Elisp value parsed from a + property or parameter's value string. In parameter and property nodes, + this should be a value node or list of value nodes. In component + nodes, it should not be present. +:buffer - buffer from which VALUE was parsed +:begin - position at which this node begins in BUFFER +:end - position at which this node ends in BUFFER +:value-begin - position at which VALUE begins in BUFFER +:value-end - position at which VALUE ends in BUFFER +:original-value - a string containing the original, uninterpreted value + of the node. This can differ from (a string represented by) VALUE + if e.g. a default VALUE was substituted for an unrecognized but + syntactically correct value. +:original-name - a string containing the original, uninterpreted name + of the parameter, property or component this node represents. + This can differ from (a string representing) TYPE + if e.g. a default TYPE was substituted for an unrecognized but + syntactically correct one." + ;; automatically mark :value as a "secondary property" for org-element-ast + (let ((full-props (if (plist-member props :value) + (plist-put props :secondary (list :value)) + props))) + (apply #'org-element-create type full-props children))) + +(defun ical:ast-node-p (val) + "Return non-nil if VAL is an iCalendar syntax node." + (and (listp val) + (length> val 1) + (ical:type-symbol-p (ical:ast-node-type val)) + (plistp (cadr val)) + (listp (ical:ast-node-children val)))) + +(defun ical:param-node-p (node) + "Return non-nil if NODE is a syntax node whose type is a parameter type." + (and (ical:ast-node-p node) + (ical:param-type-symbol-p (ical:ast-node-type node)))) + +(defun ical:property-node-p (node) + "Return non-nil if NODE is a syntax node whose type is a property type." + (and (ical:ast-node-p node) + (ical:property-type-symbol-p (ical:ast-node-type node)))) + +(defun ical:component-node-p (node) + "Return non-nil if NODE is a syntax node whose type is a component type." + (and (ical:ast-node-p node) + (ical:component-type-symbol-p (ical:ast-node-type node)))) + +(defun ical:ast-node-first-child-of (type node) + "Return the first child of NODE of type TYPE, or nil." + (assq type (ical:ast-node-children node))) + +(defun ical:ast-node-children-of (type node) + "Return a list of all the children of NODE of type TYPE." + (seq-filter (lambda (c) (eq type (ical:ast-node-type c))) + (ical:ast-node-children node))) + + +;; A high-level API for constructing iCalendar syntax nodes in Lisp code: + +(declare-function ical:list-of-p "icalendar-parser") + +(defun ical:type-of (value &optional types) + "Find the iCalendar type symbol for the type to which VALUE belongs. + +TYPES, if specified, should be a list of type symbols to check. +TYPES defaults to all type symbols listed in `icalendar-value-types'." + (require 'icalendar-parser) ; for ical:value-types, ical:list-of-p + (catch 'found + (when (ical:ast-node-p value) + (throw 'found (ical:ast-node-type value))) + ;; FIXME: the warning here is spurious, given that icalendar-parser + ;; is require'd above: + (with-suppressed-warnings ((free-vars ical:value-types)) + (dolist (type (or types (mapcar #'cdr ical:value-types))) + (if (ical:expects-list-of-values-p type) + (when (ical:list-of-p value type) + (throw 'found type)) + (when (cl-typep value type) + (throw 'found type))))))) + +;; A more flexible constructor for value nodes which can choose the +;; correct type from a list. This helps keep templates succinct and easy +;; to use in `icalendar-make-node-from-templates', and related macros +;; below. +(defun ical:make-value-node-of (type value) + "Make an iCalendar syntax node of type TYPE containing VALUE as its value. + +TYPE should be a symbol for an iCalendar value type, and VALUE should be +a value of that type. If TYPE is the symbol \\='plain-text, VALUE should +be a string, and in that case VALUE is returned as-is. + +TYPE may also be a list of type symbols; in that case, the first type in +the list which VALUE satisfies is used as the returned node's type. If +the list is nil, VALUE will be checked against all types in +`icalendar-value-types'. + +If VALUE is nil, and `icalendar-boolean' is not (in) TYPE, nil is +returned. Otherwise, a \\='wrong-type-argument error is signaled if +VALUE does not satisfy (any type in) TYPE." + (require 'icalendar-parser) + (cond + ((and (null value) + (not (if (listp type) (memq 'ical:boolean type) + (eq 'ical:boolean type)))) + ;; Instead of signaling an error, we just return nil in this case. + ;; This allows the `ical:make-*' macros higher up the stack to + ;; filter out templates that evaluate to nil at run time: + nil) + ((eq type 'plain-text) + (unless (stringp value) + (signal 'wrong-type-argument (list 'stringp value))) + value) + ((symbolp type) + (unless (ical:value-type-symbol-p type) + (signal 'wrong-type-argument (list 'icalendar-value-type-symbol-p type))) + (if (ical:expects-list-of-values-p type) + (unless (ical:list-of-p value type) + (signal 'wrong-type-argument (list `(list-of ,type) value))) + (unless (cl-typep value type) + (signal 'wrong-type-argument (list type value))) + (ical:make-ast-node type (list :value value)))) + ((listp type) + ;; N.B. nil is allowed; in that case, `ical:type-of' will check all + ;; types in `ical:value-types': + (let ((the-type (ical:type-of value type))) + (if the-type + (ical:make-ast-node the-type (list :value value)) + (signal 'wrong-type-argument + (list (if (length> type 1) (cons 'or type) (car type)) + value))))) + (t (signal 'wrong-type-argument (list '(or symbolp listp) type))))) + +(defmacro ical:make-param (type value) + "Construct an iCalendar parameter node of TYPE with value VALUE. + +TYPE should be an iCalendar type symbol satisfying +`icalendar-param-type-symbol-p'; it should not be quoted. + +VALUE should evaluate to a value appropriate for TYPE. In particular, if +TYPE expects a list of values (see `icalendar-expects-list-p'), VALUE +should be such a list. If necessary, the value(s) in VALUE will be +wrapped in syntax nodes indicating their type. + +For example, + + (icalendar-make-param icalendar-deltoparam + (list \"mailto:minionA@example.com\" \"mailto:minionB@example.com\")) + +will return an `icalendar-deltoparam' node whose value is a list of +`icalendar-cal-address' nodes containing the two addresses. + +The resulting syntax node is checked for validity by +`icalendar-ast-node-valid-p' before it is returned." + ;; TODO: support `ical:otherparam' + (unless (ical:param-type-symbol-p type) + (error "Not an iCalendar param type: %s" type)) + (let ((value-type (or (get type 'ical:value-type) 'plain-text)) + (needs-list (ical:expects-list-of-values-p type))) + `(let* ((raw-value ,value) + (value-type (quote ,value-type)) + (value + ,(if needs-list + '(if (seq-every-p #'ical:ast-node-p raw-value) + raw-value + (mapcar + (lambda (c) (ical:make-value-node-of value-type c)) + raw-value)) + '(if (ical:ast-node-p raw-value) + raw-value + (ical:make-value-node-of value-type raw-value))))) + (when value + (ical:ast-node-valid-p + (ical:make-ast-node + (quote ,type) + (list :value value))))))) + +(defmacro ical:make-property (type value &rest param-templates) + "Construct an iCalendar property node of TYPE with value VALUE. + +TYPE should be an iCalendar type symbol satisfying +`icalendar-property-type-symbol-p'; it should not be quoted. + +VALUE should evaluate to a value appropriate for TYPE. In particular, if +TYPE expects a list of values (see +`icalendar-expects-list-of-values-p'), VALUE should be such a list. If +necessary, the value(s) in VALUE will be wrapped in syntax nodes +indicating their type. If VALUE is not of the default value type for +TYPE, an `icalendar-valuetypeparam' will automatically be added to TEMPLATES. + +Each element of PARAM-TEMPLATES should represent a parameter node; see +`icalendar-make-node-from-templates' for the format of such TEMPLATES. +A template can also have the form (@ L), where L evaluates to a list of +parameter nodes to be added to the component. + +PARAM-TEMPLATES which evaluate to nil are removed when the property node +is constructed. + +For example, + + (icalendar-make-property icalendar-rdate (list \\='(2 1 2025) \\='(3 1 2025))) + +will return an `icalendar-rdate' node whose value is a list of +`icalendar-date' nodes containing the dates above as their values. + +The resulting syntax node is checked for validity by +`icalendar-ast-node-valid-p' before it is returned." + ;; TODO: support `ical:other-property', maybe like + ;; (ical:other-property "X-NAME" value ...) + (unless (ical:property-type-symbol-p type) + (error "Not an iCalendar property type: %s" type)) + (let ((value-types (cons (get type 'ical:default-type) + (get type 'ical:other-types))) + (needs-list (ical:expects-list-of-values-p type)) + params-expr children lists-of-children) + (dolist (c param-templates) + (cond ((and (listp c) (ical:type-symbol-p (car c))) + ;; c is a template for a child node, so it should be + ;; recursively expanded: + (push (cons 'ical:make-node-from-templates c) + children)) + ((and (listp c) (eq '@ (car c))) + ;; c is a template (@ L) where L evaluates to a list of children: + (push (cadr c) lists-of-children)) + (t + ;; otherwise, just pass c through as is; this allows + ;; interleaving templates with other expressions that + ;; evaluate to syntax nodes: + (push c children)))) + (when (or children lists-of-children) + (setq params-expr + `(seq-filter #'identity + (append (list ,@children) ,@lists-of-children)))) + + `(let* ((raw-value ,value) + (value-types (quote ,value-types)) + (value + ,(if needs-list + '(if (seq-every-p #'ical:ast-node-p raw-value) + raw-value + (mapcar + (lambda (c) (ical:make-value-node-of value-types c)) + raw-value)) + '(if (ical:ast-node-p raw-value) + raw-value + (ical:make-value-node-of value-types raw-value))))) + (when value + (ical:ast-node-valid-p + (ical:maybe-add-value-param + (ical:make-ast-node + (quote ,type) + (list :value value) + ,params-expr))))))) + +(defmacro ical:make-component (type &rest templates) + "Construct an iCalendar component node of TYPE from TEMPLATES. + +TYPE should be an iCalendar type symbol satisfying +`icalendar-component-type-symbol-p'; it should not be quoted. + +Each expression in TEMPLATES should represent a child node of the +component; see `icalendar-make-node-from-templates' for the format of +such TEMPLATES. A template can also have the form (@ L), where L +evaluates to a list of child nodes to be added to the component. + +Any value in TEMPLATES that evaluates to nil will be removed before the +component node is constructed. + +If TYPE is `icalendar-vevent', `icalendar-vtodo', `icalendar-vjournal', +or `icalendar-vfreebusy', the properties `icalendar-dtstamp' and +`icalendar-uid' will be automatically provided, if they are absent in +TEMPLATES. Likewise, if TYPE is `icalendar-vcalendar', the properties +`icalendar-prodid', `icalendar-version', and `icalendar-calscale' will +be automatically provided if absent. + +For example, + + (icalendar-make-component icalendar-vevent + (icalendar-summary \"Party\") + (icalendar-location \"Robot House\") + (@ list-of-other-properties)) + +will return an `icalendar-vevent' node containing the provided +properties as well as `icalendar-dtstamp' and `icalendar-uid' +properties. + +The resulting syntax node is checked for validity by +`icalendar-ast-node-valid-p' before it is returned." + ;; TODO: support `ical:other-component', maybe like + ;; (ical:other-component (:x-name "X-NAME") templates ...) + (unless (ical:component-type-symbol-p type) + (error "Not an iCalendar component type: %s" type)) + ;; Add templates for required properties automatically if we can: + (when (memq type '(ical:vevent ical:vtodo ical:vjournal ical:vfreebusy)) + (unless (assq 'ical:dtstamp templates) + (push '(ical:dtstamp (decode-time nil t)) + templates)) + (unless (assq 'ical:uid templates) + (push `(ical:uid ,(ical:make-uid templates)) + templates))) + (when (eq type 'ical:vcalendar) + (unless (assq 'ical:prodid templates) + (push `(ical:prodid ,ical:vcalendar-prodid) + templates)) + (unless (assq 'ical:version templates) + (push `(ical:version ,ical:vcalendar-version) + templates)) + (unless (assq 'ical:calscale templates) + (push '(ical:calscale "GREGORIAN") + templates))) + (when (null templates) + (error "At least one template is required")) + + (let (children lists-of-children) + (dolist (c templates) + (cond ((and (listp c) (ical:type-symbol-p (car c))) + ;; c is a template for a child node, so it should be + ;; recursively expanded: + (push (cons 'ical:make-node-from-templates c) + children)) + ((and (listp c) (eq '@ (car c))) + ;; c is a template (@ L) where L evaluates to a list of children: + (push (cadr c) lists-of-children)) + (t + ;; otherwise, just pass c through as is; this allows + ;; interleaving templates with other expressions that + ;; evaluate to syntax nodes: + (push c children)))) + (setq children (nreverse children) + lists-of-children (nreverse lists-of-children)) + (when (or children lists-of-children) + `(ical:ast-node-valid-p + (ical:make-ast-node + (quote ,type) + nil + (seq-filter #'identity + (append (list ,@children) ,@lists-of-children))))))) + +;; TODO: allow disabling the validity check?? +(defmacro ical:make-node-from-templates (type &rest templates) + "Construct an iCalendar syntax node of TYPE from TEMPLATES. + +TYPE should be an iCalendar type symbol; it should not be quoted. This +macro (and the derived macros `icalendar-make-vcalendar', +`icalendar-make-vevent', `icalendar-make-vtodo', +`icalendar-make-vjournal', `icalendar-make-vfreebusy', +`icalendar-make-valarm', `icalendar-make-vtimezone', +`icalendar-make-standard', and `icalendar-make-daylight') makes it easy +to write iCalendar syntax nodes of TYPE as Lisp code. + +Each expression in TEMPLATES represents a child node of the constructed +node. It must either evaluate to such a node, or it must have one of +the following forms: + +\(VALUE-TYPE VALUE) - constructs a node of VALUE-TYPE containing the + value VALUE. + +\(PARAM-TYPE VALUE) - constructs a parameter node of PARAM-TYPE + containing the VALUE. + +\(PROPERTY-TYPE VALUE [PARAM ...]) - constructs a property node of + PROPERTY-TYPE containing the value VALUE and PARAMs as child + nodes. Each PARAM should be a template (PARAM-TYPE VALUE), as above, + or any other expression that evaluates to a parameter node. + +\(COMPONENT-TYPE CHILD [CHILD ...]) - constructs a component node of + COMPONENT-TYPE with CHILDs as child nodes. Each CHILD should either be + a template for a property (as above), a template for a + sub-component (of the same form), or any other expression that + evaluates to an iCalendar syntax node. + +If TYPE is an iCalendar component or property type, a TEMPLATE can also +have the form (@ L), where L evaluates to a list of child nodes to be +added to the component or property node. + +For example, an iCalendar VEVENT could be written like this: + + (icalendar-make-node-from-templates icalendar-vevent + (icalendar-dtstamp (decode-time (current-time) 0)) + (icalendar-uid \"some-unique-id\") + (icalendar-summary \"Party\") + (icalendar-location \"Robot House\") + (icalendar-organizer \"mailto:bender@mars.edu\") + (icalendar-attendee \"mailto:philip.j.fry@mars.edu\" + (icalendar-partstatparam \"ACCEPTED\")) + (icalendar-attendee \"mailto:gunther@mars.edu\" + (icalendar-partstatparam \"DECLINED\")) + (icalendar-categories (list \"MISCHIEF\" \"DOUBLE SECRET PROBATION\")) + (icalendar-dtstart (icalendar-make-date-time :year 3003 :month 3 :day 13 + :hour 22 :minute 0 :second 0) + (icalendar-tzidparam \"Mars/University_Time\"))) + +Before the constructed node is returned, it is validated by +`icalendar-ast-node-valid-p'." + (cond + ((not (ical:type-symbol-p type)) + (error "Not an iCalendar type symbol: %s" type)) + ((ical:value-type-symbol-p type) + `(ical:ast-node-valid-p + (ical:make-value-node-of (quote ,type) ,(car templates)))) + ((ical:param-type-symbol-p type) + `(ical:make-param ,type ,(car templates))) + ((ical:property-type-symbol-p type) + `(ical:make-property ,type ,(car templates) ,@(cdr templates))) + ((ical:component-type-symbol-p type) + `(ical:make-component ,type ,@templates)))) + +(defmacro ical:make-vcalendar (&rest templates) + "Construct an iCalendar VCALENDAR object from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vcalendar' for the permissible child types. + +If TEMPLATES does not contain templates for the `icalendar-prodid' and +`icalendar-version' properties, they will be automatically added; see +the variables `icalendar-vcalendar-prodid' and +`icalendar-vcalendar-version'." + `(ical:make-node-from-templates ical:vcalendar ,@templates)) + +(defmacro ical:make-vevent (&rest templates) + "Construct an iCalendar VEVENT node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vevent' for the permissible child types. + +If TEMPLATES does not contain templates for the `icalendar-dtstamp' and +`icalendar-uid' properties (both required), they will be automatically +provided." + `(ical:make-node-from-templates ical:vevent ,@templates)) + +(defmacro ical:make-vtodo (&rest templates) + "Construct an iCalendar VTODO node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vtodo' for the permissible child types. + +If TEMPLATES does not contain templates for the `icalendar-dtstamp' and +`icalendar-uid' properties (both required), they will be automatically +provided." + `(ical:make-node-from-templates ical:vtodo ,@templates)) + +(defmacro ical:make-vjournal (&rest templates) + "Construct an iCalendar VJOURNAL node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vjournal' for the permissible child types. + +If TEMPLATES does not contain templates for the `icalendar-dtstamp' and +`icalendar-uid' properties (both required), they will be automatically +provided." + `(ical:make-node-from-templates ical:vjournal ,@templates)) + +(defmacro ical:make-vfreebusy (&rest templates) + "Construct an iCalendar VFREEBUSY node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vfreebusy' for the permissible child types. + +If TEMPLATES does not contain templates for the `icalendar-dtstamp' and +`icalendar-uid' properties (both required), they will be automatically +provided." + `(ical:make-node-from-templates ical:vfreebusy ,@templates)) + +(defmacro ical:make-valarm (&rest templates) + "Construct an iCalendar VALARM node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-valarm' for the permissible child types." + `(ical:make-node-from-templates ical:valarm ,@templates)) + +(defmacro ical:make-vtimezone (&rest templates) + "Construct an iCalendar VTIMEZONE node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-vtimezone' for the permissible child types." + `(ical:make-node-from-templates ical:vtimezone ,@templates)) + +(defmacro ical:make-standard (&rest templates) + "Construct an iCalendar STANDARD node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-standard' for the permissible child types." + `(ical:make-node-from-templates ical:standard ,@templates)) + +(defmacro ical:make-daylight (&rest templates) + "Construct an iCalendar DAYLIGHT node from TEMPLATES. +See `icalendar-make-node-from-templates' for the format of TEMPLATES. +See `icalendar-daylight' for the permissible child types." + `(ical:make-node-from-templates ical:daylight ,@templates)) + + +;;; Validation: + +;; Errors at the validation stage: +;; e.g. property/param values did not match, or are of the wrong type, +;; or required properties not present in a component +(define-error 'ical:validation-error "Invalid iCalendar data" 'ical:error) + +(cl-defun ical:signal-validation-error (msg &key node (severity 2)) + (signal 'ical:validation-error + (list :message msg + :buffer (ical:ast-node-meta-get :buffer node) + :position (ical:ast-node-meta-get :begin node) + :severity severity + :node node))) + +(defun ical:ast-node-required-child-p (child parent) + "Return non-nil if CHILD is required by PARENT's node type." + (let* ((type (ical:ast-node-type parent)) + (child-spec (get type 'ical:child-spec)) + (child-type (ical:ast-node-type child))) + (or (memq child-type (plist-get child-spec :one)) + (memq child-type (plist-get child-spec :one-or-more))))) + +(declare-function ical:printable-value-type-symbol-p "icalendar-parser") + +(defun ical:ast-node-valid-value-p (node) + "Validate that NODE's value satisfies the requirements of its type. +Signals an `icalendar-validation-error' if NODE's value is +invalid, or returns NODE." + (require 'icalendar-parser) ; for ical:printable-value-type-symbol-p + (let* ((type (ical:ast-node-type node)) + (value (ical:ast-node-value node)) + (valtype-param (when (ical:property-type-symbol-p type) + (ical:with-param-of node 'ical:valuetypeparam))) + (allowed-types + (cond ((ical:printable-value-type-symbol-p valtype-param) + ;; with an explicit `VALUE=sometype' param, this is the + ;; only allowed type: + (list valtype-param)) + ((and (ical:param-type-symbol-p type) + (get type 'ical:value-type)) + (list (get type 'ical:value-type))) + ((ical:property-type-symbol-p type) + (cons (get type 'ical:default-type) + (get type 'ical:other-types))) + (t nil)))) + (cond ((ical:value-type-symbol-p type) + (unless (cl-typep value type) ; see `ical:define-type' + (ical:signal-validation-error + (format "Invalid value for `%s' node: %s" type value) + :node node)) + node) + ((ical:component-node-p node) + ;; component types have no value, so no need to check anything + node) + ((and (or (ical:param-type-symbol-p type) + (ical:property-type-symbol-p type)) + (null (get type 'ical:value-type)) + (stringp value)) + ;; property and param nodes with no value type are assumed to contain + ;; strings which match a value regex: + (unless (string-match (rx-to-string (get type 'ical:value-rx)) value) + (ical:signal-validation-error + (format "Invalid string value for `%s' node: %s" type value) + :node node)) + node) + ;; otherwise this is a param or property node which itself + ;; should have one or more syntax nodes as a value, so + ;; recurse on value(s): + ((ical:expects-list-of-values-p type) + (unless (listp value) + (ical:signal-validation-error + (format "Expected list of values for `%s' node" type) + :node node)) + (when allowed-types + (dolist (v value) + (unless (memq (ical:ast-node-type v) allowed-types) + (ical:signal-validation-error + (format "Value of unexpected type `%s' in `%s' node" + (ical:ast-node-type v) type) + :node node)))) + (mapc #'ical:ast-node-valid-value-p value) + node) + (t + (unless (ical:ast-node-p value) + (ical:signal-validation-error + (format "Invalid value for `%s' node: %s" type value) + :node node)) + (when allowed-types + (unless (memq (ical:ast-node-type value) allowed-types) + (ical:signal-validation-error + (format "Value of unexpected type `%s' in `%s' node" + (ical:ast-node-type value) type) + :node node))) + (ical:ast-node-valid-value-p value))))) + +(defun ical:count-children-by-type (node) + "Count NODE's children by type. +Returns an alist mapping type symbols to the number of NODE's children +of that type." + (let ((children (ical:ast-node-children node)) + (map nil)) + (dolist (child children map) + (let* ((type (ical:ast-node-type child)) + (n (alist-get type map))) + (setf (alist-get type map) (1+ (or n 0))))))) + +(defun ical:ast-node-valid-children-p (node) + "Validate that NODE's children satisfy its type's :child-spec. + +The :child-spec is associated with NODE's type by +`icalendar-define-component', `icalendar-define-property', +`icalendar-define-param', or `icalendar-define-type', which see. +Signals an `icalendar-validation-error' if NODE is invalid, or returns +NODE. + +Note that this function does not check that the children of NODE +are themselves valid; for that, see `ical:ast-node-valid-p'." + (let* ((type (ical:ast-node-type node)) + (child-spec (get type 'ical:child-spec)) + (child-counts (ical:count-children-by-type node))) + + (when child-spec + + (dolist (child-type (plist-get child-spec :one)) + (unless (= 1 (alist-get child-type child-counts 0)) + (ical:signal-validation-error + (format "iCalendar `%s' node must contain exactly one `%s'" + type child-type) + :node node))) + + (dolist (child-type (plist-get child-spec :one-or-more)) + (unless (<= 1 (alist-get child-type child-counts 0)) + (ical:signal-validation-error + (format "iCalendar `%s' node must contain one or more `%s'" + type child-type) + :node node))) + + (dolist (child-type (plist-get child-spec :zero-or-one)) + (unless (<= (alist-get child-type child-counts 0) + 1) + (ical:signal-validation-error + (format "iCalendar `%s' node may contain at most one `%s'" + type child-type) + :node node))) + + ;; check that all child nodes are allowed: + (unless (plist-get child-spec :allow-others) + (let ((allowed-types (append (plist-get child-spec :one) + (plist-get child-spec :one-or-more) + (plist-get child-spec :zero-or-one) + (plist-get child-spec :zero-or-more))) + (appearing-types (mapcar #'car child-counts))) + + (dolist (child-type appearing-types) + (unless (member child-type allowed-types) + (ical:signal-validation-error + (format "`%s' may not contain `%s'" type child-type) + :node node)))))) + ;; success: + node)) + +(defun ical:ast-node-valid-p (node &optional recursively) + "Check that NODE is a valid iCalendar syntax node. +By default, the check will only validate NODE itself, but if +RECURSIVELY is non-nil, it will recursively check all its +descendants as well. Signals an `icalendar-validation-error' if +NODE is invalid, or returns NODE." + (unless (ical:ast-node-p node) + (ical:signal-validation-error + "Not an iCalendar syntax node" + :node node)) + + (ical:ast-node-valid-value-p node) + (ical:ast-node-valid-children-p node) + + (let* ((type (ical:ast-node-type node)) + (other-validator (get type 'ical:other-validator))) + + (unless (ical:type-symbol-p type) + (ical:signal-validation-error + (format "Node's type `%s' is not an iCalendar type symbol" type) + :node node)) + + (when (and other-validator (not (functionp other-validator))) + (ical:signal-validation-error + (format "Bad validator function `%s' for type `%s'" other-validator type))) + + (when other-validator + (funcall other-validator node))) + + (when recursively + (dolist (c (ical:ast-node-children node)) + (ical:ast-node-valid-p c recursively))) + + ;; success: + node) + +(provide 'icalendar-ast) +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; End: +;;; icalendar-ast.el ends here diff --git a/lisp/calendar/icalendar-macs.el b/lisp/calendar/icalendar-macs.el new file mode 100644 index 00000000000..30b11ba2080 --- /dev/null +++ b/lisp/calendar/icalendar-macs.el @@ -0,0 +1,1125 @@ +;;; icalendar-macs.el --- Macros for iCalendar -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Richard Lawrence +;; Created: October 2024 +;; Keywords: calendar +;; Human-Keywords: calendar, iCalendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file defines the macros `ical:define-type', `ical:define-param', +;; `ical:define-property' and `ical:define-component', used in +;; icalendar-parser.el to define the particular value types, parameters, +;; properties and components in the standard as type symbols. + +;; TODOs: +;; - in the define* macros, :default needs rethinking. +;; I had made this a string because otherwise you can't distinguish +;; an unspecified default from an explicit "FALSE" for icalendar-boolean +;; But this might not be true/might not matter anyway, and it's a pain +;; to have to read the default value where you need it. Probably +;; should just change these to be the value as read. + + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(declare-function ical:ast-node-p "icalendar-ast") +(declare-function ical:ast-node-type "icalendar-ast") +(declare-function ical:ast-node-value "icalendar-ast") +(declare-function ical:type-symbol-p "icalendar-ast") +(declare-function ical:value-type-symbol-p "icalendar-ast") +(declare-function ical:expects-list-of-values-p "icalendar-ast") + +;; Some utilities: + +(defun ical:format-child-spec (child-spec) + "Format CHILD-SPEC as a table for use in symbol documentation." + (concat + (format "%-30s%6s\n" "Type" "Number") + (make-string 36 ?-) "\n" + (mapconcat + (lambda (type) (format "%-30s%-6s\n" (format "`%s'" type) "1")) + (plist-get child-spec :one)) + (mapconcat + (lambda (type) (format "%-30s%-6s\n" (format "`%s'" type) "1+")) + (plist-get child-spec :one-or-more)) + (mapconcat + (lambda (type) (format "%-30s%-6s\n" (format "`%s'" type) "0-1")) + (plist-get child-spec :zero-or-one)) + (mapconcat + (lambda (type) (format "%-30s%-6s\n" (format "`%s'" type) "0+")) + (plist-get child-spec :zero-or-more)))) + + +;; Define value types: +(cl-defmacro ical:define-type (symbolic-name print-name doc specifier matcher + &key link + (reader #'identity) + (printer #'identity)) + "Define an iCalendar value type named SYMBOLIC-NAME. + +PRINT-NAME should be the string used to represent this type in +the value of an `icalendar-valuetypeparam' property parameter, or +nil if this is not a type that should be specified there. DOC +should be a documentation string for the type. SPECIFIER should +be a type specifier in the sense of `cl-deftype'. MATCHER should +be an RX definition body (see `rx-define'; argument lists are not +supported). + +Before the type is defined with `cl-deftype', a function will be +defined named `icalendar-match-PRINT-NAME-value' +\(or `icalendar-match-OTHER-value', if PRINT-NAME is nil, where +OTHER is derived from SYMBOLIC-NAME by removing any prefix +\"icalendar-\" and suffix \"value\"). This function takes a +string argument and matches it against MATCHER. This function may +thus occur in SPECIFIER (e.g. in a (satisfies ...) clause). + +See the functions `icalendar-read-value-node', +`icalendar-parse-value-node', and `icalendar-print-value-node' to +convert values defined with this macro to and from their text +representation in iCalendar format. + +The following keyword arguments are accepted: + +:reader - a function to read data of this type. It will be passed + a string matching MATCHER and should return an Elisp data structure. + Its name does not need to be quoted. (default: identity) + +:printer - a function to convert an Elisp data structure of this + type to a string. Its name does not need to be quoted. + (default: identity) + +:link - a string containing an URL for further documentation of this type" + (declare (doc-string 2)) + (let* (;; Related functions: + (type-dname (if print-name + (downcase print-name) + (string-trim + (symbol-name symbolic-name) + "icalendar-" "value"))) + (matcher-name (intern (concat "icalendar-match-" type-dname "-value"))) + ;; Documentation: + (header "It names a value type defined by `icalendar-define-type'.") + (matcher-doc (format +"Strings representing values of this type can be matched with +`%s'.\n" matcher-name)) + (reader-doc (format "They can be read with `%s'\n" reader)) + (printer-doc (format "and printed with `%s'." printer)) + (full-doc (concat header "\n\n" doc "\n\n" + matcher-doc reader-doc printer-doc "\n\n" +"A syntax node of this type can be read with +`icalendar-read-value-node' or parsed with `icalendar-parse-value-node', +and printed with `icalendar-print-value-node'."))) + + `(progn + ;; Type metadata needs to be available at both compile time and + ;; run time. In particular, `ical:value-type-symbol-p' needs to + ;; work at compile time. + (eval-and-compile + (setplist (quote ,symbolic-name) + (list + 'ical:is-type t + 'ical:is-value t + 'ical:matcher (function ,matcher-name) + 'ical:value-rx (quote ,symbolic-name) + 'ical:value-reader (function ,reader) + 'ical:value-printer (function ,printer) + 'ical:type-documentation ,full-doc + 'ical:link ,link))) + + (rx-define ,symbolic-name + ,matcher) + + (defun ,matcher-name (s) + ,(format "Match string S against rx `%s'." symbolic-name) + (string-match (rx ,symbolic-name) s)) + + (cl-deftype ,symbolic-name () ,specifier) + + ;; Store the association between the print name and the type + ;; symbol in ical:value-types. The check against print name + ;; here allows us to also define value types that aren't + ;; "really" types according to the standard, like + ;; `ical:geo-coordinates'. Only types that have a + ;; print-name can be specified in a VALUE parameter. + (when ,print-name + (push (cons ,print-name (quote ,symbolic-name)) ical:value-types))))) + +;; TODO: not sure this is needed. I've only used it once in the parser. +(cl-defmacro ical:define-keyword-type (symbolic-name print-name doc matcher + &key link + (reader 'intern) + (printer 'symbol-name)) + "Like `icalendar-define-type', for types represented by strings. +String values matching MATCHER are assumed to be type-specific keywords +that should be interned as symbols when read. (Thus no type specifier +is necessary: it is always just \\='symbol.) Their printed +representation is their symbol name." + `(ical:define-type ,symbolic-name ,print-name ,doc + 'symbol + ,matcher + :link ,link + :reader ,reader + :printer ,printer)) + + +;; Define parameters: +(cl-defmacro ical:define-param (symbolic-name param-name doc value + &key quoted + list-sep + default + (unrecognized default) + ((:name-face name-face) + 'ical:parameter-name nondefault-name-face) + ((:value-face value-face) + 'ical:parameter-value nondefault-value-face) + ((:warn-face warn-face) + 'ical:warning nondefault-warn-face) + extra-faces + link) + "Define iCalendar parameter PARAM-NAME under the symbol SYMBOLIC-NAME. +PARAM-NAME should be the parameter name as it should appear in +iCalendar data. + +VALUE should either be a symbol for a value type defined with +`icalendar-define-type', or an `rx' regular expression. If it is +a type symbol, the regex, reader and printer functions associated +with that type will be used when parsing and serializing values. +If it is a regular expression, it is assumed that the values of +this parameter are strings which match that regular expression. + +An `rx' regular expression named SYMBOLIC-NAME which matches the +parameter is defined: + Group 1 of this regex matches PARAM-NAME + (or any valid parameter name, if PARAM-NAME is nil). + Group 2 matches VALUE, which specifies a correct value + for this parameter according to RFC5545. + Group 3, if matched, contains any parameter value which does + *not* match VALUE, and is incorrect according to the standard. + +This regex matches the entire string representing this parameter, +from \";\" to the end of its value. Another regular expression +named `SYMBOLIC-NAME-value' is also defined to match just the +value part, after \";PARAM-NAME=\", with groups 2 and 3 as above. + +A function to match the complete parameter expression called +`icalendar-match-PARAM-NAME-param' is defined +\(or `icalendar-match-OTHER-param-value' if PARAM-NAME is nil, +where OTHER is derived from SYMBOLIC-NAME by removing any prefix +`icalendar-' and suffix `param'). This function is used +to provide syntax highlighting in `icalendar-mode'. + +See the functions `icalendar-read-param-value', +`icalendar-parse-param-value', `icalendar-parse-params' and +`icalendar-print-param-node' to convert parameters defined with +this macro to and from their text representation in iCalendar +format. + +The following keyword arguments are accepted: + +:default - a (string representing the) default value, if the + parameter is not specified on a given property. + +:unrecognized - a (string representing the) value which must be + substituted for values that are not recognized but syntactically + correct according to RFC5545. Unrecognized values must be in match + group 5 of the regex determined by VALUE. An unrecognized value will + be preserved in the syntax tree metadata and printed instead of this + value when the node is printed. Defaults to any value specified for + :default. + +:quoted - non-nil if values of this parameter must always be surrounded + by (double-)quotation marks when printed, according to RFC5545. + +:list-sep - if the parameter accepts a list of values, this should be a + string which separates the values (typically \",\"). If :list-sep is + non-nil, the value string will first be split on the separator, then + if :quoted is non-nil, the individual values will be unquoted, then + each value will be read according to VALUE and collected into a list + when parsing. When printing, the inverse happens: values are quoted + if :quoted is non-nil, then joined with :list-sep. Passing this + argument marks SYMBOLIC-NAME as a type that accepts a list of values + for `icalendar-expects-list-of-values-p'. + +:name-face - a face symbol for highlighting the property name + (default: `icalendar-parameter-name') + +:value-face - a face symbol for highlighting valid property values + (default: `icalendar-parameter-value') + +:warn-face - a face symbol for highlighting invalid property values + (default: `icalendar-warning') + +:extra-faces - a list of the form accepted for HIGHLIGHT in + `font-lock-keywords'. In particular, + ((GROUPNUM FACENAME [OVERRIDE [LAXMATCH]]) ...) + can be used to apply different faces to different + match subgroups. + +:link - a string containing a URL for documentation of this parameter. + The URL will be provided in the documentation shown by + `describe-symbol' for SYMBOLIC-NAME." + (declare (doc-string 2)) + (let* (;; Related function names: + (param-dname (if param-name + (downcase param-name) + (string-trim (symbol-name symbolic-name) + "icalendar-" "param"))) + (matcher-name (intern (concat "icalendar-match-" param-dname "-param"))) + (type-predicate-name + (intern (concat "icalendar-" param-dname "-param-p"))) + ;; Value regexes: + (qvalue-rx (if quoted `(seq ?\" ,value ?\") value)) + (values-rx (when list-sep + `(seq ,qvalue-rx (zero-or-more ,list-sep ,qvalue-rx)))) + (full-value-rx-name + (intern (concat (symbol-name symbolic-name) "-value"))) + ;; Faces: + (has-faces (or nondefault-name-face nondefault-value-face + nondefault-warn-face extra-faces)) + ;; Documentation: + (header "It names a parameter type defined by `icalendar-define-param'.") + (val-list (if list-sep (concat "VAL1" list-sep "VAL2" list-sep "...") + "VAL")) + (s (if list-sep "s" "")) ; to make plurals + (val-doc (concat "VAL" s " " + "must be " (unless list-sep "a ") (when quoted "quoted ") + (if (ical:value-type-symbol-p value) + (format "`%s' value%s" (symbol-name value) s) + (format "string%s matching rx `%s'" s value)))) + (syntax-doc (format "Syntax: %s=%s\n%s" + (or param-name "(NAME)") val-list val-doc)) + (full-doc (concat header "\n\n" doc "\n\n" syntax-doc))) + + `(progn + ;; Type metadata needs to be available at both compile time and + ;; run time. In particular, `ical:value-type-symbol-p' needs to + ;; work at compile time. + (eval-and-compile + (setplist (quote ,symbolic-name) + (list + 'ical:is-type t + 'ical:is-param t + 'ical:matcher (function ,matcher-name) + 'ical:default-value ,default + 'ical:is-quoted ,quoted + 'ical:list-sep ,list-sep + 'ical:substitute-value ,unrecognized + 'ical:matcher (function ,matcher-name) + 'ical:value-type + (when (ical:value-type-symbol-p (quote ,value)) + (quote ,value)) + 'ical:value-rx (quote ,value) + 'ical:values-rx (quote ,values-rx) + 'ical:full-value-rx (quote ,full-value-rx-name) + 'ical:type-documentation ,full-doc + 'ical:link ,link))) + + ;; Regex which matches just the value of the parameter: + ;; Group 2: correct values of the parameter, and + ;; Group 3: incorrect values up to the next parameter + (rx-define ,full-value-rx-name + (or (group-n 2 ,(or values-rx qvalue-rx)) + (group-n 3 ical:param-value))) + + ;; Regex which matches the full parameter: + ;; Group 1: the parameter name, + ;; Group 2: correct values of the parameter, and + ;; Group 3: incorrect values up to the next parameter + (rx-define ,symbolic-name + (seq ";" + ;; if the parameter name has no printed form, the best we + ;; can do is match ical:param-name: + (group-n 1 ,(or param-name 'ical:param-name)) + "=" + ,full-value-rx-name)) + + ;; CL-type to represent syntax nodes for this parameter: + (defun ,type-predicate-name (node) + ,(format "Return non-nil if NODE represents a %s parameter." param-name) + (and (ical:ast-node-p node) + (eq (ical:ast-node-type node) (quote ,symbolic-name)))) + + (cl-deftype ,symbolic-name () '(satisfies ,type-predicate-name)) + + ;; Matcher for the full param string, for syntax highlighting: + (defun ,matcher-name (limit) + ,(concat (format "Matcher for %s parameter.\n" param-name) + "(Defined by `icalendar-define-param'.)") + (re-search-forward (rx ,symbolic-name) limit t)) + + ;; Entry for font-lock-keywords in icalendar-mode: + (when ,has-faces + ;; Avoid circular load of icalendar-mode.el in + ;; icalendar-parser.el (which does not use the *-face + ;; keywords), while still allowing external code to add to + ;; font-lock-keywords dynamically: + (require 'icalendar-mode) + (push (quote (,matcher-name + (1 (quote ,name-face) t t) + (2 (quote ,value-face) t t) + (3 (quote ,warn-face) t t) + ,@extra-faces)) + ical:font-lock-keywords)) + + ;; Associate the print name with the type symbol for + ;; `ical:parse-params' and `ical:print-param': + (when ,param-name + (push (cons ,param-name (quote ,symbolic-name)) ical:param-types))))) + + +;; Define properties: +(cl-defmacro ical:define-property (symbolic-name property-name doc value + &key default + (unrecognized default) + (default-type + (if (ical:value-type-symbol-p value) + value + 'ical:text)) + other-types + list-sep + child-spec + other-validator + ((:name-face name-face) + 'ical:property-name nondefault-name-face) + ((:value-face value-face) + 'ical:property-value nondefault-value-face) + ((:warn-face warn-face) + 'ical:warning nondefault-warn-face) + extra-faces + link) + "Define iCalendar property PROPERTY-NAME under SYMBOLIC-NAME. +PROPERTY-NAME should be the property name as it should appear in +iCalendar data. + +VALUE should either be a symbol for a value type defined with +`icalendar-define-type', or an `rx' regular expression. If it is +a type symbol, the regex, reader and printer functions associated +with that type will be used when parsing and serializing the +property's value. If it is a regular expression, it is assumed +that the values are strings of type `icalendar-text' which match +that regular expression. + +An `rx' regular expression named SYMBOLIC-NAME is defined to +match the property: + Group 1 of this regex matches PROPERTY-NAME. + Group 2 matches VALUE. + Group 3, if matched, contains any property value which does + *not* match VALUE, and is incorrect according to the standard. + Group 4, if matched, contains the (unparsed) property parameters; + its boundaries can be used for parsing these. + +This regex matches the entire string representing this property, +from the beginning of the content line to the end of its value. +Another regular expression named `SYMBOLIC-NAME-value' is also +defined to match just the value part, after the separating colon, +with groups 2 and 3 as above. + +A function to match the complete property expression called +`icalendar-match-PROPERTY-NAME-property' is defined. This +function is used to provide syntax highlighting in +`icalendar-mode'. + +See the functions `icalendar-read-property-value', +`icalendar-parse-property-value', `icalendar-parse-property', and +`icalendar-print-property-node' to convert properties defined +with this macro to and from their text representation in +iCalendar format. + +The following keyword arguments are accepted: + +:default - a (string representing the) default value, if + the property is not specified in a given component. + +:unrecognized - a (string representing the) value which must be + substituted for values that are not recognized but + syntactically correct according to RFC5545. Unrecognized values + must be in match group 5 of the regex determined by VALUE. An + unrecognized value will be preserved in the syntax tree + metadata and printed instead of this value when the node is + printed. Defaults to any value specified for :default. + +:default-type - a type symbol naming the default type of the + property's value. If the property's value differs from this + type, an `icalendar-valuetypeparam' parameter will be added to + the property's syntax node and printed when the node is + printed. Default is VALUE if VALUE is a value type symbol, + otherwise the type `icalendar-text'. + +:other-types - a list of type symbols naming value types other + than :default-type. These represent alternative types for the + property's value. If parsing the property's value under its + default type fails, these types will be tried in turn, and only + if the property's value matches none of them will an error be + signaled. + +:list-sep - if the property accepts a list of values, this should + be a string which separates the values (typically \",\"). If + :list-sep is non-nil, the value string will first be split on + the separator, then each value will be read according to VALUE + and collected into a list when parsing. When printing, the + inverse happens: values are printed individually and then + joined with :list-sep. Passing this argument marks + SYMBOLIC-NAME as a type that accepts a list of values for + `icalendar-expects-list-of-values-p'. + +:child-spec - a plist mapping the following keywords to lists +of type symbols: + :one - parameters that must appear exactly once + :one-or-more - parameters that must appear at least once and + may appear more than once + :zero-or-one - parameters that must appear at most once + :zero-or-more - parameters that may appear more than once + :allow-others - if non-nil, other parameters besides those listed in + the above are allowed to appear. (In this case, a + :zero-or-more clause is redundant.) + +:other-validator - a function to perform any additional validation of + the component, beyond what `icalendar-ast-node-valid-p' checks. + This function should accept one argument, a syntax node. It + should return non-nil if the node is valid, or signal an + `icalendar-validation-error' if it is not. Its name does not + need to be quoted. + +:name-face - a face symbol for highlighting the property name + (default: `icalendar-property-name') + +:value-face - a face symbol for highlighting valid property values + (default: `icalendar-property-value') + +:warn-face - a face symbol for highlighting invalid property values + (default: `icalendar-warning') + +:extra-faces - a list of the form for HIGHLIGHT in `font-lock-keywords'. + In particular, ((GROUPNUM FACENAME [OVERRIDE [LAXMATCH]])...) + can be used to apply different faces to different match subgroups. + +:link - a string containing a URL for documentation of this property" + (declare (doc-string 2)) + (let* (;; Value RX: + (full-value-rx-name + (intern (concat (symbol-name symbolic-name) "-property-value"))) + (values-rx (when list-sep + `(seq ,value (zero-or-more ,list-sep ,value)))) + ;; Related functions: + (property-dname (if property-name + (downcase property-name) + (string-trim (symbol-name symbolic-name) + "icalendar-" "-property"))) + (matcher-name + (intern (concat "icalendar-match-" property-dname "-property"))) + (type-predicate-name + (intern (concat "icalendar-" property-dname "-property-p"))) + ;; Faces: + (has-faces (or nondefault-name-face nondefault-value-face + nondefault-warn-face extra-faces)) + ;; Documentation: + (header "It names a property type defined by `icalendar-define-property'.") + (val-list (if list-sep (concat "VAL1" list-sep "VAL2" list-sep "...") + "VAL")) + (default-doc (if default (format "The default value is: \"%s\"\n" default) + "")) + (s (if list-sep "s" "")) ; to make plurals + (val-doc (concat "VAL" s " " + "must be " (unless list-sep "a ") + (format "value%s of one of the following types:\n" s) + (string-join + (cons + (format "`%s' (default)" default-type) + (mapcar (lambda (type) (format "`%s'" type)) + other-types)) + "\n") + default-doc)) + (name-doc (if property-name "" "NAME must match rx `icalendar-name'")) + (syntax-doc (format "Syntax: %s[;PARAM...]:%s\n%s\n%s\n" + (or property-name "NAME") val-list name-doc val-doc)) + (child-doc + (concat + "The following parameters are required or allowed\n" + "as children in syntax nodes of this type:\n\n" + (ical:format-child-spec child-spec) + (when (plist-get child-spec :allow-others) + "\nOther parameters of any type are also allowed.\n"))) + (full-doc (concat header "\n\n" doc "\n\n" syntax-doc "\n\n" child-doc))) + + `(progn + ;; Type metadata needs to be available at both compile time and + ;; run time. In particular, `ical:value-type-symbol-p' needs to + ;; work at compile time. + (eval-and-compile + (setplist (quote ,symbolic-name) + (list + 'ical:is-type t + 'ical:is-property t + 'ical:matcher (function ,matcher-name) + 'ical:default-value ,default + 'ical:default-type (quote ,default-type) + 'ical:other-types (quote ,other-types) + 'ical:list-sep ,list-sep + 'ical:substitute-value ,unrecognized + 'ical:value-type + (when (ical:value-type-symbol-p (quote ,value)) + (quote ,value)) + 'ical:value-rx (quote ,value) + 'ical:values-rx (quote ,values-rx) + 'ical:full-value-rx (quote ,full-value-rx-name) + 'ical:child-spec (quote ,child-spec) + 'ical:other-validator (function ,other-validator) + 'ical:type-documentation ,full-doc + 'ical:link ,link))) + + ;; Value regex which matches: + ;; Group 2: correct values of the property, and + ;; Group 3: incorrect values up to end-of-line (for syntax warnings) + (rx-define ,full-value-rx-name + (or (group-n 2 ,(or values-rx value)) + (group-n 3 (zero-or-more any)))) + + ;; Full property regex which matches: + ;; Group 1: the property name, + ;; Group 2: correct values of the property, and + ;; Group 3: incorrect values up to end-of-line (for syntax warnings) + (rx-define ,symbolic-name + (seq line-start + (group-n 1 ,(or property-name 'ical:name)) + (group-n 4 (zero-or-more ical:other-param-safe)) + ":" + ,full-value-rx-name + line-end)) + + ;; Matcher: + (defun ,matcher-name (limit) + ,(concat (format "Matcher for `%s' property.\n" symbolic-name) + "(Defined by icalendar-define-property.)") + (re-search-forward (rx ,symbolic-name) limit t)) + + ;; CL-type to represent syntax nodes for this property: + (defun ,type-predicate-name (node) + ,(format "Return non-nil if NODE represents a %s property." property-name) + (and (ical:ast-node-p node) + (eq (ical:ast-node-type node) (quote ,symbolic-name)))) + + (cl-deftype ,symbolic-name () '(satisfies ,type-predicate-name)) + + ;; Associate the print name with the type symbol for + ;; `icalendar-parse-property', `icalendar-print-property-node', etc.: + (when ,property-name + (push (cons ,property-name (quote ,symbolic-name)) ical:property-types)) + + ;; Generate an entry for font-lock-keywords in icalendar-mode: + (when ,has-faces + ;; Avoid circular load of icalendar-mode.el in + ;; icalendar-parser.el (which does not use the *-face + ;; keywords), while still allowing external code to add to + ;; font-lock-keywords dynamically: + (require 'icalendar-mode) + (push (quote (,matcher-name + (1 (quote ,name-face) t t) + (2 (quote ,value-face) t t) + (3 (quote ,warn-face) t t) + ,@extra-faces)) + ical:font-lock-keywords))))) + + +;; Define components: +(cl-defmacro ical:define-component (symbolic-name component-name doc + &key + ((:keyword-face keyword-face) + 'ical:keyword nondefault-keyword-face) + ((:name-face name-face) + 'ical:component-name nondefault-name-face) + child-spec + other-validator + link) + "Define iCalendar component COMPONENT-NAME under SYMBOLIC-NAME. +COMPONENT-NAME should be the name of the component as it should +appear in iCalendar data. + +Regular expressions to match the component boundaries are defined +named `COMPONENT-NAME-begin' and `COMPONENT-NAME-end' (or +`OTHER-begin' and `OTHER-end', where `OTHER' is derived from +SYMBOLIC-NAME by removing any prefix `icalendar-' and suffix +`-component' if COMPONENT-NAME is nil). + Group 1 of these regexes matches the \"BEGIN\" or \"END\" + keyword that marks a component boundary. + Group 2 matches the component name. + +A function to match the component boundaries is defined called +`icalendar-match-COMPONENT-NAME-component' (or +`icalendar-match-OTHER-component', with OTHER as above). This +function is used to provide syntax highlighting in +`icalendar-mode'. + +The following keyword arguments are accepted: + +:child-spec - a plist mapping the following keywords to lists +of type symbols: + :one - properties or components that must appear exactly once + :one-or-more - properties or components that must appear at least once and + may appear more than once + :zero-or-one - properties or components that must appear at most once + :zero-or-more - properties or components that may appear more than once + :allow-others - if non-nil, other children besides those listed in the above + are allowed to appear. (In this case, a :zero-or-more + clause is redundant.) + +:other-validator - a function to perform any additional validation of + the component, beyond what `icalendar-ast-node-valid-p' checks. + This function should accept one argument, a syntax node. It + should return non-nil if the node is valid, or signal an + `icalendar-validation-error' if it is not. Its name does not + need to be quoted. + +:keyword-face - a face symbol for highlighting the BEGIN/END keyword + (default: `icalendar-keyword') + +:name-face - a face symbol for highlighting the component name + (default: `icalendar-component-name') + +:link - a string containing a URL for documentation of this component" + (declare (doc-string 2)) + (let* (;; Regexes: + (name-rx (or component-name 'ical:name)) + (component-dname (if component-name + (downcase component-name) + (string-trim (symbol-name symbolic-name) + "icalendar-" "-component"))) + (begin-rx-name (intern (concat "icalendar-" component-dname "-begin"))) + (end-rx-name (intern (concat "icalendar-" component-dname "-end"))) + ;; Related functions: + (matcher-name + (intern (concat "icalendar-match-" component-dname "-component"))) + (type-predicate-name + (intern (concat "icalendar-" component-dname "-component-p"))) + ;; Faces: + (has-faces (or nondefault-name-face nondefault-keyword-face)) + ;; Documentation: + (header "It names a component type defined by +`icalendar-define-component'.") + (name-doc (if (not component-name) + "\nNAME must match rx `icalendar-name'" + "")) + (syntax-doc (format "Syntax:\nBEGIN:%s\n[contentline ...]\nEND:%1$s%s" + (or component-name "NAME") + name-doc)) + (child-doc + (concat + "The following properties and components are required or " + "allowed\nas children in syntax nodes of this type:\n\n" + (ical:format-child-spec child-spec) + (when (plist-get child-spec :allow-others) + "\nOther properties and components of any type are also allowed.\n"))) + (full-doc (concat header "\n\n" doc "\n\n" syntax-doc "\n\n" child-doc))) + + `(progn + ;; Type metadata needs to be available at both compile time and + ;; run time. In particular, `ical:value-type-symbol-p' needs to + ;; work at compile time. + (eval-and-compile + (setplist (quote ,symbolic-name) + (list + 'ical:is-type t + 'ical:is-component t + 'ical:matcher (function ,matcher-name) + 'ical:begin-rx (quote ,begin-rx-name) + 'ical:end-rx (quote ,end-rx-name) + 'ical:child-spec (quote ,child-spec) + 'ical:other-validator (function ,other-validator) + 'ical:type-documentation ,full-doc + 'ical:link ,link))) + + ;; Regexes which match: + ;; Group 1: BEGIN or END, and + ;; Group 2: the component name + (rx-define ,begin-rx-name + (seq line-start + (group-n 1 "BEGIN") + ":" + (group-n 2 ,name-rx) + line-end)) + + (rx-define ,end-rx-name + (seq line-start + (group-n 1 "END") + ":" + (group-n 2 ,name-rx) + line-end)) + + (defun ,matcher-name (limit) + ,(concat (format "Matcher for %s component boundaries.\n" + (or component-name "unrecognized")) + "(Defined by `icalendar-define-component'.)") + (re-search-forward (rx (or ,begin-rx-name ,end-rx-name)) limit t)) + + ;; CL-type to represent syntax nodes for this component: + (defun ,type-predicate-name (node) + ,(format "Return non-nil if NODE represents a %s component." + (or component-name "unrecognized")) + (and (ical:ast-node-p node) + (eq (ical:ast-node-type node) (quote ,symbolic-name)))) + + (cl-deftype ,symbolic-name () '(satisfies ,type-predicate-name)) + + ;; Generate an entry for font-lock-keywords in icalendar-mode: + (when ,has-faces + ;; Avoid circular load of icalendar-mode.el in + ;; icalendar-parser.el (which does not use the *-face + ;; keywords), while still allowing external code to add to + ;; font-lock-keywords dynamically: + (require 'icalendar-mode) + (push (quote (,matcher-name + (1 (quote ,keyword-face) t t) + (2 (quote ,name-face) t t))) + ical:font-lock-keywords)) + + ;; Associate the print name with the type symbol for + ;; `icalendar-parse-component', `icalendar-print-component' etc.: + (when ,component-name + (push (cons ,component-name (quote ,symbolic-name)) + ical:component-types))))) + + +;; Macros for destructuring and binding AST nodes + +(defmacro ical:with-node-children (node bindings &rest body) + "Execute BODY with BINDINGS to children in NODE. +NODE should be an iCalendar syntax node representing a component or +property. + +Each binding in BINDINGS should be a list of one of the following forms: + +\(TYPE VAR) + TYPE should be a type symbol for an iCalendar property or component + which can be a child of COMPONENT. The first child node of TYPE, if + any, will be bound to VAR in BODY. + +\(TYPE KEY1 VAR1 ...) + For each KEY present, the corresponding VAR will be bound as follows: + :all - a list of all child nodes of TYPE. If this keyword is present, + none of the others are allowed. + :first - the first child node of TYPE + :default - the default value, if any, for TYPE + :value-node - the value of the node in :first + :value-type - the type of the node in :value-node (if it is a node). + :value - the value of the node in :value-node, if it is a node, + or :value-node itself, if it is not. + If TYPE expects a list of values, you should use the following keywords + instead of the previous three: + :value-nodes - the values of the node in :first + :value-types - a list of the types of the nodes in :value-nodes. + :values - a list of the values of the nodes in :value-nodes (if they are + nodes), or the :value-nodes themselves (if they are not). + It is a compile-time error to use the singular keywords with a TYPE that + takes multiple values, or the plural keywords with a TYPE that does not." + (declare (indent 2)) + ;; Static checks on the bindings prevent various annoying bugs: + (dolist (b bindings) + (let ((type (car b)) + (kwargs (cdr b))) + (unless (ical:type-symbol-p type) + (error "Not an iCalendar type symbol: %s" type)) + (when (and (plist-member kwargs :all) + (> 2 (length kwargs))) + (error ":all may not be combined with other bindings")) + (if (ical:expects-list-of-values-p type) + (when (or (plist-member kwargs :value-node) + (plist-member kwargs :value-type) + (plist-member kwargs :value)) + (error "Type `%s' expects a list of values" type)) + (when (or (plist-member kwargs :value-nodes) + (plist-member kwargs :value-types) + (plist-member kwargs :values)) + (error "Type `%s' does not expect a list of values" type))))) + + (let ((nd (gensym "icalendar-node"))) + `(let* ((,nd ,node) + ,@(mapcan + (lambda (tv) + (let ((type (car tv)) + (vars (cdr tv))) + (when (and (symbolp (car vars)) (null (cdr vars))) + ;; the simple (TYPE VAR) case: + (setq vars (list :first (car vars)))) + + (let ((first-var (or (plist-get vars :first) + (gensym "first"))) + (default-var (or (plist-get vars :default) + (gensym "default"))) + (vnode-var (or (plist-get vars :value-node) + (gensym "value-node"))) + (vtype-var (or (plist-get vars :value-type) + (gensym "value-type"))) + (vval-var (or (plist-get vars :value) + (gensym "value"))) + + (vnodes-var (or (plist-get vars :value-nodes) + (gensym "value-nodes"))) + (vtypes-var (or (plist-get vars :value-types) + (gensym "value-types"))) + (vvals-var (or (plist-get vars :values) + (gensym "values"))) + + (all-var (or (plist-get vars :all) + (gensym "all"))) + ;; The corresponding vars for :all are mostly + ;; too complicated to be useful, I think, so + ;; not implementing them for now. + ;; TODO: but it *would* be helpful to have an + ;; :all-values clause especially for RDATE and + ;; EXDATE, since they both accept lists, and + ;; can also occur multiple times. + ;; I've found myself needing to write + ;; (mapcar #'ical:ast-node-value + ;; (apply #'append + ;; (mapcar #'ical:ast-node-value rdate-nodes)) + ;; a bit too often. + ) + (delq nil + (list + (when (plist-member vars :all) + `(,all-var (ical:ast-node-children-of + (quote ,type) ,nd))) + (when (not (plist-member vars :all)) + `(,first-var (ical:ast-node-first-child-of + (quote ,type) ,nd))) + (when (plist-member vars :default) + `(,default-var (get (quote ,type) + 'ical:default-value))) + ;; Single value: + (when (or (plist-member vars :value-node) + (plist-member vars :value-type) + (plist-member vars :value)) + `(,vnode-var (when (ical:ast-node-p ,first-var) + (ical:ast-node-value ,first-var)))) + (when (plist-member vars :value-type) + `(,vtype-var + (when ,vnode-var + (ical:ast-node-type ,vnode-var)))) + (when (plist-member vars :value) + `(,vval-var + (when ,vnode-var + (if (ical:ast-node-p ,vnode-var) + (ical:ast-node-value ,vnode-var) + ,vnode-var)))) + + ;; List of values: + (when (or (plist-member vars :value-nodes) + (plist-member vars :value-types) + (plist-member vars :values)) + `(,vnodes-var + (when (ical:ast-node-p ,first-var) + (ical:ast-node-value ,first-var)))) + (when (plist-member vars :value-types) + `(,vtypes-var + (when ,vnodes-var + (mapcar #'ical:ast-node-type ,vnodes-var)))) + (when (plist-member vars :values) + `(,vvals-var + (when ,vnodes-var + (if (ical:ast-node-p (car ,vnodes-var)) + (mapcar #'ical:ast-node-value + ,vnodes-var) + ,vnodes-var))))))))) + + bindings)) + ,@body))) + +(defalias 'ical:with-component #'ical:with-node-children + "Execute BODY with properties of NODE bound as in BINDINGS. + +NODE should be an iCalendar syntax node representing an iCalendar +component: `icalendar-vevent', `icalendar-vtodo', `icalendar-vjournal', +`icalendar-vtimezone', `icalendar-vfreebusy', `icalendar-standard', +`icalendar-daylight'. It may also be an entire `icalendar-vcalendar'. + +Each binding in BINDINGS should be a list of one of the following forms: + +(TYPE VAR) + TYPE should be a type symbol for an iCalendar property or component + which can be a child of COMPONENT. The first child node of TYPE, if + any, will be bound to VAR in BODY. + +(TYPE KEY1 VAR1 ...) + For each KEY present, the corresponding VAR will be bound as follows: + :all - a list of all child nodes of TYPE. If this keyword is present, + none of the others are allowed. + :default - the default value, if any, for TYPE + :first - the first child node of TYPE + :value-node - the value (which is itself a node) of the node in :first + :value-type - the type of the node in :value-node. + :value - the value of the node in :value-node. + If TYPE expects a list of values, you should use the following keywords + instead of the previous three: + :value-nodes - the values (which are themselves nodes) of the node in :first + :value-types - a list of the types of the nodes in :value-nodes. + :values - a list of the values of the node in :value-node. + It is a compile-time error to use the singular keywords with a TYPE that + takes multiple values, or the plural keywords with a TYPE that does not.") + +(defmacro ical:with-node-value (node &optional bindings &rest body) + "Execute BODY with bindings in BINDINGS taken from NODE and its children. + +NODE should be an iCalendar syntax node representing a property or +parameter. If NODE is not a syntax node, this form evalutes to nil +without binding the variables in BINDINGS and without executing BODY. + +Within BODY, if NODE's value is itself a syntax node, the symbol +`value-node' will be bound to the syntax node for NODE's value, +`value-type' will be bound to `value-node's type, and `value' will be +bound to `value-node's value. + +If NODE's value is a list of syntax nodes, then within BODY, +`value-nodes' will be bound to those value nodes, `value-types' will be +bound to a list of their types, and `values' will be bound to their +values. + +If NODE's value is not a syntax node, then `value' is instead bound +directly to NODE's value, and `value-type' and `value-node' are bound to +nil. + +If BODY is nil, it is assumed to be the symbol `value'; thus + (icalendar-with-node-value some-node) +is equivalent to + (icalendar-with-node-value some-node nil value) + +BINDINGS are passed on to `icalendar-with-node-children' and will be +available in BODY; see its docstring for their form." + (let ((vn (gensym "icalendar-node")) + (val (gensym "icalendar-value")) + (is-list (gensym "is-list"))) + `(let ((,vn ,node)) + (when (ical:ast-node-p ,vn) + (let* ((,val (ical:ast-node-value ,vn)) + (value-node (when (ical:ast-node-p ,val) ,val)) + (value-type (when (ical:ast-node-p value-node) + (ical:ast-node-type value-node))) + (value (if (ical:ast-node-p value-node) + (ical:ast-node-value value-node) + ,val)) + (,is-list (ical:expects-list-of-values-p (ical:ast-node-type ,vn))) + (value-nodes (when ,is-list + (seq-filter #'ical:ast-node-p ,val))) + (value-types (when ,is-list + (mapcar #'ical:ast-node-type value-nodes))) + (values (when ,is-list + (mapcar #'ical:ast-node-value value-nodes)))) + (ignore value-type ; Silence the byte compiler when + value ; one of these goes unused + value-types + values) + (ical:with-node-children ,vn ,bindings ,@(or body (list 'value)))))))) + +(defalias 'ical:with-property #'ical:with-node-value + "Execute BODY with BINDINGS taken from the value and parameters in NODE. + +NODE should be an iCalendar syntax node representing a property. If NODE +is not a syntax node, this form evalutes to nil without binding the +variables in BINDINGS and without executing BODY. + +Within BODY, if NODE's value is itself a syntax node, the symbol +`value-node' will be bound to the syntax node for NODE's value, +`value-type' will be bound to `value-node's type, and `value' will be +bound to `value-node's value. + +If NODE's value is a list of syntax nodes, then within BODY, +`value-nodes' will be bound to those value nodes, `value-types' will be +bound to a list of their types, and `values' will be bound to their +values. + +If NODE's value is not a syntax node, then `value' is bound directly to +NODE's value, and `value-type' and `value-node' are bound to nil. + +BINDINGS are passed on to `icalendar-with-node-children' and will be +available in BODY; see its docstring for their form.") + +(defmacro ical:with-param (parameter &rest body) + "Bind the value in PARAMETER and execute BODY. + +PARAMETER should be an iCalendar syntax node representing a +parameter. If PARAMETER is nil, this form evalutes to nil without +executing BODY. + +Within BODY, if PARAMETER's value is a syntax node, the symbol +`value-node' will be bound to that syntax node, `value-type' will be +bound to the value node's type, and `value' will be bound to the value +node's value. + +If PARAMETER's value is not a syntax node, then `value' is bound +directly to PARAMETER's value, and `value-type' and `value-node' are +bound to nil." + `(ical:with-node-value ,parameter nil ,@body)) + +(defmacro ical:with-child-of (node type &optional bindings &rest body) + "Like `icalendar-with-node-value', but for the relevant node's parent. + +Find the first child node of type TYPE in NODE, bind that +child node's value and any of its children in BINDINGS and execute BODY +with these bindings. If there is no such node, this form evalutes to +nil without executing BODY. + +Within BODY, the symbols `value-node', `value-type', and `value' will be +bound as in `icalendar-with-node-value'. +If BODY is nil, it is assumed to be the symbol `value'; thus + (icalendar-with-child-of some-node some-type) +is equivalent to + (icalendar-with-child-of some-node some-type nil value) + +See `icalendar-with-node-children' for the form of BINDINGS." + (let ((child (gensym "icalendar-node"))) + `(let ((,child (ical:ast-node-first-child-of ,type ,node))) + (ical:with-node-value ,child ,bindings ,@body)))) + +(defalias 'ical:with-property-of #'ical:with-child-of + "Like `icalendar-with-property', but for components containing that property. + +Find the first property node of type TYPE in NODE and execute BODY. + +Within BODY, the symbols `value-node', `value-type', and `value' will be +bound to the property's value node, type and value as in +`icalendar-with-node-value'. If BODY is nil, it is assumed to be the +symbol `value'; thus + (icalendar-with-property-of some-component some-type) +is equivalent to + (icalendar-with-property-of some-component some-type nil value) + +BINDINGS can be used to bind the property's parameters; see +`icalendar-with-node-children' for the form of BINDINGS.") + +(defmacro ical:with-param-of (node type &rest body) + "Like `icalendar-with-param', but for properties containing that param. + +Find the first parameter node of TYPE in NODE and execute BODY. + +Within BODY, the symbols `value-node', `value-type', and `value' will be +bound to the parameter's value node, type and value as in +`icalendar-with-node-value'. If BODY is nil, it is assumed to be the +symbol `value'; thus + (icalendar-with-param-of some-property some-type) +is equivalent to + (icalendar-with-param-of some-property some-type nil value)" + `(ical:with-child-of ,node ,type nil ,@body)) + +(provide 'icalendar-macs) +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; End: +;;; icalendar-macs.el ends here diff --git a/lisp/calendar/icalendar-mode.el b/lisp/calendar/icalendar-mode.el new file mode 100644 index 00000000000..2fc2aec44ff --- /dev/null +++ b/lisp/calendar/icalendar-mode.el @@ -0,0 +1,610 @@ +;;; icalendar-mode.el --- Major mode for iCalendar format -*- lexical-binding: t; -*- +;;; + +;; Copyright (C) 2024 Richard Lawrence + +;; Author: Richard Lawrence +;; Keywords: calendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file defines icalendar-mode, a major mode for iCalendar data. +;; Its main job is to provide syntax highlighting using the matching +;; functions created for iCalendar syntax in icalendar-parser.el, and to +;; perform line unfolding and folding via format conversion. + +;; When activated, icalendar-mode unfolds content lines if necessary. +;; This is because the parsing functions, and thus syntax highlighting, +;; assume that content lines have already been unfolded. When a buffer +;; is saved, icalendar-mode also automatically folds long content if +;; necessary, as required by RFC5545. + + +;;; Code: +(require 'icalendar-parser) +(require 'format) + +;; Faces and font lock: +(defgroup ical:faces + '((ical:property-name custom-face) + (ical:property-value custom-face) + (ical:parameter-name custom-face) + (ical:parameter-value custom-face) + (ical:component-name custom-face) + (ical:keyword custom-face) + (ical:binary-data custom-face) + (ical:date-time-types custom-face) + (ical:numeric-types custom-face) + (ical:recurrence-rule custom-face) + (ical:warning custom-face) + (ical:ignored custom-face)) + "Faces for `icalendar-mode'." + :version "31.1" + :group 'icalendar + :prefix 'icalendar) + +(defface ical:property-name + '((default . (:inherit font-lock-keyword-face))) + "Face for iCalendar property names.") + +(defface ical:property-value + '((default . (:inherit default))) + "Face for iCalendar property values.") + +(defface ical:parameter-name + '((default . (:inherit font-lock-property-name-face))) + "Face for iCalendar parameter names.") + +(defface ical:parameter-value + '((default . (:inherit font-lock-property-use-face))) + "Face for iCalendar parameter values.") + +(defface ical:component-name + '((default . (:inherit font-lock-constant-face))) + "Face for iCalendar component names.") + +(defface ical:keyword + '((default . (:inherit font-lock-keyword-face))) + "Face for other iCalendar keywords.") + +(defface ical:binary-data + '((default . (:inherit font-lock-comment-face))) + "Face for iCalendar values that represent binary data.") + +(defface ical:date-time-types + '((default . (:inherit font-lock-type-face))) + "Face for iCalendar values that represent time. +These include dates, date-times, durations, periods, and UTC offsets.") + +(defface ical:numeric-types + '((default . (:inherit ical:property-value-face))) + "Face for iCalendar values that represent integers, floats, and geolocations.") + +(defface ical:recurrence-rule + '((default . (:inherit font-lock-type-face))) + "Face for iCalendar recurrence rule values.") + +(defface ical:uri + '((default . (:inherit ical:property-value-face :underline t))) + "Face for iCalendar values that are URIs (including URLs and mail addresses).") + +(defface ical:warning + '((default . (:inherit font-lock-warning-face))) + "Face for iCalendar syntax errors.") + +(defface ical:ignored + '((default . (:inherit font-lock-comment-face))) + "Face for iCalendar syntax which is parsed but ignored.") + +;;; Font lock: +(defconst ical:params-font-lock-keywords + '((ical:match-other-param + (1 'font-lock-comment-face t t) + (2 'font-lock-comment-face t t) + (3 'ical:warning t t)) + (ical:match-value-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-tzid-param + (1 'ical:parameter-name t t) + (2 'ical:parameter-value t t) + (3 'ical:warning t t)) + (ical:match-sent-by-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-rsvp-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-role-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-reltype-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-related-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-range-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-partstat-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-member-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-language-param + (1 'ical:parameter-name t t) + (2 'ical:parameter-value t t) + (3 'ical:warning t t)) + (ical:match-fbtype-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-fmttype-param + (1 'ical:parameter-name t t) + (2 'ical:parameter-value t t) + (3 'ical:warning t t)) + (ical:match-encoding-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-dir-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-delegated-to-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-delegated-from-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-cutype-param + (1 'ical:parameter-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-cn-param + (1 'ical:parameter-name t t) + (2 'ical:parameter-value t t) + (3 'ical:warning t t)) + (ical:match-altrep-param + (1 'ical:parameter-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t))) + "Entries for iCalendar property parameters in `font-lock-keywords'.") + +(defconst ical:properties-font-lock-keywords + '((ical:match-request-status-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-other-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-sequence-property + (1 'ical:property-name t t) + (2 'ical:numeric-types t t) + (3 'ical:warning t t)) + (ical:match-last-modified-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-dtstamp-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-created-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-trigger-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-repeat-property + (1 'ical:property-name t t) + (2 'ical:numeric-types t t) + (3 'ical:warning t t)) + (ical:match-action-property + (1 'ical:property-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-rrule-property + (1 'ical:property-name t t) + (2 'ical:recurrence-rule t t) + (3 'ical:warning t t)) + (ical:match-rdate-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-exdate-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-uid-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-url-property + (1 'ical:property-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-related-to-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-recurrence-id-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-organizer-property + (1 'ical:property-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-contact-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-attendee-property + (1 'ical:property-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-tzurl-property + (1 'ical:property-name t t) + (2 'ical:uri t t) + (3 'ical:warning t t)) + (ical:match-tzoffsetto-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-tzoffsetfrom-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-tzname-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-tzid-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-transp-property + (1 'ical:property-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-freebusy-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-duration-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-dtstart-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-due-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-dtend-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-completed-property + (1 'ical:property-name t t) + (2 'ical:date-time-types t t) + (3 'ical:warning t t)) + (ical:match-summary-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-status-property + (1 'ical:property-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-resources-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-priority-property + (1 'ical:property-name t t) + (2 'ical:numeric-types t t) + (3 'ical:warning t t)) + (ical:match-percent-complete-property + (1 'ical:property-name t t) + (2 'ical:numeric-types t t) + (3 'ical:warning t t)) + (ical:match-location-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-geo-property + (1 'ical:property-name t t) + (2 'ical:numeric-types t t) + (3 'ical:warning t t)) + (ical:match-description-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-comment-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-class-property + (1 'ical:property-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t)) + (ical:match-categories-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-attach-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t) + (13 'ical:uri t t) + (14 'ical:binary-data t t)) + (ical:match-version-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-prodid-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-method-property + (1 'ical:property-name t t) + (2 'ical:property-value t t) + (3 'ical:warning t t)) + (ical:match-calscale-property + (1 'ical:property-name t t) + (2 'ical:keyword t t) + (3 'ical:warning t t))) + "Entries for iCalendar properties in `font-lock-keywords'.") + +(defconst ical:ignored-properties-font-lock-keywords + `((,(rx ical:other-property) (1 'ical:ignored keep t) + (2 'ical:ignored keep t))) + "Entries for iCalendar ignored properties in `font-lock-keywords'.") + +(defconst ical:components-font-lock-keywords + '((ical:match-vcalendar-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-other-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-valarm-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-daylight-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-standard-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-vtimezone-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-vfreebusy-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-vjournal-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-vtodo-component + (1 'ical:keyword t t) + (2 'ical:component-name t t)) + (ical:match-vevent-component + (1 'ical:keyword t t) + (2 'ical:component-name t t))) + "Entries for iCalendar components in `font-lock-keywords'.") + +(defvar ical:font-lock-keywords + (append ical:params-font-lock-keywords + ical:properties-font-lock-keywords + ical:components-font-lock-keywords + ical:ignored-properties-font-lock-keywords) + "Value of `font-lock-keywords' for `icalendar-mode'.") + + +;; The major mode: + +;;; Mode hook +(defvar ical:mode-hook nil + "Hook run when activating `icalendar-mode'.") + +;;; Activating the mode for .ics files: +(add-to-list 'auto-mode-alist '("\\.ics\\'" . icalendar-mode)) + +;;; Syntax table +(defvar ical:mode-syntax-table + (let ((st (make-syntax-table))) + ;; Characters for which the standard syntax table suffices: + ;; ; (punctuation): separates some property values, and property parameters + ;; " (string): begins and ends string values + ;; : (punctuation): separates property name (and parameters) from property + ;; values + ;; , (punctuation): separates values in a list + ;; CR, LF (whitespace): content line endings + ;; space (whitespace): when at the beginning of a line, continues the + ;; previous line + + ;; Characters which need to be adjusted from the standard syntax table: + ;; = is punctuation, not a symbol constituent: + (modify-syntax-entry ?= ". " st) + ;; / is punctuation, not a symbol constituent: + (modify-syntax-entry ?/ ". " st) + st) + "Syntax table used in `icalendar-mode'.") + +;;; Coding systems + +;; Provide a hint to the decoding system that iCalendar files use DOS +;; line endings. This appears to be the simplest way to ensure that +;; `find-file' will correctly decode an iCalendar file, since decoding +;; happens before icalendar-mode starts. +(add-to-list 'file-coding-system-alist '("\\.ics\\'" . undecided-dos)) + +;;; Format conversion + +;; We use the format conversion infrastructure provided by format.el, +;; `insert-file-contents', and `write-region' to automatically perform +;; line unfolding when icalendar-mode starts in a buffer, and line +;; folding when it is saved to a file. See Info node `(elisp)Format +;; Conversion' for more. + +(defconst ical:format-definition + '(text/calendar "iCalendar format" + nil ; no regexp - icalendar-mode runs decode instead + ical:unfold-region ; decoding function + ical:folding-annotations ; encoding function + nil ; encoding function does not modify buffer + nil ; no need to activate a minor mode + t) ; preserve the format when saving + "Entry for iCalendar format in `format-alist'.") + +(add-to-list 'format-alist ical:format-definition) + +(defun ical:-format-decode-buffer () + "Call `format-decode-buffer' with the \\='text/calendar format. +This function is intended to be run from `icalendar-mode-hook'." + (format-decode-buffer 'text/calendar)) + +(add-hook 'ical:mode-hook #'ical:-format-decode-buffer -90) + +(defun ical:-disable-auto-fill () + "Disable `auto-fill-mode' in iCalendar buffers. +Auto-fill-mode interferes with line folding and syntax highlighting, so +it is off by default in iCalendar buffers. This function is intended to +be run from `icalendar-mode-hook'." + (when auto-fill-function + (auto-fill-mode -1))) + +(add-hook 'ical:mode-hook #'ical:-disable-auto-fill -91) + +;;; Commands + +(defun ical:switch-to-unfolded-buffer () + "Switch to a new buffer with content lines unfolded. +The new buffer will contain the same data as the current buffer, but +with content lines unfolded (before decoding, if possible). + +`Folding' means inserting a line break and a single whitespace +character to continue lines longer than 75 octets; `unfolding' +means removing the extra whitespace inserted by folding. The +iCalendar standard (RFC5545) requires folding lines when +serializing data to iCalendar format, and unfolding before +parsing it. In `icalendar-mode', folded lines may not have proper +syntax highlighting; this command allows you to view iCalendar +data with proper syntax highlighting, as the parser sees it. + +If the current buffer is visiting a file, this function will +offer to save the buffer first, and then reload the contents from +the file, performing unfolding with `icalendar-unfold-undecoded-region' +before decoding it. This is the most reliable way to unfold lines. + +If it is not visiting a file, it will unfold the new buffer +with `icalendar-unfold-region'. This can in some cases have +undesirable effects (see its docstring), so the original contents +are preserved unchanged in the current buffer. + +In both cases, after switching to the new buffer, this command +offers to kill the original buffer. + +It is recommended to turn off `auto-fill-mode' when viewing an +unfolded buffer, so that filling does not interfere with syntax +highlighting. This function offers to disable `auto-fill-mode' if +it is enabled in the new buffer; consider using +`visual-line-mode' instead." + (interactive) + (when (and buffer-file-name (buffer-modified-p)) + (when (y-or-n-p (format "Save before reloading from %s?" + (file-name-nondirectory buffer-file-name))) + (save-buffer))) + (let ((old-buffer (current-buffer)) + (mmode major-mode) + (uf-buffer (if buffer-file-name + (ical:unfolded-buffer-from-file buffer-file-name) + (ical:unfolded-buffer-from-buffer (current-buffer))))) + (switch-to-buffer uf-buffer) + ;; restart original major mode, in case the new buffer is + ;; still in fundamental-mode: TODO: is this necessary? + (funcall mmode) + (when (y-or-n-p (format "Unfolded buffer is shown. Kill %s?" + (buffer-name old-buffer))) + (kill-buffer old-buffer)) + (when (and auto-fill-function (y-or-n-p "Disable auto-fill-mode?")) + (auto-fill-mode -1)))) + +;;; Mode definition +;;;###autoload +(define-derived-mode icalendar-mode text-mode "iCalendar" + "Major mode for viewing and editing iCalendar (RFC5545) data. + +This mode provides syntax highlighting for iCalendar components, +properties, values, and property parameters, and defines a format to +automatically handle folding and unfolding iCalendar content lines. + +`Folding' means inserting whitespace characters to continue long +lines; `unfolding' means removing the extra whitespace inserted +by folding. The iCalendar standard requires folding lines when +serializing data to iCalendar format, and unfolding before +parsing it. + +Thus icalendar-mode's syntax highlighting is designed to work with +unfolded lines. When `icalendar-mode' is activated in a buffer, it will +automatically unfold lines using a file format conversion, and +automatically fold lines when saving the buffer to a file; see Info +node `(elisp)Format Conversion' for more information. It also disables +`auto-fill-mode' if it is active, since filling interferes with line +folding and syntax highlighting. Consider using `visual-line-mode' in +`icalendar-mode' instead." + :group 'icalendar + :syntax-table ical:mode-syntax-table + ;; TODO: Keymap? + ;; TODO: buffer-local variables? + ;; TODO: indent-line-function and indentation variables + ;; TODO: mode-specific menu and context menus + ;; TODO: eldoc integration + ;; TODO: completion of keywords + ;; TODO: hook for folding in change-major-mode-hook? + (progn + (setq font-lock-defaults '(ical:font-lock-keywords nil t)))) + +(provide 'icalendar-mode) + +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; End: +;;; icalendar-mode.el ends here diff --git a/lisp/calendar/icalendar-parser.el b/lisp/calendar/icalendar-parser.el new file mode 100644 index 00000000000..186557ffeb1 --- /dev/null +++ b/lisp/calendar/icalendar-parser.el @@ -0,0 +1,4889 @@ +;;; icalendar-parser.el --- Parse iCalendar grammar -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Richard Lawrence +;; Created: October 2024 +;; Keywords: calendar +;; Human-Keywords: calendar, iCalendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file defines regular expressions, constants and functions that +;; implement the iCalendar grammar according to RFC5545. +;; +;; iCalendar data is grouped into *components*, such as events or +;; to-do items. Each component contains one or more *content lines*, +;; which each contain a *property* name and its *value*, and possibly +;; also property *parameters* with additional data that affects the +;; interpretation of the property. +;; +;; The macros `ical:define-type', `ical:define-param', +;; `ical:define-property' and `ical:define-component', defined in +;; icalendar-macs.el, each create rx-style regular expressions for one +;; of these categories in the grammar and are used here to define the +;; particular value types, parameters, properties and components in the +;; standard as type symbols. These type symbols store all the metadata +;; about the relevant types, and are used for type-based dispatch in the +;; parser and printer functions. In the abstract syntax tree, each node +;; contains a type symbol naming its type. A number of other regular +;; expressions which encode basic categories of the grammar are also +;; defined in this file. +;; +;; The following functions provide the high-level interface to the parser: +;; +;; `icalendar-parse-and-index' +;; `icalendar-parse' +;; `icalendar-parse-calendar' +;; `icalendar-parse-component' +;; `icalendar-parse-property' +;; `icalendar-parse-params' +;; +;; The format of the abstract syntax tree which these functions create +;; is documented in icalendar-ast.el. Nodes in this tree can be +;; serialized to iCalendar format with the corresponding printer +;; functions: +;; +;; `icalendar-print-calendar-node' +;; `icalendar-print-component-node' +;; `icalendar-print-property-node' +;; `icalendar-print-params' + +;;; Code: + +(require 'icalendar) +(eval-when-compile (require 'icalendar-macs)) +(require 'icalendar-ast) +(eval-when-compile (require 'cl-lib)) +(require 'subr-x) +(require 'seq) +(require 'rx) +(require 'calendar) +(require 'time-date) +(require 'simple) +(require 'help-mode) + +;;; Customization +(defgroup icalendar-parser nil + "iCalendar parsing options." + :version "31.1" + :group 'icalendar + :prefix 'icalendar) + +(defcustom ical:parse-strictly nil + "When non-nil, iCalendar data will be parsed strictly. + +By default, the iCalendar parser accepts certain harmless deviations +from RFC5545 that are common in real-world data (e.g., unescaped commas +in text values). Setting this to t will cause the parser to produce +errors instead of silently accepting such data." + :version "31.1" + :type '(choice (const :tag "Ignore minor errors" nil) + (const :tag "Parse strictly" t))) + +;;; Functions for folding and unfolding +;; +;; According to RFC5545, iCalendar content lines longer than 75 octets +;; should be *folded* by inserting extra line breaks and leading +;; whitespace to continue the line. Such lines must be *unfolded* +;; before they can be parsed. Unfolding can only reliably happen +;; before Emacs decodes a region of text, because decoding potentially +;; replaces the CR-LF line endings which terminate content lines. +;; Programs that can control when decoding happens should use the +;; stricter `ical:unfold-undecoded-region' to unfold text; programs +;; that must work with decoded data should use the looser +;; `ical:unfold-region'. `ical:fold-region' will fold content lines +;; using line breaks appropriate to the buffer's coding system. +;; +;; All the parsing-related code belows assumes that lines have +;; already been unfolded if necessary. +(defcustom ical:pre-unfolding-hook nil + "Hook run before unfolding iCalendar data. + +The functions in this hook will be run before the iCalendar data is +\"unfolded\", i.e., before whitespace introduced for breaking long lines +is removed (see `icalendar-unfold-region' and +`icalendar-unfold-undecoded-region'). If you routinely receive +iCalendar data that is not correctly folded, you can add functions to +this hook which clean up that data before unfolding is attempted. + +Each function should accept zero arguments and should perform its +operation on the entire current buffer." + :version "31.1" + :type '(hook) + :options '(ical:fix-line-endings)) + +(defun ical:fix-line-endings () + "Convert all line endings to LF. +This function is intended to be used from `icalendar-pre-unfolding-hook' +(which see) to make files with inconsistent line endings parseable." + (when ical:parse-strictly + (ical:warn + (concat "Converting line endings to LF causes parsing " + "errors when `icalendar-parse-strictly' is non-nil."))) + (goto-char (point-min)) + (while (re-search-forward "\r\n?" nil t) + (replace-match "\n"))) + +(defun ical:unfold-undecoded-region (start end &optional buffer) + "Unfold an undecoded region in BUFFER between START and END. +If omitted, BUFFER defaults to the current buffer. + +\"Unfolding\" means removing the whitespace characters inserted to +continue lines longer than 75 octets (see `icalendar-fold-region' +for the folding operation). RFC5545 specifies these whitespace +characters to be a CR-LF sequence followed by a single space or +tab character. Unfolding can only be done reliably before a +region is decoded, since decoding potentially replaces CR-LF line +endings. + +When `icalendar-parse-strictly' is non-nil, this function searches +strictly for CR-LF sequences and will fail if they have already been +replaced, so it should only be called with a region that has not yet +been decoded. Otherwise, it also searches for folds containing +Unix-style LF line endings, since these are common in real data." + (with-current-buffer (or buffer (current-buffer)) + (let ((modp (buffer-modified-p))) + (with-restriction start end + (run-hooks 'ical:pre-unfolding-hook) + (goto-char (point-min)) + ;; Testing reveals that a *significant* amount of real-world data + ;; does not use CR-LF line endings, even if it is otherwise + ;; OK. So unless we're explicitly parsing strictly, we allow the + ;; CR to be missing, as we do in `icalendar-unfold-region': + (let ((fold (if ical:parse-strictly (rx (seq "\r\n" (or " " "\t"))) + (rx (seq (zero-or-one "\r") "\n" (or " " "\t")))))) + (while (re-search-forward fold nil t) + (replace-match "" nil nil))) + ;; merely unfolding should not mark the buffer as modified; + ;; this prevents querying the user before killing it: + (set-buffer-modified-p modp))))) + +(defun ical:unfold-region (start end &optional buffer) + "Unfold region between START and END in BUFFER (default: current buffer). + +\"Unfolding\" means removing the whitespace characters inserted to +continue lines longer than 75 octets (see `icalendar-fold-region' +for the folding operation). + +Returns the new end position after unfolding finishes. Thus this +function is a suitable FROM-FN (decoding function) for `format-alist'. + +WARNING: Unfolding can only be done reliably before text is +decoded, since decoding potentially replaces CR-LF line endings. +Unfolding an already-decoded region could lead to unexpected +results, such as displaying multibyte characters incorrectly, +depending on the contents and the coding system used. + +This function attempts to do the right thing even if the region +is already decoded. If it is still undecoded, it is better to +call `icalendar-unfold-undecoded-region' directly instead, and +decode it afterward." + ;; TODO: also make this a command so it can be run manually? + (with-current-buffer (or buffer (current-buffer)) + (let ((was-multibyte enable-multibyte-characters) + (start-char (position-bytes start)) + (end-char (position-bytes end)) + (end-marker (make-marker))) + ;; set a marker at the original end position so we can return + ;; the updated position later: + (set-marker end-marker end) + ;; we put the buffer in unibyte mode and later restore its + ;; previous state, so that if the buffer was already multibyte, + ;; any multibyte characters where line folds broke up their + ;; bytes can be reinterpreted: + (set-buffer-multibyte nil) + (with-restriction start-char end-char + (run-hooks 'ical:pre-unfolding-hook) + (goto-char (point-min)) + ;; since we can't be sure that line folds have a leading CR + ;; in already-decoded regions, do the best we can: + (while (re-search-forward (rx (seq (zero-or-one "\r") "\n" + (or " " "\t"))) + nil t) + (replace-match "" nil nil))) + ;; restore previous state, possibly reinterpreting characters: + (set-buffer-multibyte was-multibyte) + ;; return the new end of the region, for format.el conversion: + (marker-position end-marker)))) + +(defun ical:unfolded-buffer-from-region (start end &optional buffer) + "Create a new, unfolded buffer with the same contents as the region. + +Copies the buffer contents between START and END (in BUFFER, if +provided) to a new buffer and performs line unfolding in the new buffer +with `icalendar-unfold-region'. That function can in some cases have +undesirable effects; see its docstring. If BUFFER is visiting a file, it +may be better to reload its contents from that file and perform line +unfolding before decoding; see `icalendar-unfolded-buffer-from-file'. +Returns the new buffer." + (let* ((old-buffer (or buffer (current-buffer))) + (contents (with-current-buffer old-buffer + (buffer-substring start end))) + (uf-buffer (generate-new-buffer ;; TODO: again, move to modeline? + (concat " *UNFOLDED:" (buffer-name old-buffer))))) + (with-current-buffer uf-buffer + (insert contents) + (ical:unfold-region (point-min) (point-max)) + ;; ensure we'll use CR-LF line endings on write, even if they weren't + ;; in the source data. The standard also says UTF-8 is the default + ;; encoding, so use 'prefer-utf-8-dos when last-coding-system-used + ;; is nil. + (setq buffer-file-coding-system + (if last-coding-system-used + (coding-system-change-eol-conversion last-coding-system-used + 'dos) + 'prefer-utf-8-dos)) + ;; inhibit auto-save-mode, which will otherwise create save + ;; files containing the unfolded data; these are probably + ;; not useful to the user and a nuisance when running tests: + (auto-save-mode -1)) + uf-buffer)) + +(defun ical:unfolded-buffer-from-buffer (buffer) + "Create a new, unfolded buffer with the same contents as BUFFER. + +Copies the contents of BUFFER to a new buffer and performs line +unfolding there with `icalendar-unfold-region'. That function can in +some cases have undesirable effects; see its docstring. If BUFFER is +visiting a file, it may be better to reload its contents from that file +and perform line unfolding before decoding; see +`icalendar-unfolded-buffer-from-file'. Returns the new buffer." + (with-current-buffer buffer + (ical:unfolded-buffer-from-region (point-min) (point-max) buffer))) + +(defun ical:find-unfolded-buffer-visiting (filename) + "Find an existing unfolded buffer visiting FILENAME." + ;; FIXME: I was previously using + ;; (find-buffer-visiting filename #'ical:unfolded-p) + ;; for this, but found that it would sometimes return nil even when an + ;; unfolded buffer already existed for FILENAME, leading to buffers + ;; getting unfolded and parsed multiple times. Hence this kludge. + (catch 'unfolded + (let ((exp-name (expand-file-name filename))) + (dolist (buf (match-buffers "UNFOLDED")) + (when (and (equal exp-name (buffer-file-name buf)) + (ical:unfolded-p buf)) + (throw 'unfolded buf)))))) + +(defun ical:unfolded-buffer-from-file (filename &optional visit beg end) + "Return a buffer visiting FILENAME with unfolded lines. + +If an unfolded buffer is already visiting FILENAME, return +it. Otherwise, create a new buffer with the contents of FILENAME and +perform line unfolding with `icalendar-unfold-undecoded-region', then +decode the buffer, setting an appropriate value for +`buffer-file-coding-system', and return the new buffer. Optional +arguments VISIT, BEG, END are as in `insert-file-contents'." + (unless (and (file-exists-p filename) + (file-readable-p filename)) + (error "File cannot be read: %s" filename)) + (or (ical:find-unfolded-buffer-visiting filename) + (let ((uf-buffer + (generate-new-buffer + (concat " *UNFOLDED:" (file-name-nondirectory filename))))) + (with-current-buffer uf-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally filename visit beg end t) + (ical:unfold-undecoded-region (point-min) (point-max)) + ;; now proceed with decoding: + (set-buffer-multibyte t) + (decode-coding-inserted-region (point-min) (point-max) filename) + ;; ensure we'll use CR-LF line endings on write, even if they weren't + ;; in the source data. The standard also says UTF-8 is the default + ;; encoding, so use 'prefer-utf-8-dos when last-coding-system-used + ;; is nil. FIXME: for some reason, this doesn't seem to run at all! + (setq buffer-file-coding-system + (if last-coding-system-used + (coding-system-change-eol-conversion last-coding-system-used + 'dos) + 'prefer-utf-8-dos)) + ;; restore buffer name after renaming by set-visited-file-name: + (let ((bname (buffer-name))) + (set-visited-file-name filename t) + (rename-buffer bname)) + ;; merely unfolding should not mark the buffer as modified; + ;; this prevents querying the user before killing it: + (set-buffer-modified-p nil) + ;; inhibit auto-save-mode, which will otherwise create save + ;; files containing the unfolded data; these are probably + ;; not useful to the user and a nuisance when running tests: + (auto-save-mode -1)) + uf-buffer))) + +(defun ical:fold-region (begin end &optional annotate-only use-tabs) + "Fold content lines between BEGIN and END when longer than 75 octets. + +\"Folding\" means inserting a line break and a single space +character at the beginning of the new line. If USE-TABS is +non-nil, insert a tab character instead of a single space. + +RFC5545 specifies that lines longer than 75 *octets* (excluding +the line-ending CR-LF sequence) must be folded, and allows that +some implementations might fold lines in the middle of a +multibyte character. This function takes care not to do that in a +buffer where `enable-multibyte-characters' is non-nil, and only +folds between character boundaries. If the buffer is in unibyte +mode, however, and contains undecoded multibyte data, it may fold +lines in the middle of a multibyte character. + +By default, this function modifies the region by inserting line folds. +If the optional argument ANNOTATE-ONLY is non-nil, it will instead leave +the buffer unmodified, and return a list of \"annotations\" +\(POSITION . LINE-FOLD), indicating where line folds in the region should +be inserted. This output is suitable for a function in +`write-region-annotation-functions'; `icalendar-folding-annotations' +is a wrapper for this function which can be added to that list." + ;; TODO: also make this a command so it can be run manually? + (let (annotations) + (save-excursion + (goto-char begin) + (when (not (bolp)) + (let ((inhibit-field-text-motion t)) + (beginning-of-line))) + (let ((bol (point)) + (eol (make-marker)) + (reg-end (make-marker)) + (line-fold (if use-tabs "\n\t" "\n "))) + (set-marker reg-end end) + (while (< bol reg-end) + (let ((inhibit-field-text-motion t)) + (end-of-line)) + (set-marker eol (point)) + (when (< 75 (- (position-bytes (marker-position eol)) + (position-bytes bol))) + (goto-char + ;; the max of 75 excludes the two CR-LF + ;; characters we're about to add: + (byte-to-position (+ 75 (position-bytes bol)))) + (if annotate-only + (push (cons (point) line-fold) annotations) + (insert line-fold)) + (set-marker eol (point))) + (setq bol (goto-char (1+ eol)))))) + ;; Return annotations, or nil if we modified the buffer directly: + (nreverse annotations))) + +(defun ical:folding-annotations (start end &optional buffer) + "Return a list of annotations for folding lines in the region. + +This function is a wrapper for `icalendar-fold-region' that provides the +interface to be used from `write-region-annotation-functions', which +see." + ;; start may be nil or a string; see `write-region' + (if (stringp start) + (let ((buf (generate-new-buffer " *icalendar-folded*"))) + (set-buffer buf) + (insert start) + (ical:fold-region (point-min) (point-max) t)) + + (when (bufferp buffer) (set-buffer buffer)) + (ical:fold-region (or start (point-min)) + (if start end (point-max)) + t))) + +(defun ical:contains-folded-lines-p (&optional buffer) + "Return non-nil if BUFFER contains folded content lines. + +BUFFER defaults to the current buffer. Folded content lines need to be +unfolded before parsing the buffer or performing syntax +highlighting. Returns the position at the end of the first fold, or nil." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (goto-char (point-min)) + (re-search-forward (rx (seq line-start (or " " "\t"))) + nil t)))) + +(defun ical:unfolded-p (&optional buffer) + "Return non-nil if BUFFER does not contain any folded content lines. +BUFFER defaults to the current buffer." + (not (ical:contains-folded-lines-p buffer))) + +(defun ical:contains-unfolded-lines-p (&optional buffer) + "Return non-nil if BUFFER contains long content lines that should be folded. + +Lines longer than 75 bytes need to folded before saving or transmitting +the data in BUFFER (default: current buffer). If BUFFER contains such +lines, return the position at the beginning of the first line that +requires folding." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (goto-char (point-min)) + (let ((bol (point)) + (eol (make-marker))) + (catch 'unfolded-line + (while (< bol (point-max)) + (let ((inhibit-field-text-motion t)) + (end-of-line)) + (set-marker eol (point)) + ;; the max of 75 excludes the two CR-LF characters + ;; after position eol: + (when (< 75 (- (position-bytes (marker-position eol)) + (position-bytes bol))) + (throw 'unfolded-line bol)) + (setq bol (goto-char (1+ eol)))) + nil))))) + +(defun ical:folded-p (&optional buffer) + "Return non-nil if BUFFER contains no content lines that require folding. +BUFFER defaults to the current buffer." + (not (ical:contains-unfolded-lines-p buffer))) + + +;; Parsing-related code starts here. All the parsing code assumes that +;; content lines have already been unfolded. + +;;;; Error handling: + +;; Errors at the parsing stage: +;; e.g. value does not match expected regex +(define-error 'ical:parse-error "Could not parse iCalendar data" 'ical:error) + +(cl-defun ical:signal-parse-error (msg &key (buffer (current-buffer)) + (position (point)) + (severity 2) + (line (line-number-at-pos position)) + column restart-at) + (signal 'ical:parse-error + (list :message msg + :line line + :column column + :severity severity + :position position + :buffer buffer + :restart-at restart-at))) + +(defun ical:handle-parse-error (err-data &optional skip-msg err-buffer) + (let* ((err-sym (car err-data)) + (err-plist (cdr err-data)) + (buf (plist-get err-plist :buffer)) + (restart-pos (plist-get err-plist :restart-at)) + (new-msg + (concat (plist-get err-plist :message) + "..." + (cond (skip-msg skip-msg) + (restart-pos (format "skipping to %d" restart-pos)) + (t "skipping"))))) + (setq err-plist (plist-put err-plist :message new-msg)) + (setq err-plist (plist-put err-plist :severity 1)) + (ical:handle-generic-error (cons err-sym err-plist) err-buffer) + (when restart-pos + (with-current-buffer buf + (goto-char restart-pos))))) + +;; Errors at the printing stage: +;; e.g. default print function doesn't know how to print value +(define-error 'ical:print-error "Unable to print iCalendar data" 'ical:error) + +(cl-defun ical:signal-print-error (msg &key (severity 2) node) + (signal 'ical:print-error + (list :message msg + :node node + :buffer (ical:ast-node-meta-get :buffer node) + :severity severity + :position (ical:ast-node-meta-get :begin node)))) + +(defun ical:handle-print-error (err-data &optional skip-msg err-buffer) + (let* ((err-sym (car err-data)) + (err-plist (cdr err-data)) + (new-msg (concat (plist-get err-plist :message) + "..." + (or skip-msg "skipping")))) + (setq err-plist (plist-put err-plist :message new-msg)) + (setq err-plist (plist-put err-plist :severity 1)) + (ical:handle-generic-error (cons err-sym err-plist) err-buffer)) + (ical:handle-generic-error err-data err-buffer)) + +;;;; Some utilities: +(defun ical:parse-from-string (type s) + "Parse string S to an iCalendar syntax node of type TYPE. +S should not contain folded content lines." + ;; TODO: support unfolding? + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (cond ((ical:component-type-symbol-p type) + (ical:parse-component (point-max))) + ((ical:property-type-symbol-p type) + (ical:parse-property (point-max))) + ((ical:param-type-symbol-p type) + (unless (looking-at-p ";") + (insert ";") + (backward-char)) + (ical:parse-params (point-max))) + ((ical:value-type-symbol-p type) + (ical:parse-value-node type (point-max))) + (t + (error "Don't know how to parse type %s" type))))) + +(defun ical:parse-one-of (types limit) + "Parse a value, from point up to LIMIT, of one of the TYPES. + +TYPES should be a list of type symbols. For each type in TYPES, the +parser function associated with that type will be called at point. The +return value of the first successful parser function is returned. If +none of the parser functions are able to parse a value, an +`icalendar-parse-error' is signaled." + (let* ((value nil) + (start (point)) + (type (car types)) + (parser (get type 'ical:value-parser)) + (rest (cdr types))) + (while (and parser (not value)) + (condition-case nil + (setq value (funcall parser limit)) + (ical:parse-error + ;; value of this type not found, so try again: + (goto-char start) + (setq type (car rest) + rest (cdr rest) + parser (get type 'ical:value-parser))))) + (unless value + (ical:signal-parse-error + (format "Unable to parse any of %s between %d and %d" types start limit) + :position start)) + value)) + +(defun ical:read-list-with (reader string + &optional value-regex separators omit-nulls trim) + "Read a list of values from STRING with READER. + +READER should be a reader function that accepts a single string argument. +SEPARATORS, OMIT-NULLS, and TRIM are as in `split-string'. +SEPARATORS defaults to \"[^\\][,;]\". TRIM defaults to matching a +double quote character. + +VALUE-REGEX should be a regular expression if READER assumes that +individual substrings in STRING have previously been matched +against this regex. In this case, each value in S is placed in a +temporary buffer and the match against VALUE-REGEX is performed +before READER is called." + (let* ((wrapped-reader + (if (not value-regex) + ;; no need for temp buffer: + reader + ;; match the regex in a temp buffer before calling reader: + (lambda (s) + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (unless (looking-at value-regex) + (ical:signal-parse-error + (format "Expected list of values matching '%s'" value-regex))) + (funcall reader (match-string 0)))))) + (seps (or separators "[^\\][,;]")) + (trm (or trim "\"")) + (raw-values (split-string string seps omit-nulls trm))) + + (unless (functionp reader) + (signal 'ical:parser-error + (list (format "`%s' is not a reader function" reader)))) + + (mapcar wrapped-reader raw-values))) + +(defun ical:read-list-of (type string + &optional separators omit-nulls trim) + "Read a list of values of type TYPE from STRING. + +TYPE should be a value type symbol. The reader function +associated with that type will be called to read the successive +values in STRING, and the values will be returned as a list of +syntax nodes. + +SEPARATORS, OMIT-NULLS, and TRIM are as in `split-string' and +will be passed on, if provided, to `icalendar-read-list-with'." + (let* ((reader (lambda (s) (ical:read-value-node type s))) + (val-regex (rx-to-string (get type 'ical:value-rx)))) + (ical:read-list-with reader string val-regex + separators omit-nulls trim))) + +(defun ical:list-of-p (list type) + "Return non-nil if each value in LIST satisfies TYPE. +TYPE should be a type specifier for `cl-typep'." + (seq-every-p (lambda (val) (cl-typep val type)) list)) + +(defun ical:default-value-printer (val) + "Default printer for a *single* property or parameter value. + +If VAL is a string, just return it unchanged. + +Otherwise, VAL should be a syntax node representing a value. In +that case, return the original string value if another was +substituted at parse time, or look up the printer function for +the node's type and call it on the value inside the node. + +For properties and parameters that only allow a single value, +this function should be a sufficient value printer. It is not +sufficient for those that allow lists of values, or which have +other special requirements like quoting or escaping." + (cond ((stringp val) val) + ((and (ical:ast-node-p val) + (get (ical:ast-node-type val) 'ical:value-printer)) + (or (ical:ast-node-meta-get :original-value val) + (let* ((stored-value (ical:ast-node-value val)) + (type (ical:ast-node-type val)) + (printer (get type 'ical:value-printer))) + (funcall printer stored-value)))) + ;; TODO: other cases to make things easy? + ;; e.g. symbols print as their names? + (t (ical:signal-print-error + (format "Don't know how to print value: %s" val))))) + + +;;; Section 3.1: Content lines + +;; Regexp constants for parsing: + +;; In the following regexps and define-* declarations, because +;; Emacs does not have named groups, we observe the following +;; convention so that the regexps can be combined in sensible ways: +;; +;; - Groups 1 through 5 are reserved for the highest-level regexes +;; created by define-param, define-property and define-component and +;; used in the match-* functions. Group 1 always represents a 'key' +;; (e.g. param or property name), group 2 always represents a +;; correctly parsed value for that key, and group 3 (if matched) an +;; invalid or unknown value. +;; +;; Groups 4 and 5 are reserved for other information in these +;; highest-level regexes, such as the parameter string between a +;; property name and its value, or unrecognized values allowed by +;; the standard and required to be treated like a default value. +;; +;; - Groups 6 through 10 are currently unused +;; - Groups 11 through 20 are reserved for significant sub-expressions +;; of individual value expressions, e.g. the number of weeks in a +;; duration value. The various read-* functions rely on these groups +;; when converting iCalendar data to Elisp data structures. + +(rx-define ical:iana-token + (one-or-more (any "A-Za-z0-9" "-"))) + +(rx-define ical:x-name + (seq "X-" + (zero-or-one (>= 3 (any "A-Za-z0-9")) "-") ; Vendor ID + (one-or-more (any "A-Za-z0-9" "-")))) ; Name + +(rx-define ical:name + (or ical:iana-token ical:x-name)) + +(rx-define ical:crlf + (seq #x12 #xa)) + +(rx-define ical:control + ;; All the controls except HTAB + (any (#x00 . #x08) (#x0A . #x1F) #x7F)) + +;; TODO: double check that "nonascii" class actually corresponds to +;; the range in the standard +(rx-define ical:safe-char + ;; Any character except ical:control, ?\", ?\;, ?:, ?, + (any #x09 #x20 #x21 (#x23 . #x2B) (#x2D . #x39) (#x3C . #x7E) nonascii)) + +(rx-define ical:qsafe-char + ;; Any character except ical:control and ?\" + (any #x09 #x20 #x21 (#x23 . #x7E) nonascii)) + +(rx-define ical:quoted-string + (seq ?\" (zero-or-more ical:qsafe-char) ?\")) + +(rx-define ical:paramtext + ;; RFC5545 allows *zero* characters here, but that would mean we could + ;; have parameters like ;FOO=;BAR="somethingelse", and what would then + ;; be the value of FOO? I see no reason to allow this and it breaks + ;; parameter parsing so I have required at least one char here + (one-or-more ical:safe-char)) + +(rx-define ical:param-name + (or ical:iana-token ical:x-name)) + +(rx-define ical:param-value + (or ical:paramtext ical:quoted-string)) + +(rx-define ical:value-char + (any #x09 #x20 (#x21 . #x7E) nonascii)) + +(rx-define ical:value + (zero-or-more ical:value-char)) + +;; some helpers for brevity, not defined in the standard: +(rx-define ical:comma-list (item-rx) + (seq item-rx + (zero-or-more (seq ?, item-rx)))) + +(rx-define ical:semicolon-list (item-rx) + (seq item-rx + (zero-or-more (seq ?\; item-rx)))) + + +;;; Section 3.3: Property Value Data Types + +;; Note: These definitions are here (out of order with respect to the +;; standard) because a few of them are already required for property +;; parameter definitions (section 3.2) below. + +(defconst ical:value-types nil ;; populated by define-type + "Alist mapping value type strings to type symbols. +Value type strings are those which can appear in `icalendar-valuetypeparam' +parameters and specify the type of a property's value.") + +(defun ical:read-value-node (type s) + "Read an iCalendar value of type TYPE from string S to a syntax node. +Returns a syntax node containing the value." + (let ((reader (get type 'ical:value-reader))) + (ical:make-ast-node type (list :value (funcall reader s))))) + +(defun ical:parse-value-node (type limit) + "Parse an iCalendar value of type TYPE from point up to LIMIT. +Returns a syntax node containing the value." + (let ((value-regex (rx-to-string (get type 'ical:value-rx)))) + + (unless (re-search-forward value-regex limit t) + (ical:signal-parse-error + (format "No %s value between %d and %d" type (point) limit))) + + (let ((begin (match-beginning 0)) + (end (match-end 0)) + (node (ical:read-value-node type (match-string 0)))) + (ical:ast-node-meta-set node :buffer (current-buffer)) + (ical:ast-node-meta-set node :begin begin) + (ical:ast-node-meta-set node :end end) + + node))) + +(defun ical:print-value-node (node) + "Serialize an iCalendar syntax NODE containing a value to a string." + (let* ((type (ical:ast-node-type node)) + (value-printer (get type 'ical:value-printer))) + (funcall value-printer (ical:ast-node-value node)))) + +(defun ical:printable-value-type-symbol-p (symbol) + "Return non-nil if SYMBOL represents a printable iCalendar value type. + +This means that SYMBOL names a type for a property or parameter value +defined by `icalendar-define-type' which has a print name (mainly for +use in `icalendar-valuetypeparam' parameters). That is, SYMBOL must *both* +satisfy `icalendar-value-type-symbol-p' and be associated with a print +name in `icalendar-value-types'." + (and (ical:value-type-symbol-p symbol) + (rassq symbol ical:value-types))) + +(defun ical:value-node-p (node) + "Return non-nil if NODE is a syntax node whose type is a value type." + (and (ical:ast-node-p node) + (ical:value-type-symbol-p (ical:ast-node-type node)))) + +;;;; 3.3.1 Binary +;; from https://www.rfc-editor.org/rfc/rfc4648#section-4: +(rx-define ical:base64char + (any (?A . ?Z) (?a . ?z) (?0 . ?9) ?+ ?/)) + +(ical:define-type ical:binary "BINARY" + "Type for Binary values. + +The parsed and printed representations are the same: a string of characters +representing base64-encoded data." + '(and string (satisfies ical:match-binary-value)) + (seq (zero-or-more (= 4 ical:base64char)) + (zero-or-one (or (seq (= 2 ical:base64char) "==") + (seq (= 3 ical:base64char) "=")))) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.1") + +;;;; 3.3.2 Boolean +(defun ical:read-boolean (s) + "Read an `icalendar-boolean' value from a string S. +S should be a match against rx `icalendar-boolean'." + (let ((upcased (upcase s))) + (cond ((equal upcased "TRUE") t) + ((equal upcased "FALSE") nil) + (t (ical:signal-parse-error + (format "Expected 'TRUE' or 'FALSE'; got %s" s)))))) + +(defun ical:print-boolean (b) + "Serialize an `icalendar-boolean' value B to a string." + (if b "TRUE" "FALSE")) + +(ical:define-type ical:boolean "BOOLEAN" + "Type for Boolean values. + +When printed, either the string 'TRUE' or 'FALSE'. +When read, either t or nil." + 'boolean + (or "TRUE" "FALSE") + :reader ical:read-boolean + :printer ical:print-boolean + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.2") + +;;;; 3.3.3 Calendar User Address +;; Defined with URI, below + +;; Dates and Times: + +;;;; 3.3.4 Date +(cl-deftype ical:numeric-year () '(integer 0 9999)) +(cl-deftype ical:numeric-month () '(integer 1 12)) +(cl-deftype ical:numeric-monthday () '(integer 1 31)) + +(rx-define ical:year + (= 4 digit)) + +(rx-define ical:month + (= 2 digit)) + +(rx-define ical:mday + (= 2 digit)) + +(defun ical:read-date (s) + "Read an `icalendar-date' from a string S. +S should be a match against rx `icalendar-date'." + (let ((year (string-to-number (substring s 0 4))) + (month (string-to-number (substring s 4 6))) + (day (string-to-number (substring s 6 8)))) + (list month day year))) + +(defun ical:print-date (d) + "Serialize an `icalendar-date' to a string." + (format "%04d%02d%02d" + (calendar-extract-year d) + (calendar-extract-month d) + (calendar-extract-day d))) + +(ical:define-type ical:date "DATE" + "Type for Date values. + +When printed, a date is a string of digits in YYYYMMDD format. + +When read, a date is a list (MONTH DAY YEAR), with the three +values being integers in the appropriate ranges; see calendar.el +for functions that work with this representation." + '(and (satisfies calendar-date-is-valid-p)) + (seq ical:year ical:month ical:mday) + :reader ical:read-date + :printer ical:print-date + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.4") + +;;;; 3.3.12 Time +;; (Defined here so that ical:time RX can be used in ical:date-time) +(cl-deftype ical:numeric-hour () '(integer 0 23)) +(cl-deftype ical:numeric-minute () '(integer 0 59)) +(cl-deftype ical:numeric-second () '(integer 0 60)) ; 60 represents a leap second + +(declare-function ical:make-date-time "icalendar-utils") + +(defun ical:read-time (s) + "Read an `icalendar-time' from a string S. +S should be a match against rx `icalendar-time'." + (require 'icalendar-utils) ; for ical:make-date-time; avoids circular require + (let ((hour (string-to-number (substring s 0 2))) + (minute (string-to-number (substring s 2 4))) + (second (string-to-number (substring s 4 6))) + (utcoffset (if (and (length= s 7) + (equal "Z" (substring s 6 7))) + 0 + ;; unknown/'floating' time zone: + nil))) + (ical:make-date-time :second second + :minute minute + :hour hour + :zone utcoffset))) + +(defun ical:print-time (time) + "Serialize an `icalendar-time' to a string." + (format "%02d%02d%02d%s" + (decoded-time-hour time) + (decoded-time-minute time) + (decoded-time-second time) + (if (eql 0 (decoded-time-zone time)) + "Z" ""))) + +(defun ical:-decoded-time-p (val) + "Return non-nil if VAL is a valid decoded *time*. +This predicate does not check date-related values in VAL; +for that, see `icalendar--decoded-date-time-p'." + (and (listp val) + (length= val 9) + (cl-typep (decoded-time-second val) 'ical:numeric-second) + (cl-typep (decoded-time-minute val) 'ical:numeric-minute) + (cl-typep (decoded-time-hour val) 'ical:numeric-hour) + (cl-typep (decoded-time-dst val) '(member t nil -1)) + (cl-typep (decoded-time-zone val) '(or integer null)))) + +(ical:define-type ical:time "TIME" + "Type for Time values. + +When printed, a time is a string of six digits HHMMSS, followed +by the letter 'Z' if it is in UTC. + +When read, a time is a decoded time, i.e. a list in the format +(SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF). See +`decode-time' for the specifics of the individual values. When +read, the DAY, MONTH, YEAR, and DOW fields are nil, and these +fields and DST are ignored when printed." + '(satisfies ical:-decoded-time-p) + (seq (= 6 digit) (zero-or-one ?Z)) + :reader ical:read-time + :printer ical:print-time + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.12") + +;;;; 3.3.5 Date-Time +(defun ical:-decoded-date-time-p (val) + (and (listp val) + (length= val 9) + (cl-typep (decoded-time-second val) 'ical:numeric-second) + (cl-typep (decoded-time-minute val) 'ical:numeric-minute) + (cl-typep (decoded-time-hour val) 'ical:numeric-hour) + (cl-typep (decoded-time-day val) 'ical:numeric-monthday) + (cl-typep (decoded-time-month val) 'ical:numeric-month) + (cl-typep (decoded-time-year val) 'ical:numeric-year) + (calendar-date-is-valid-p (list (decoded-time-month val) + (decoded-time-day val) + (decoded-time-year val))) + ;; FIXME: the weekday slot value should be automatically + ;; calculated from month, day, and year, like: + ;; (calendar-day-of-week (list month day year)) + ;; Although `ical:read-date-time' does this correctly, + ;; `make-decoded-time' does not. Thus we can't use + ;; `make-decoded-time' to construct valid `ical:date-time' + ;; values unless this check is turned off, + ;; which means it's annoying to write tests and anything + ;; that uses cl-typecase to dispatch on values created by + ;; `make-decoded-time': + ;; (cl-typep (decoded-time-weekday val) '(integer 0 6)) + (cl-typep (decoded-time-dst val) '(member t nil -1)) + (cl-typep (decoded-time-zone val) '(or integer null)))) + +(defun ical:read-date-time (s) + "Read an `icalendar-date-time' from a string S. +S should be a match against rx `icalendar-date-time'." + (require 'icalendar-utils) ; for ical:make-date-time; avoids circular requires + (let ((year (string-to-number (substring s 0 4))) + (month (string-to-number (substring s 4 6))) + (day (string-to-number (substring s 6 8))) + ;; "T" is index 8 + (hour (string-to-number (substring s 9 11))) + (minute (string-to-number (substring s 11 13))) + (second (string-to-number (substring s 13 15))) + (utcoffset (if (and (length= s 16) + (equal "Z" (substring s 15 16))) + 0 + ;; unknown/'floating' time zone: + nil))) + (ical:make-date-time :second second + :minute minute + :hour hour + :day day + :month month + :year year + :zone utcoffset))) + +(defun ical:print-date-time (datetime) + "Serialize an `icalendar-date-time' to a string." + (format "%04d%02d%02dT%02d%02d%02d%s" + (decoded-time-year datetime) + (decoded-time-month datetime) + (decoded-time-day datetime) + (decoded-time-hour datetime) + (decoded-time-minute datetime) + (decoded-time-second datetime) + (if (ical:date-time-is-utc-p datetime) + "Z" ""))) + +(defun ical:date-time-is-utc-p (datetime) + "Return non-nil if DATETIME is in UTC time." + (let ((offset (decoded-time-zone datetime))) + (and offset (= 0 offset)))) + +(ical:define-type ical:date-time "DATE-TIME" + "Type for Date-Time values. + +When printed, a date-time is a string of digits like: + YYYYMMDDTHHMMSS +where the 'T' is literal, and separates the date string from the +time string. + +When read, a date-time is a decoded time, i.e. a list in the format +(SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF). See +`decode-time' for the specifics of the individual values." + '(satisfies ical:-decoded-date-time-p) + (seq ical:date ?T ical:time) + :reader ical:read-date-time + :printer ical:print-date-time + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.5") + +;;;; 3.3.6 Duration +(rx-define ical:dur-second + (seq (group-n 19 (one-or-more digit)) ?S)) + +(rx-define ical:dur-minute + (seq (group-n 18 (one-or-more digit)) ?M (zero-or-one ical:dur-second))) + +(rx-define ical:dur-hour + (seq (group-n 17 (one-or-more digit)) ?H (zero-or-one ical:dur-minute))) + +(rx-define ical:dur-day + (seq (group-n 16 (one-or-more digit)) ?D)) + +(rx-define ical:dur-week + (seq (group-n 15 (one-or-more digit)) ?W)) + +(rx-define ical:dur-time + (seq ?T (or ical:dur-hour ical:dur-minute ical:dur-second))) + +(rx-define ical:dur-date + (seq ical:dur-day (zero-or-one ical:dur-time))) + +(defun ical:read-dur-value (s) + "Read an `icalendar-dur-value' from a string S. +S should be a match against rx `icalendar-dur-value'." + ;; TODO: this smells like a design flaw. Silence the byte compiler for now. + (ignore s) + (let ((sign (if (equal (match-string 20) "-") -1 1))) + (if (match-string 15) + ;; dur-value specified in weeks, so just return an integer: + (* sign (string-to-number (match-string 15))) + ;; otherwise, make a time delta from the other units: + (let* ((days (match-string 16)) + (ndays (* sign (if days (string-to-number days) 0))) + (hours (match-string 17)) + (nhours (* sign (if hours (string-to-number hours) 0))) + (minutes (match-string 18)) + (nminutes (* sign (if minutes (string-to-number minutes) 0))) + (seconds (match-string 19)) + (nseconds (* sign (if seconds (string-to-number seconds) 0)))) + (make-decoded-time :second nseconds :minute nminutes :hour nhours + :day ndays))))) + +(defun ical:print-dur-value (dur) + "Serialize an `icalendar-dur-value' to a string." + (if (integerp dur) + ;; dur-value specified in weeks can only contain weeks: + (format "%sP%dW" (if (< dur 0) "-" "") (abs dur)) + ;; otherwise, show all the time units present: + (let* ((days+- (or (decoded-time-day dur) 0)) + (hours+- (or (decoded-time-hour dur) 0)) + (minutes+- (or (decoded-time-minute dur) 0)) + (seconds+- (or (decoded-time-second dur) 0)) + ;; deal with the possibility of mixed positive and negative values + ;; in a time delta list: + (sum (+ seconds+- + (* 60 minutes+-) + (* 60 60 hours+-) + (* 60 60 24 days+-))) + (abssum (abs sum)) + (days (/ abssum (* 60 60 24))) + (sumnodays (mod abssum (* 60 60 24))) + (hours (/ sumnodays (* 60 60))) + (sumnohours (mod sumnodays (* 60 60))) + (minutes (/ sumnohours 60)) + (seconds (mod sumnohours 60)) + (sign (when (< sum 0) "-")) + (time-sep (unless (and (zerop hours) (zerop minutes) (zerop seconds)) + "T"))) + (concat sign + "P" + (unless (zerop days) (format "%dD" days)) + time-sep + (unless (zerop hours) (format "%dH" hours)) + (unless (zerop minutes) (format "%dM" minutes)) + (unless (zerop seconds) (format "%dS" seconds)))))) + +(defun ical:-time-delta-p (val) + (and (listp val) + (length= val 9) + (let ((seconds (decoded-time-second val)) + (minutes (decoded-time-minute val)) + (hours (decoded-time-hour val)) + (days (decoded-time-day val))) ; other values in list are ignored + (or (and (integerp seconds) (not (zerop seconds))) + (and (integerp minutes) (not (zerop minutes))) + (and (integerp hours) (not (zerop hours))) + (and (integerp days) (not (zerop days))))))) + +(ical:define-type ical:dur-value "DURATION" + "Type for Duration values. + +When printed, a duration is a string containing: + - possibly a +/- sign + - the letter 'P' + - one or more sequences of digits followed by a letter representing a unit + of time: 'W' for weeks, 'D' for days, etc. Units smaller than a day are + separated from days by the letter 'T'. If a duration is specified in weeks, + other units of time are not allowed. + +For example, a duration of 15 days, 5 hours, and 20 seconds would be printed: + P15DT5H0M20S +and a duration of 7 weeks would be printed: + P7W + +When read, a duration is either an integer, in which case it +represents a number of weeks, or a decoded time, in which case it +must represent a time delta in the sense of `decoded-time-add'. +Note that, in the time delta representation, units of time longer +than a day are not supported and will be ignored if present. + +This type is named `icalendar-dur-value' rather than +`icalendar-duration' for consistency with the text of RFC5545 and +so that its name does not collide with the symbol for the +`DURATION' property." + '(or integer (satisfies ical:-time-delta-p)) + ;; Group 15: weeks + ;; Group 16: days + ;; Group 17: hours + ;; Group 18: minutes + ;; Group 19: seconds + ;; Group 20: sign + (seq + (group-n 20 (zero-or-one (or ?+ ?-))) + ?P + (or ical:dur-date ical:dur-time ical:dur-week)) + :reader ical:read-dur-value + :printer ical:print-dur-value + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.6") + + +;;;; 3.3.7 Float +(ical:define-type ical:float "FLOAT" + "Type for Float values. + +When printed, possibly a sign + or -, followed by a sequence of digits, +and possibly a decimal. When read, an Elisp float value." + '(float * *) + (seq + (zero-or-one (or ?+ ?-)) + (one-or-more digit) + (zero-or-one (seq ?. (one-or-more digit)))) + :reader string-to-number + :printer number-to-string + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.7") + +;;;; 3.3.8 Integer +(ical:define-type ical:integer "INTEGER" + "Type for Integer values. + +When printed, possibly a sign + or -, followed by a sequence of digits. +When read, an Elisp integer value between -2147483648 and 2147483647." + '(integer -2147483648 2147483647) + (seq + (zero-or-one (or ?+ ?-)) + (one-or-more digit)) + :reader string-to-number + :printer number-to-string + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.8") + +;;;; 3.3.9 Period +(defsubst ical:period-start (period) + "Return the `icalendar-date-time' which marks the start of PERIOD." + (car period)) + +(defsubst ical:period--defined-end (period) + "Return the `icalendar-date-time' which marks the end of PERIOD, or nil." + (cadr period)) + + +(declare-function ical:date/time-add-duration "icalendar-utils") + +(defsubst ical:period-dur-value (period) + "Return the `icalendar-dur-value' which gives the length of PERIOD, or nil." + (caddr period)) + +(defun ical:period-end (period &optional vtimezone) + "Return the `icalendar-date-time' which marks the end of PERIOD. +If the end is not explicitly specified, it will be computed from the +period's start and duration. VTIMEZONE, if given, should be the +`icalendar-vtimezone' in which to compute the end time." + (require 'icalendar-utils) ; for date/time-add-duration; avoids circular import + (or (ical:period--defined-end period) + ;; compute end from duration and cache it: + (setf (cadr period) + (ical:date/time-add-duration + (ical:period-start period) + (ical:period-dur-value period) + vtimezone)))) + +(defun ical:period-p (val) + (and (listp val) + (length= val 3) + (cl-typep (ical:period-start val) 'ical:date-time) + (cl-typep (ical:period-end val) '(or null ical:date-time)) + (cl-typep (ical:period-dur-value val) '(or null ical:dur-value)))) + +(cl-defun ical:make-period (start &key end duration) + "Make an `icalendar-period' value. + +START and END (if given) should be `icalendar-date-time' values. +DURATION, if given, should be an `icalendar-dur-value'. It is an error +to pass both END and DURATION, or neither." + (when (and end duration) + (signal 'wrong-type-argument (list end duration))) + (unless (or end duration) + (signal 'wrong-type-argument (list end duration))) + (list start end duration)) + +(defun ical:read-period (s) + "Read an `icalendar-period' from a string S. +S should have been matched against rx `icalendar-period'." + ;; TODO: this smells like a design flaw. Silence the byte compiler for now. + (ignore s) + (let ((start (ical:read-date-time (match-string 11))) + (end (when (match-string 12) (ical:read-date-time (match-string 12)))) + (dur (when (match-string 13) (ical:read-dur-value (match-string 13))))) + (ical:make-period start :end end :duration dur))) + +(defun ical:print-period (per) + "Serialize an `icalendar-period' to a string." + (let ((start (ical:period-start per)) + (end (ical:period-end per)) + (dur (ical:period-dur-value per))) + (concat (ical:print-date-time start) + "/" + (if dur + (ical:print-dur-value dur) + (ical:print-date-time end))))) + +(ical:define-type ical:period "PERIOD" + "Type for Period values. + +A period of time is specified as a starting date-time together +with either an explicit date-time as its end, or a duration which +gives its length and implicitly marks its end. + +When printed, the starting date-time is separated from the end or +duration by a / character. + +When read, a period is represented as a list (START END DUR), where +START is an `icalendar-date-time', END is either an +`icalendar-date-time' or nil, and DUR is either an `icalendar-dur-value' +or nil. See the functions `icalendar-make-period', +`icalendar-period-start', `icalendar-period-end', and +`icalendar-period-dur-value' to work with period values." + '(satisfies ical:period-p) + (seq (group-n 11 ical:date-time) + "/" + (or (group-n 12 ical:date-time) + (group-n 13 ical:dur-value))) + :reader ical:read-period + :printer ical:print-period + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.9") + +;;;; 3.3.10 Recurrence rules: +(rx-define ical:freq + (or "SECONDLY" "MINUTELY" "HOURLY" "DAILY" "WEEKLY" "MONTHLY" "YEARLY")) + +(rx-define ical:weekday + (or "SU" "MO" "TU" "WE" "TH" "FR" "SA")) + +(rx-define ical:ordwk + (** 1 2 digit)) ; 1 to 53 + +(rx-define ical:weekdaynum + ;; Group 19: Week num, if present + ;; Group 20: week day abbreviation + (seq (zero-or-one + (group-n 19 (seq (zero-or-one (or ?+ ?-)) + ical:ordwk))) + (group-n 20 ical:weekday))) + +(rx-define ical:weeknum + (seq (zero-or-one (or ?+ ?-)) + ical:ordwk)) + +(rx-define ical:monthdaynum + (seq (zero-or-one (or ?+ ?-)) + (** 1 2 digit))) ; 1 to 31 + +(rx-define ical:monthnum + (seq (zero-or-one (or ?+ ?-)) + (** 1 2 digit))) ; 1 to 12 + +(rx-define ical:yeardaynum + (seq (zero-or-one (or ?+ ?-)) + (** 1 3 digit))) ; 1 to 366 + +(defconst ical:weekday-numbers + '(("SU" . 0) + ("MO" . 1) + ("TU" . 2) + ("WE" . 3) + ("TH" . 4) + ("FR" . 5) + ("SA" . 6)) + "Alist mapping two-letter weekday abbreviations to numbers 0 to 6. +Weekday abbreviations in recurrence rule parts are translated to +and from numbers for compatibility with calendar-* and +decoded-time-* functions.") + +(defun ical:read-weekdaynum (s) + "Read a weekday abbreviation to a number. +If the abbreviation is preceded by an offset, read a dotted +pair (WEEKDAY . OFFSET). Thus \"SU\" becomes 0, \"-1SU\" +becomes (0 . -1), etc. S should have been matched against +`icalendar-weekdaynum'." + ;; TODO: this smells like a design flaw. Silence the byte compiler for now. + (ignore s) + (let ((dayno (cdr (assoc (match-string 20) ical:weekday-numbers))) + (weekno (match-string 19))) + (if weekno + (cons dayno (string-to-number weekno)) + dayno))) + +(defun ical:print-weekdaynum (val) + "Serialize a number or dotted pair VAL to a string. +The result is in the format required for a BYDAY recurrence rule clause. +See `icalendar-read-weekdaynum' for the format of VAL." + (if (consp val) + (let* ((dayno (car val)) + (day (car (rassq dayno ical:weekday-numbers))) + (offset (cdr val))) + (concat (number-to-string offset) day)) + ;; number alone just stands for a day: + (car (rassq val ical:weekday-numbers)))) + +(defun ical:read-recur-rule-part (s) + "Read an `icalendar-recur-rule-part' from string S. +S should have been matched against `icalendar-recur-rule-part'. +The return value is a list (KEYWORD VALUE), where VALUE may +itself be a list, depending on the values allowed by KEYWORD." + ;; TODO: this smells like a design flaw. Silence the byte compiler for now. + (ignore s) + (let ((keyword (intern (upcase (match-string 11)))) + (values (match-string 12))) + (list keyword + (cl-case keyword + (FREQ (intern (upcase values))) + (UNTIL (if (length> values 8) + (ical:read-date-time values) + (ical:read-date values))) + ((COUNT INTERVAL) + (string-to-number values)) + ((BYSECOND BYMINUTE BYHOUR BYMONTHDAY BYYEARDAY BYWEEKNO BYMONTH BYSETPOS) + (ical:read-list-with #'string-to-number values nil ",")) + (BYDAY + (ical:read-list-with #'ical:read-weekdaynum values + (rx ical:weekdaynum) ",")) + (WKST (cdr (assoc values ical:weekday-numbers))))))) + +(defun ical:print-recur-rule-part (part) + "Serialize recur rule part PART to a string." + (let ((keyword (car part)) + (values (cadr part)) + values-str) + (cl-case keyword + (FREQ (setq values-str (symbol-name values))) + (UNTIL (setq values-str (cl-typecase values + (ical:date-time (ical:print-date-time values)) + (ical:date (ical:print-date values))))) + ((COUNT INTERVAL) + (setq values-str (number-to-string values))) + ((BYSECOND BYMINUTE BYHOUR BYMONTHDAY BYYEARDAY BYWEEKNO BYMONTH BYSETPOS) + (setq values-str (string-join (mapcar #'number-to-string values) + ","))) + (BYDAY + (setq values-str (string-join (mapcar #'ical:print-weekdaynum values) + ","))) + (WKST (setq values-str (car (rassq values ical:weekday-numbers))))) + + (concat (symbol-name keyword) "=" values-str))) + +(rx-define ical:recur-rule-part + ;; Group 11: keyword + ;; Group 12: value(s) + (or (seq (group-n 11 "FREQ") "=" (group-n 12 ical:freq)) + (seq (group-n 11 "UNTIL") "=" (group-n 12 (or ical:date-time ical:date))) + (seq (group-n 11 "COUNT") "=" (group-n 12 (one-or-more digit))) + (seq (group-n 11 "INTERVAL") "=" (group-n 12 (one-or-more digit))) + (seq (group-n 11 "BYSECOND") "=" (group-n 12 ; 0 to 60 + (ical:comma-list (** 1 2 digit)))) + (seq (group-n 11 "BYMINUTE") "=" (group-n 12 ; 0 to 59 + (ical:comma-list (** 1 2 digit)))) + (seq (group-n 11 "BYHOUR") "=" (group-n 12 ; 0 to 23 + (ical:comma-list (** 1 2 digit)))) ; 0 to 23 + (seq (group-n 11 "BYDAY") "=" (group-n 12 ; weeknum? daynum, e.g. SU or 34SU + (ical:comma-list ical:weekdaynum))) + (seq (group-n 11 "BYMONTHDAY") "=" (group-n 12 + (ical:comma-list ical:monthdaynum))) + (seq (group-n 11 "BYYEARDAY") "=" (group-n 12 + (ical:comma-list ical:yeardaynum))) + (seq (group-n 11 "BYWEEKNO") "=" (group-n 12 (ical:comma-list ical:weeknum))) + (seq (group-n 11 "BYMONTH") "=" (group-n 12 (ical:comma-list ical:monthnum))) + (seq (group-n 11 "BYSETPOS") "=" (group-n 12 + (ical:comma-list ical:yeardaynum))) + (seq (group-n 11 "WKST") "=" (group-n 12 ical:weekday)))) + +(defun ical:read-recur (s) + "Read a recurrence rule value from string S. +S should be a match against rx `icalendar-recur'." + ;; TODO: let's switch to keywords and a plist, so we can more easily + ;; write these clauses also in diary sexp entries without so many parens + (ical:read-list-with #'ical:read-recur-rule-part s (rx ical:recur-rule-part) ";")) + +(defun ical:print-recur (val) + "Serialize a recurrence rule value VAL to a string." + ;; RFC5545 sec. 3.3.10: "to ensure backward compatibility with + ;; applications that pre-date this revision of iCalendar the + ;; FREQ rule part MUST be the first rule part specified in a + ;; RECUR value." + (string-join + (cons + (ical:print-recur-rule-part (assq 'FREQ val)) + (mapcar #'ical:print-recur-rule-part + (seq-filter (lambda (part) (not (eq 'FREQ (car part)))) + val))) + ";")) + +(defconst ical:-recur-value-types + ;; `list-of' is not a cl-type specifier, just a symbol here; it is + ;; handled specially when checking types in `ical:recur-value-p': + '(FREQ (member YEARLY MONTHLY WEEKLY DAILY HOURLY MINUTELY SECONDLY) + UNTIL (or ical:date-time ical:date) + COUNT (integer 1 *) + INTERVAL (integer 1 *) + BYSECOND (list-of (integer 0 60)) + BYMINUTE (list-of (integer 0 59)) + BYHOUR (list-of (integer 0 23)) + BYDAY (list-of (or (integer 0 6) (satisfies ical:dayno-offset-p))) + BYMONTHDAY (list-of (or (integer -31 -1) (integer 1 31))) + BYYEARDAY (list-of (or (integer -366 -1) (integer 1 366))) + BYWEEKNO (list-of (or (integer -53 -1) (integer 1 53))) + BYMONTH (list-of (integer 1 12)) ; unlike the others, months cannot be negative + BYSETPOS (list-of (or (integer -366 -1) (integer 1 366))) + WKST (integer 0 6)) + "Plist mapping `icalendar-recur' keywords to type specifiers.") + +(defun ical:dayno-offset-p (val) + "Return non-nil if VAL is a pair (DAYNO . OFFSET). +DAYNO must be in [0..6] and OFFSET in [-53..53], excluding 0." + (and (consp val) + (cl-typep (car val) '(integer 0 6)) + (cl-typep (cdr val) '(or (integer -53 -1) (integer 1 53))))) + +(defun ical:recur-value-p (vals) + "Return non-nil if VALS is an iCalendar recurrence rule value." + (and (listp vals) + ;; FREQ is always required: + (assq 'FREQ vals) + ;; COUNT and UNTIL are mutually exclusive if present: + (not (and (assq 'COUNT vals) (assq 'UNTIL vals))) + ;; If BYSETPOS is present, another BYXXX clause must be too: + (or (not (assq 'BYSETPOS vals)) + (assq 'BYMONTH vals) + (assq 'BYWEEKNO vals) + (assq 'BYYEARDAY vals) + (assq 'BYMONTHDAY vals) + (assq 'BYDAY vals) + (assq 'BYHOUR vals) + (assq 'BYMINUTE vals) + (assq 'BYSECOND vals)) + (let ((freq (ical:recur-freq vals)) + (byday (ical:recur-by* 'BYDAY vals)) + (byweekno (ical:recur-by* 'BYWEEKNO vals)) + (bymonthday (ical:recur-by* 'BYMONTHDAY vals)) + (byyearday (ical:recur-by* 'BYYEARDAY vals))) + (and + ;; "The BYDAY rule part MUST NOT be specified with a numeric + ;; value when the FREQ rule part is not set to MONTHLY or + ;; YEARLY." + (or (not (consp (car byday))) + (memq freq '(MONTHLY YEARLY))) + ;; "The BYDAY rule part MUST NOT be specified with a numeric + ;; value with the FREQ rule part set to YEARLY when the + ;; BYWEEKNO rule part is specified." This also covers: + ;; "[The BYWEEKNO] rule part MUST NOT be used when the FREQ + ;; rule part is set to anything other than YEARLY." + (or (not byweekno) + (and (eq freq 'YEARLY) + (not (consp (car byday))))) + ;; "The BYMONTHDAY rule part MUST NOT be specified when the + ;; FREQ rule part is set to WEEKLY." + (not (and bymonthday (eq freq 'WEEKLY))) + ;; "The BYYEARDAY rule part MUST NOT be specified when the + ;; FREQ rule part is set to DAILY, WEEKLY, or MONTHLY." + (not (and byyearday (memq freq '(DAILY WEEKLY MONTHLY)))))) + ;; check types of all rule parts: + (seq-every-p + (lambda (kv) + (when (consp kv) + (let* ((keyword (car kv)) + (val (cadr kv)) + (type (plist-get ical:-recur-value-types keyword))) + (and keyword val type + (if (and (consp type) + (eq (car type) 'list-of)) + (ical:list-of-p val (cadr type)) + (cl-typep val type)))))) + vals))) + +(ical:define-type ical:recur "RECUR" + "Type for Recurrence Rule values. + +When printed, a recurrence rule value looks like + KEY1=VAL1;KEY2=VAL2;... +where the VALs may themselves be lists or have other syntactic +structure; see RFC5545 sec. 3.3.10 for all the details. + +The KEYs and their associated value types when read are as follows. +The first is required: + '(FREQ (member YEARLY MONTHLY WEEKLY DAILY HOURLY MINUTELY SECONDLY) +These two are mutually exclusive; at most one may appear: + UNTIL (or icalendar-date-time icalendar-date) + COUNT (integer 1 *) +All others are optional: + INTERVAL (integer 1 *) + BYSECOND (list-of (integer 0 60)) + BYMINUTE (list-of (integer 0 59)) + BYHOUR (list-of (integer 0 23)) + BYDAY (list-of (or (integer 0 6) ; day of week + (pair (integer 0 6) ; (day of week . offset) + (integer -53 53))) ; except 0 + BYMONTHDAY (list-of (integer -31 31)) ; except 0 + BYYEARDAY (list-of (integer -366 366)) ; except 0 + BYWEEKNO (list-of (integer -53 53)) ; except 0 + BYMONTH (list-of (integer 1 12)) ; months cannot be negative + BYSETPOS (list-of (integer -366 366)) ; except 0 + WKST (integer 0 6)) + +When read, these KEYs and their associated VALs are gathered into +an alist. + +In general, the VALs consist of integers or lists of integers. +Abbreviations for weekday names are translated into integers +0 (=Sunday) through 6 (=Saturday), for compatibility with +calendar.el and decoded-time-* functions. + +Some examples: + +1) Printed: FREQ=DAILY;COUNT=10;INTERVAL=2 + Meaning: 10 occurrences that occur every other day + Read: ((FREQ DAILY) + (COUNT 10) + (INTERVAL 2)) + +2) Printed: FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA + Meaning: Every day in January of every year until 2000/01/31 at 14:00 UTC + Read: ((FREQ YEARLY) + (UNTIL (0 0 14 31 1 2000 1 -1 0)) + (BYMONTH (1)) + (BYDAY (0 1 2 3 4 5 6))) + +3) Printed: FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2 + Meaning: Every month on the second-to-last weekday of the month + Read: ((FREQ MONTHLY) + (BYDAY (1 2 3 4 5)) + (BYSETPOS (-2))) + +Notice that singleton values are still wrapped in a list when the +KEY accepts a list of values, but not when the KEY always has a +single (e.g. integer) value." + '(satisfies ical:recur-value-p) + (ical:semicolon-list ical:recur-rule-part) + :reader ical:read-recur + :printer ical:print-recur + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.10") + +(defun ical:recur-freq (recur-value) + "Return the frequency in RECUR-VALUE." + (car (alist-get 'FREQ recur-value))) + +(defun ical:recur-interval-size (recur-value) + "Return the interval size in RECUR-VALUE, or the default of 1." + (or (car (alist-get 'INTERVAL recur-value)) 1)) + +(defun ical:recur-until (recur-value) + "Return the UNTIL date(-time) in RECUR-VALUE." + (car (alist-get 'UNTIL recur-value))) + +(defun ical:recur-count (recur-value) + "Return the COUNT in RECUR-VALUE." + (car (alist-get 'COUNT recur-value))) + +(defun ical:recur-weekstart (recur-value) + "Return the weekday which starts the work week in RECUR-VALUE. +If no starting weekday is specified in RECUR-VALUE, returns the default, +1 (= Monday)." + (or (car (alist-get 'WKST recur-value)) 1)) + +(defun ical:recur-by* (byunit recur-value) + "Return the values in the BYUNIT clause in RECUR-VALUE. +BYUNIT should be a symbol: \\='BYMONTH, \\='BYDAY, etc. +See `icalendar-recur' for all the possible BYUNIT values." + (car (alist-get byunit recur-value))) + +;;;; 3.3.11 Text +(rx-define ical:escaped-char + (seq ?\\ (or ?\\ ?\; ?, ?N ?n))) + +(rx-define ical:text-safe-char + ;; "Any character except CONTROLs not needed by the current character + ;; set, DQUOTE, ";", ":", "\", "," " + (any #x09 #x20 #x21 ; htab, space, and "!" + (#x23 . #x2B) (#x2D . #x39) ; "#".."9" skipping #x2C="," + (#x3C . #x5B) (#x5D . #x7E) ; "<".."~" skipping #x5C="\" + nonascii)) + +(defun ical:text-region-p (val) + "Return t if VAL represents a region of text." + (and (listp val) + (markerp (car val)) + (not (null (marker-buffer (car val)))) + (markerp (cdr val)))) + +(defun ical:make-text-region (&optional buffer begin end) + "Return an object that represents a region of text. +The region is taken from BUFFER between BEGIN and END. BUFFER defaults +to the current buffer, and BEGIN and END default to point and mark in +BUFFER." + (let ((buf (or buffer (current-buffer))) + (b (make-marker)) + (e (make-marker))) + (with-current-buffer buf + (set-marker b (or begin (region-beginning)) buf) + (set-marker e (or end (region-end))) + (cons b e)))) + +(defsubst ical:text-region-begin (r) + "Return the marker at the beginning of the text region R." + (car r)) + +(defsubst ical:text-region-end (r) + "Return the marker at the end of the text region R." + (cdr r)) + +(defun ical:unescape-text-in-region (begin end) + "Unescape the text between BEGIN and END. +Unescaping replaces literal '\\n' and '\\N' with newline, and removes +backslashes that escape commas, semicolons, and backslashes." + (with-restriction begin end + (save-excursion + (replace-string-in-region "\\N" "\n" (point-min) (point-max)) + (replace-string-in-region "\\n" "\n" (point-min) (point-max)) + (replace-string-in-region "\\," "," (point-min) (point-max)) + (replace-string-in-region "\\;" ";" (point-min) (point-max))) + (replace-string-in-region (concat "\\" "\\") "\\" (point-min) (point-max)))) + +(defun ical:unescape-text-string (s) + "Unescape the text in string S. +Unescaping replaces literal '\\n' and '\\N' with newline, and removes +backslashes that escape commas, semicolons, and backslashes." + (with-temp-buffer + (insert s) + (ical:unescape-text-in-region (point-min) (point-max)) + (buffer-string))) + +(defun ical:escape-text-in-region (begin end) + "Escape the text between BEGIN and END in the current buffer. +Escaping replaces newlines with literal '\\n', and escapes commas, +semicolons and backslashes with a backslash." + (with-restriction begin end + (save-excursion + ;; replace backslashes first, so the ones introduced when + ;; escaping other characters don't end up double-escaped: + (replace-string-in-region "\\" (concat "\\" "\\") (point-min) (point-max)) + (replace-string-in-region "\n" "\\n" (point-min) (point-max)) + (replace-string-in-region "," "\\," (point-min) (point-max)) + (replace-string-in-region ";" "\\;" (point-min) (point-max))))) + +(defun ical:escape-text-string (s) + "Escape the text in string S. +Escaping replaces newlines with literal '\\n', and escapes commas, +semicolons and backslashes with a backslash." + (with-temp-buffer + (insert s) + (ical:escape-text-in-region (point-min) (point-max)) + (buffer-string))) + +(defun ical:read-text (s) + "Read an `icalendar-text' value from a string S. +S should be a match against rx `icalendar-text'." + (ical:unescape-text-string s)) + +(defun ical:print-text (val) + "Serialize an iCalendar text value. +VAL may be a string or text region (see `icalendar-make-text-region'). +The text will be escaped before printing. If VAL is a region, the text +it contains will not be modified; it is copied before escaping." + (if (stringp val) + (ical:escape-text-string val) + ;; val is a region, so copy and escape its contents: + (let* ((beg (ical:text-region-begin val)) + (buf (marker-buffer beg)) + (end (ical:text-region-end val))) + (with-temp-buffer + (insert-buffer-substring buf (marker-position beg) (marker-position end)) + (ical:escape-text-in-region (point-min) (point-max)) + (buffer-string))))) + +(defun ical:text-to-string (node) + "Return the value of an `icalendar-text' NODE as a string. +The returned string is *not* escaped. For that, see `icalendar-print-text'." + (ical:with-node-value node nil + (if (stringp value) value + ;; Otherwise the value is a text region: + (let* ((beg (ical:text-region-begin value)) + (buf (marker-buffer beg)) + (end (ical:text-region-end value))) + (with-current-buffer buf + (buffer-substring (marker-position beg) (marker-position end))))))) + +;; TODO: would it be useful to add a third representation, namely a +;; function or thunk? So that e.g. Org can pre-process its own syntax +;; and return a plain text string to use in the description? +(ical:define-type ical:text "TEXT" + "Type for Text values. + +Text values can be represented in Elisp in two ways: as strings, +or as buffer regions. For values which aren't expected to change, +such as property values in a text/calendar email attachment, use +strings. For values which are user-editable and might change +between parsing and serializing to iCalendar format, use a +region. In that case, a text value contains two markers BEGIN and +END which mark the bounds of the region. See +`icalendar-make-text-region' to create such values, and +`icalendar-text-region-begin' and `icalendar-text-region-end' to +access the markers. + +Certain characters in text values are required to be escaped by +the iCalendar standard. These characters should NOT be +pre-escaped when inserting them into the parse tree. Instead, +`icalendar-print-text' takes care of escaping text values, and +`icalendar-read-text' takes care of unescaping them, when parsing and +printing iCalendar data." + '(or string (satisfies ical:text-region-p)) + (zero-or-more (or ical:text-safe-char ?: ?\" ical:escaped-char)) + :reader ical:read-text + :printer ical:print-text + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.11") + +;; 3.3.12 Time - Defined above + +;;;; 3.3.13 URI +;; see https://www.rfc-editor.org/rfc/rfc3986#section-3 +(rx-define ical:uri-with-scheme + ;; Group 11: URI scheme; see icalendar-uri-schemes.el + ;; Group 12: rest of URI after ":" + ;; This regex mostly just scans for all characters allowed by RFC3986, + ;; except we make an effort to parse the scheme, because otherwise the + ;; regex is either too permissive (ical:binary, in particular, matches + ;; a subset of the characters allowed in a URI) or too complicated to + ;; be useful. + ;; TODO: use url-parse.el to parse to struct? + (seq (group-n 11 (any "a-zA-Z") (zero-or-more (any ?- ?+ ?. "A-Za-z0-9"))) + ":" + (group-n 12 + (one-or-more + (any "A-Za-z0-9" ?- ?. ?_ ?~ ; unreserved chars + ?: ?/ ?? ?# ?\[ ?\] ?@ ; gen-delims + ?! ?$ ?& ?' ?\( ?\) ?* ?+ ?, ?\; ?= ; sub-delims + ?%))))) ; for %-encoding + +(ical:define-type ical:uri "URI" + "Type for URI values. + +The parsed and printed representations are the same: a URI string." + '(satisfies ical:match-uri-value) + ical:uri-with-scheme + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.13") + +;;;; 3.3.3 Calendar User Address +(ical:define-type ical:cal-address "CAL-ADDRESS" + "Type for Calendar User Address values. + +The parsed and printed representations are the same: a URI string. +Typically, this should be a mailto: URI. + +RFC5545 says: '*When used to address an Internet email transport + address* for a calendar user, the value MUST be a mailto URI, + as defined by [RFC2368]' + +Since it is unclear whether there are Calendar User Address values +which are not used to address email, this type does not enforce the use +of the mailto: scheme, but be prepared for problems if you create +values of this type with any other scheme." + '(and string (satisfies ical:match-cal-address-value)) + ical:uri-with-scheme + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.3") + +;;;; 3.3.14 UTC Offset +(defun ical:read-utc-offset (s) + "Read a UTC offset from a string. +S should be a match against rx `icalendar-utc-offset'" + (let ((sign (if (equal (substring s 0 1) "-") -1 1)) + (nhours (string-to-number (substring s 1 3))) + (nminutes (string-to-number (substring s 3 5))) + (nseconds (if (length= s 7) + (string-to-number (substring s 5 7)) + 0))) + (* sign (+ nseconds (* 60 nminutes) (* 60 60 nhours))))) + +(defun ical:print-utc-offset (utcoff) + "Serialize a UTC offset to a string." + (let* ((sign (if (< utcoff 0) "-" "+")) + (absoff (abs utcoff)) + (nhours (/ absoff (* 60 60))) + (no-hours (mod absoff (* 60 60))) + (nminutes (/ no-hours 60)) + (nseconds (mod no-hours 60))) + (if (zerop nseconds) + (format "%s%02d%02d" sign nhours nminutes) + (format "%s%02d%02d%02d" sign nhours nminutes nseconds)))) + +(ical:define-type ical:utc-offset "UTC-OFFSET" + "Type for UTC Offset values. + +When printed, a sign followed by a string of digits, like +HHMM +or -HHMMSS. When read, an integer representing the number of +seconds offset from UTC. This representation is for compatibility +with `decode-time' and related functions." + '(integer -999999 999999) + (seq (or ?+ ?-) ; + is not optional for positive values! + (= 4 digit) ; HHMM + (zero-or-one (= 2 digit))) ; SS + :reader ical:read-utc-offset + :printer ical:print-utc-offset + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.14") + + +;;; Section 3.2: Property Parameters + +(defconst ical:param-types nil ;; populated by ical:define-param + "Alist mapping printed parameter names to type symbols.") + +(defun ical:maybe-quote-param-value (s &optional always) + "Add quotes around param value string S if required. +If ALWAYS is non-nil, add quotes to S regardless of its contents." + (if (or always + (not (string-match (rx ical:paramtext) s)) + (< (match-end 0) (length s))) + (concat "\"" s "\"") + s)) + +(defun ical:read-param-value (type s) + "Read a value for a parameter of type TYPE from a string S. +S should have already been matched against the regex for TYPE and +the match data should be available to this function. Returns a +syntax node of type TYPE containing the read value. + +If TYPE accepts a list of values, S will be split on the list +separator for TYPE and read individually." + (let* ((value-type (get type 'ical:value-type)) ; if nil, value is just a string + (value-regex (when (get type 'ical:value-rx) + (rx-to-string (get type 'ical:value-rx)))) + (list-sep (get type 'ical:list-sep)) + (substitute-val (get type 'ical:substitute-value)) + (unrecognized-val (match-string 5)) ; see :unrecognized in define-param + (raw-val (if unrecognized-val substitute-val s)) + (one-val-reader (if (ical:value-type-symbol-p value-type) + (lambda (s) (ical:read-value-node value-type s)) + #'identity)) ; value is just a string + ;; values may be quoted even if :quoted does not require it, + ;; so they need to be stripped of quotes. read-list-with does + ;; this by default; in the single value case, use string-trim + (read-val (if list-sep + (ical:read-list-with one-val-reader raw-val + value-regex list-sep) + (funcall one-val-reader + (string-trim raw-val "\"" "\""))))) + (ical:make-ast-node type + (list :value read-val + :original-value unrecognized-val)))) + +(defun ical:parse-param-value (type limit) + "Parse the value for a parameter of type TYPE from point up to LIMIT. +TYPE should be a type symbol for an iCalendar parameter type. +This function expects point to be at the start of the value +string, after the parameter name and the equals sign. Returns a +syntax node representing the parameter." + (let ((full-value-regex (rx-to-string (get type 'ical:full-value-rx)))) + ;; By far the most common invalid data seem to be text values that + ;; contain unescaped characters (e.g. commas in addresses). These + ;; are harmless as long as the parameter accepts arbitrary text and + ;; does not expect a list of values. The only such parameter + ;; defined in RFC5545 is `ical:cnparam', so we treat this as a + ;; special case and loosen the official regexp to accept anything up + ;; to the start of the next param or property value: + (when (and (eq type 'ical:cnparam) + (not ical:parse-strictly)) + (setq full-value-regex + (rx (group-n 2 (or ical:quoted-string + (zero-or-more (not (any ?: ?\;)))))))) + + (unless (re-search-forward full-value-regex limit t) + (ical:signal-parse-error + (format "Unable to parse `%s' value between %d and %d" + type (point) limit))) + (when (match-string 3) + (ical:signal-parse-error + (format "Invalid value for `%s' parameter: %s" type (match-string 3)))) + + (let ((value-begin (match-beginning 2)) + (value-end (match-end 2)) + (node (ical:read-param-value type (match-string 2)))) + (ical:ast-node-meta-set node :buffer (current-buffer)) + ;; :begin must be set by parse-params + (ical:ast-node-meta-set node :value-begin value-begin) + (ical:ast-node-meta-set node :value-end value-end) + (ical:ast-node-meta-set node :end value-end) + + node))) + +(defun ical:parse-params (limit) + "Parse the parameter string of the current property, up to LIMIT. +Point should be at the \";\" at the start of the first parameter. +Returns a list of parameters, which may be nil if none are present. +After parsing, point is at the end of the parameter string and the +start of the property value string." + (let (params param-node) + (rx-let ((ical:param-start (seq ";" (group-n 1 ical:param-name) "="))) + (while (re-search-forward (rx ical:param-start) limit t) + (when-let* ((begin (match-beginning 1)) + (param-name (match-string 1)) + (param-type (alist-get (upcase param-name) + ical:param-types + 'ical:otherparam + nil #'equal))) + (condition-case err + (setq param-node (ical:parse-param-value param-type limit)) + (ical:parse-error + (ical:handle-parse-error err (format "Skipping bad %s parameter" + param-name)) + (setq param-node nil))) + (when param-node + (ical:ast-node-meta-set param-node :begin begin) + ;; store the original param name if we didn't recognize it: + (when (eq param-type 'ical:otherparam) + (ical:ast-node-meta-set param-node :original-name param-name)) + (push param-node params)))) + (nreverse params)))) + +(defun ical:print-param-node (node) + "Serialize a parameter syntax node NODE to a string. +NODE should be a syntax node whose type is an iCalendar +parameter type." + (let* ((param-type (ical:ast-node-type node)) + (param-name (car (rassq param-type ical:param-types))) + (name-str (or param-name + ;; set by parse-params for unrecognized params: + (ical:ast-node-meta-get :original-name node)))) + + (unless (and name-str (stringp name-str) (not (equal name-str ""))) + (ical:signal-print-error "No printable parameter name" :node node)) + + (let* ((list-sep (get param-type 'ical:list-sep)) + (val/s (ical:ast-node-value node)) + (vals (if (and list-sep (listp val/s)) + val/s + (list val/s))) + ;; any ical:print-error here propagates: + (printed (mapcar #'ical:default-value-printer vals)) + ;; add quotes to each value as needed, even if :quoted + ;; does not require it: + (must-quote (get param-type 'ical:is-quoted)) + (quoted (mapcar + (lambda (v) (ical:maybe-quote-param-value v must-quote)) + printed)) + (val-str (or (ical:ast-node-meta-get :original-value node) + (string-join quoted list-sep) + quoted))) + + (unless (and (stringp val-str) (not (equal val-str ""))) + (ical:signal-print-error "Unable to print parameter value" :node node)) + + (format ";%s=%s" name-str val-str)))) + +(defun ical:print-params (param-nodes) + "Print the property parameter nodes in PARAM-NODES. +Returns the printed parameter list as a string." + (let (param-strs) + (dolist (node param-nodes) + (condition-case err + (push (ical:print-param-node node) param-strs) + (ical:print-error + (ical:handle-print-error err)))) + (apply #'concat (nreverse param-strs)))) + +;; Parameter definitions in RFC5545: + +(ical:define-param ical:altrepparam "ALTREP" + "Alternate text representation (URI)" + ical:uri + :quoted t + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.1") + +(ical:define-param ical:cnparam "CN" + "Common Name" + ical:param-value + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.2") + +(ical:define-param ical:cutypeparam "CUTYPE" + "Calendar User Type" + (or "INDIVIDUAL" + "GROUP" + "RESOURCE" + "ROOM" + "UNKNOWN" + (group-n 5 + (or ical:x-name ical:iana-token))) + :default "INDIVIDUAL" + ;; "Applications MUST treat x-name and iana-token values they + ;; don't recognize the same way as they would the UNKNOWN + ;; value": + :unrecognized "UNKNOWN" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.3") + +(ical:define-param ical:delfromparam "DELEGATED-FROM" + "Delegators. + +This is a comma-separated list of quoted `icalendar-cal-address' URIs, +typically specified on the `icalendar-attendee' property. The users in +this list have delegated their participation to the user which is +the value of the property." + ical:cal-address + :quoted t + :list-sep "," + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.4") + +(ical:define-param ical:deltoparam "DELEGATED-TO" + "Delegatees. + +This is a comma-separated list of quoted `icalendar-cal-address' URIs, +typically specified on the `icalendar-attendee' property. The users in +this list have been delegated to participate by the user which is +the value of the property." + ical:cal-address + :quoted t + :list-sep "," + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.5") + +(ical:define-param ical:dirparam "DIR" + "Directory Entry Reference. + +This parameter may be specified on properties with a +`icalendar-cal-address' value type. It is a quoted URI which specifies +a reference to a directory entry associated with the calendar +user which is the value of the property." + ical:uri + :quoted t + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.6") + +(ical:define-param ical:encodingparam "ENCODING" + "Inline Encoding, either \"8BIT\" (text, default) or \"BASE64\" (binary). + +If \"BASE64\", the property value is base64-encoded binary data. +This parameter must be specified if the `icalendar-valuetypeparam' +is \"BINARY\"." + (or "8BIT" "BASE64") + :default "8BIT" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.7") + +(rx-define ical:mimetype + (seq ical:mimetype-regname "/" ical:mimetype-regname)) + +;; from https://www.rfc-editor.org/rfc/rfc4288#section-4.2: +(rx-define ical:mimetype-regname + (** 1 127 (any "A-Za-z0-9" ?! ?# ?$ ?& ?. ?+ ?- ?^ ?_))) + +(ical:define-param ical:fmttypeparam "FMTTYPE" + "Format Type (Mimetype per RFC4288) + +Specifies the media type of the object referenced in the property value, +for example \"text/plain\" or \"text/html\". +Valid media types are defined in RFC4288; see +URL `https://www.rfc-editor.org/rfc/rfc4288#section-4.2'" + ical:mimetype + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.8") + +(ical:define-param ical:fbtypeparam "FBTYPE" + "Free/Busy Time Type. Default is \"BUSY\". + +RFC5545 gives the following meanings to the values: + +FREE: the time interval is free for scheduling. +BUSY: the time interval is busy because one or more events have + been scheduled for that interval. +BUSY-UNAVAILABLE: the time interval is busy and the interval + can not be scheduled. +BUSY-TENTATIVE: the time interval is busy because one or more + events have been tentatively scheduled for that interval. +Other values are treated like BUSY." + (or "FREE" + "BUSY-UNAVAILABLE" + "BUSY-TENTATIVE" + "BUSY" + ical:x-name + ical:iana-token) + :default "BUSY" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.9") + +;; TODO: see https://www.rfc-editor.org/rfc/rfc5646#section-2.1 +(rx-define ical:rfc5646-lang + (one-or-more (any "A-Za-z0-9" ?-))) + +(ical:define-param ical:languageparam "LANGUAGE" + "Language tag (per RFC5646) + +This parameter specifies the language of the property value as a +language tag, for example \"en-US\" for US English or \"no\" for +Norwegian. Valid language tags are defined in RFC5646; see +URL `https://www.rfc-editor.org/rfc/rfc5646'" + ical:rfc5646-lang + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.10") + +(ical:define-param ical:memberparam "MEMBER" + "Group or List Membership. + +This is a comma-separated list of quoted `icalendar-cal-address' +values. These are addresses of groups or lists of which the user +in the property value is a member." + ical:cal-address + :quoted t + :list-sep "," + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.11") + +(ical:define-param ical:partstatparam "PARTSTAT" + "Participation status. + +The value specifies the participation status of the calendar user +in the property value. They have different interpretations +depending on whether they occur in a VEVENT, VTODO or VJOURNAL +component. RFC5545 gives the values the following meanings: + +NEEDS-ACTION (all): needs action by the user +ACCEPTED (all): accepted by the user +DECLINED (all): declined by the user +TENTATIVE (VEVENT, VTODO): tentatively accepted by the user +DELEGATED (VEVENT, VTODO): delegated by the user +COMPLETED (VTODO): completed at the `icalendar-date-time' in the + VTODO's `icalendar-completed' property +IN-PROCESS (VTODO): in the process of being completed" + (or "NEEDS-ACTION" + "ACCEPTED" + "DECLINED" + "TENTATIVE" + "DELEGATED" + "COMPLETED" + "IN-PROCESS" + (group-n 5 (or ical:x-name + ical:iana-token))) + ;; "Applications MUST treat x-name and iana-token values + ;; they don't recognize the same way as they would the + ;; NEEDS-ACTION value." + :default "NEEDS-ACTION" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.12") + +(ical:define-param ical:rangeparam "RANGE" + "Recurrence Identifier Range. + +Specifies the effective range of recurrence instances of the property's value. +The value \"THISANDFUTURE\" is the only value compliant with RFC5545; +legacy applications might also produce \"THISANDPRIOR\"." + "THISANDFUTURE" + :default "THISANDFUTURE" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.13") + +(ical:define-param ical:trigrelparam "RELATED" + "Alarm Trigger Relationship. + +This parameter may be specified on properties whose values give +an alarm trigger as an `icalendar-duration'. If the parameter +value is \"START\" (the default), the alarm triggers relative to +the start of the component; similarly for \"END\"." + (or "START" "END") + :default "START" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.14") + +(ical:define-param ical:reltypeparam "RELTYPE" + "Relationship type. + +This parameter specifies a hierarchical relationship between the +calendar component referenced in a `icalendar-related-to' +property and the calendar component in which it occurs. +\"PARENT\" means the referenced component is superior to this +one, \"CHILD\" that the referenced component is subordinate to +this one, and \"SIBLING\" means they are peers." + (or "PARENT" + "CHILD" + "SIBLING" + (group-n 5 (or ical:x-name + ical:iana-token))) + ;; "Applications MUST treat x-name and iana-token values they don't + ;; recognize the same way as they would the PARENT value." + :default "PARENT" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.15") + +(ical:define-param ical:roleparam "ROLE" + "Participation role. + +This parameter specifies the participation role of the calendar +user in the property value. RFC5545 gives the parameter values +the following meanings: +CHAIR: chair of the calendar entity +REQ-PARTICIPANT (default): user's participation is required +OPT-PARTICIPANT: user's participation is optional +NON-PARTICIPANT: user is copied for information purposes only" + (or "CHAIR" + "REQ-PARTICIPANT" + "OPT-PARTICIPANT" + "NON-PARTICIPANT" + (group-n 5 (or ical:x-name + ical:iana-token))) + ;; "Applications MUST treat x-name and iana-token values + ;; they don't recognize the same way as they would the + ;; REQ-PARTICIPANT value." + :default "REQ-PARTICIPANT" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.16") + +(ical:define-param ical:rsvpparam "RSVP" + "RSVP expectation. + +This parameter is an `icalendar-boolean' which specifies whether +the calendar user in the property value is expected to reply to +the Organizer of a VEVENT or VTODO." + ical:boolean + :default "FALSE" + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.17") + +(ical:define-param ical:sentbyparam "SENT-BY" + "Sent by. + +This parameter specifies a calendar user that is acting on behalf +of the user in the property value." + ;; "The parameter value MUST be a mailto URI as defined in [RFC2368]" + ;; Weirdly, this is the only place in the standard I've seen "mailto:" + ;; be *required* for a cal-address. We ignore this requirement because + ;; coding around the exception is not worth it: it requires working + ;; around the fact that two different types, the looser and the more + ;; stringent cal-address, would need to have the same print name. + ical:cal-address + :quoted t + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.18") + +(ical:define-param ical:tzidparam "TZID" + "Time Zone identifier. + +This parameter identifies the VTIMEZONE component in the calendar +which should be used to interpret the time value given in the +property. The value of this parameter must be equal to the value +of the TZID property in that VTIMEZONE component; there must be +exactly one such component for every unique value of this +parameter in the calendar." + (seq (zero-or-one "/") ical:paramtext) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.19") + +(defun ical:read-value-type (s) + "Read a value type from string S. +S should contain the printed representation of a value type in a \"VALUE=...\" +property parameter. If S represents a known type in `icalendar-value-types', +it is read as the associated type symbol. Otherwise S is returned unchanged." + (let ((type-assoc (assoc s ical:value-types))) + (if type-assoc + (cdr type-assoc) + s))) + +(defun ical:print-value-type (type) + "Print a value type TYPE. +TYPE should be an iCalendar type symbol naming a known value type +defined with `icalendar-define-type', or a string naming an +unknown type. If it is a symbol, return the associated printed +representation for the type from `icalendar-value-types'. +Otherwise return TYPE." + (if (symbolp type) + (car (rassq type ical:value-types)) + type)) + +(ical:define-type ical:printed-value-type nil + "Type to represent values of the `icalendar-valuetypeparam' parameter. + +When read, if the type named by the parameter is a known value +type in `icalendar-value-types', it is represented as a type +symbol for that value type. If it is an unknown value type, it is +represented as a string. When printed, a string is returned +unchanged; a type symbol is printed as the associated name in +`icalendar-value-types'. + +This is not a type defined by RFC5545; it is defined here to +facilitate parsing of the `icalendar-valuetypeparam' parameter." + '(or string (satisfies ical:printable-value-type-symbol-p)) + (or "BINARY" + "BOOLEAN" + "CAL-ADDRESS" + "DATE-TIME" + "DATE" + "DURATION" + "FLOAT" + "INTEGER" + "PERIOD" + "RECUR" + "TEXT" + "TIME" + "URI" + "UTC-OFFSET" + ;; Note: "Applications MUST preserve the value data for x-name + ;; and iana-token values that they don't recognize without + ;; attempting to interpret or parse the value data." So in this + ;; case we don't specify :default or :unrecognized in the + ;; parameter definition, and we don't put the value in group 5; + ;; the reader will just preserve whatever string matches here. + ical:x-name + ical:iana-token) + :reader ical:read-value-type + :printer ical:print-value-type) + +(ical:define-param ical:valuetypeparam "VALUE" + "Property value data type. + +This parameter is used to specify the value type of the +containing property's value, if it is not of the default value +type." + ical:printed-value-type + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.2.20") + +(ical:define-param ical:otherparam nil ; don't add to ical:param-types + "Parameter with an unknown name. + +This is not a parameter type defined by RFC5545; it represents +parameters with an unknown name (matching rx `icalendar-param-name') +whose values must be parsed and preserved but not further +interpreted." + ical:param-value) + +(rx-define ical:other-param-safe + ;; we use this rx to skip params when matching properties and + ;; their values. Thus we *don't* capture the param names and param values + ;; in numbered groups here, which would clobber the groups of the enclosing + ;; expression. + (seq ";" + (or ical:iana-token ical:x-name) + "=" + (ical:comma-list ical:param-value))) + + +;;; Properties: + +(defconst ical:property-types nil ;; populated by ical:define-property + "Alist mapping printed property names to type symbols.") + +(defun ical:read-property-value (type s &optional params) + "Read a value for the property type TYPE from a string S. + +TYPE should be a type symbol for an iCalendar property type +defined with `icalendar-define-property'. The property value is +assumed to be of TYPE's default value type, unless an +`icalendar-valuetypeparam' parameter appears in PARAMS, in which +case a value of that type will be read. S should have already +been matched against TYPE's value regex and the match data should +be available to this function. Returns a property syntax node of +type TYPE containing the read value and the list of PARAMS. + +If TYPE accepts lists of values, they will be split from S on the +list separator and read separately." + (let* ((value-type (or (ical:value-type-from-params params) + (get type 'ical:default-type))) + (list-sep (get type 'ical:list-sep)) + (unrecognized-val (match-string 5)) + (raw-val (if unrecognized-val + (get type 'ical:substitute-value) + s)) + (value (if list-sep + (ical:read-list-of value-type raw-val list-sep) + (ical:read-value-node value-type raw-val)))) + (ical:make-ast-node type + (list :value value + :original-value unrecognized-val) + params))) + +(defun ical:parse-property-value (type limit &optional params) + "Parse a value for the property type TYPE from point up to LIMIT. +This function expects point to be at the start of the value +expression, after \"PROPERTY-NAME[PARAM...]:\". Returns a syntax +node of type TYPE containing the parsed value and the list of +PARAMS." + (let ((start (point)) + (full-value-regex (rx-to-string (get type 'ical:full-value-rx)))) + + ;; By far the most common invalid data seem to be text values that + ;; contain unescaped characters (e.g. commas in addresses in + ;; LOCATION). These are harmless as long as the property accepts + ;; any text value, accepts no other types of values, and does not + ;; expect a list of values. So we treat this as a special case and + ;; loosen the regexp to accept any non-control character until eol: + (when (and (eq 'ical:text (get type 'ical:default-type)) + (equal (rx-to-string 'ical:text t) + (rx-to-string (get type 'ical:value-rx) t)) + (null (get type 'ical:other-types)) + (not (ical:expects-list-of-values-p type)) + (not ical:parse-strictly)) + (setq full-value-regex + (rx (group-n 2 (zero-or-more (not (any control)))) + line-end))) + + (unless (re-search-forward full-value-regex limit t) + (ical:signal-parse-error + (format "Unable to parse `%s' property value between %d and %d" + type start limit) + :restart-at (1+ limit))) + + (when (match-string 3) + (ical:signal-parse-error + (format "Invalid value for `%s' property: %s" type (match-string 3)) + :restart-at (1+ limit))) + + (let* ((value-begin (match-beginning 2)) + (value-end (match-end 2)) + (end value-end) + (node (ical:read-property-value type (match-string 2) params))) + (ical:ast-node-meta-set node :buffer (current-buffer)) + ;; 'begin must be set by parse-property + (ical:ast-node-meta-set node :value-begin value-begin) + (ical:ast-node-meta-set node :value-end value-end) + (ical:ast-node-meta-set node :end end) + + node))) + +(defun ical:print-property-node (node) + "Serialize a property syntax node NODE to a string." + (setq node (ical:maybe-add-value-param node)) + (let* ((type (ical:ast-node-type node)) + (list-sep (get type 'ical:list-sep)) + (property-name (car (rassq type ical:property-types))) + (name-str (or property-name + (ical:ast-node-meta-get :original-name node))) + (params (ical:ast-node-children node)) + (value (ical:ast-node-value node)) + (value-str + (or (ical:ast-node-meta-get :original-value node) + ;; any ical:print-error here propagates: + (if list-sep + (string-join (mapcar #'ical:default-value-printer value) + list-sep) + (ical:default-value-printer value))))) + + (unless (and (stringp name-str) (length> name-str 0)) + (ical:signal-print-error + (format "Unknown property name for type `%s'" type) + :node node)) + + (concat name-str + (ical:print-params params) + ":" + value-str + "\n"))) + +(defun ical:maybe-add-value-param (property-node) + "Add a VALUE parameter to PROPERTY-NODE if necessary. + +If the type of PROPERTY-NODE's value is not the same as its +default-type, check that its parameter list contains an +`icalendar-valuetypeparam' specifying that type as the type for +the value. If not, add such a parameter to PROPERTY-NODE's list +of parameters. Returns the possibly-modified PROPERTY-NODE. + +If the parameter list already contains a value type parameter for +a type other than the property value's type, an +`icalendar-validation-error' is signaled. + +If PROPERTY's value is a list, the type of the first element will +be assumed to be the type for all the values in the list. If the +list is empty, no change will be made to PROPERTY's parameters." + (catch 'no-value-type + (let* ((property-type (ical:ast-node-type property-node)) + (value/s (ical:ast-node-value property-node)) + (value (if (and (ical:expects-list-of-values-p property-type) + (listp value/s)) + (car value/s) + value/s)) + (value-type (cond ((stringp value) 'ical:text) + ((ical:ast-node-p value) + (ical:ast-node-type value)) + ;; if we can't determine a type from the value, bail: + (t (throw 'no-value-type property-node)))) + (params (ical:ast-node-children property-node)) + (expected-type (ical:value-type-from-params params))) + + (when (not (eq value-type (get property-type 'ical:default-type))) + (if expected-type + (when (not (eq value-type expected-type)) + (ical:signal-validation-error + (format (concat "Mismatching VALUE parameter. VALUE specifies %s " + "but property value has type %s") + expected-type value-type) + :node property-node)) + ;; the value isn't of the default type, but we didn't find a + ;; VALUE parameter, so add one now: + (let* ((valuetype-param + (ical:make-ast-node 'ical:valuetypeparam + (list :value (ical:make-ast-node + 'ical:printed-value-type + (list :value value-type))))) + (new-params (cons valuetype-param + (ical:ast-node-children property-node)))) + (apply #'ical:ast-node-set-children property-node new-params)))) + + ;; Return the modified property node: + property-node))) + +(defun ical:value-type-from-params (params) + "Return the type symbol associated with any VALUE parameter in PARAMS. +PARAMS should be a list of parameter nodes. The type symbol specified by +the first `icalendar-valuetypeparam' in PARAMS, or nil, will be returned." + (catch 'found + (dolist (param params) + (when (ical:value-param-p param) + (let ((type (ical:ast-node-value + (ical:ast-node-value param)))) + (throw 'found type)))))) + +(defun ical:parse-property (limit) + "Parse the current property, up to LIMIT. + +Point should be at the beginning of a property line; LIMIT should be the +position at the end of the line. + +Returns a syntax node for the property. After parsing, point is at the +beginning of the next content line." + (rx-let ((ical:property-start (seq line-start (group-n 1 ical:name)))) + (let (line-begin line-end property-name property-type params node) + ;; Property name + (unless (re-search-forward (rx ical:property-start) limit t) + (ical:signal-parse-error + "Malformed property: could not match property name" + :restart-at (1+ limit))) + + (setq property-name (match-string 1)) + (setq line-begin (line-beginning-position)) + (setq line-end (line-end-position)) + + ;; Parameters + (when (looking-at-p ";") + (setq params (ical:parse-params line-end))) + + (unless (looking-at-p ":") + (ical:signal-parse-error + "Malformed property: parameters did not end at colon" + :restart-at (1+ limit))) + (forward-char) + + ;; Value + (setq property-type (alist-get (upcase property-name) + ical:property-types + 'ical:other-property + nil #'equal)) + (setq node (ical:parse-property-value property-type limit params)) + + ;; sanity check, since e.g. invalid base64 data might not + ;; match all the way to the end of the line, as test + ;; rfc5545-sec3.1.3/2 initially revealed + (unless (eql (point) (line-end-position)) + (ical:signal-parse-error + (format "%s property value did not consume line: %s" + property-name + (ical:default-value-printer (ical:ast-node-value node))) + :restart-at (1+ limit))) + + ;; value, children are set in ical:read-property-value, + ;; value-begin, value-end, end in ical:parse-property-value. + ;; begin and original-name are only available here: + (ical:ast-node-meta-set node :begin line-begin) + (when (eq property-type 'ical:other-property) + (ical:ast-node-meta-set node :original-name property-name)) + + ;; Set point up for the next property parser. + (while (not (bolp)) + (forward-char)) + + ;; Return the syntax node + node))) + + +;;;; Section 3.7: Calendar Properties +(ical:define-property ical:calscale "CALSCALE" + "Calendar scale. + +This property specifies the time scale of an +`icalendar-vcalendar' object. The only scale defined by RFC5545 +is \"GREGORIAN\", which is the default." + ;; only allowed value: + "GREGORIAN" + :default "GREGORIAN" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.7.1") + +(ical:define-property ical:method "METHOD" + "Method for a scheduling request. + +When an `icalendar-vcalendar' is sent in a MIME message, this property +specifies the semantics of the request in the message: e.g. it is +a request to publish the calendar object, or a reply to an +invitation. This property and the MIME message's \"method\" +parameter value must be the same. + +RFC5545 does not define any methods, but RFC5546 does; see +URL `https://www.rfc-editor.org/rfc/rfc5546.html#section-3.2'" + ;; TODO: implement methods in RFC5546? + ical:iana-token + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.7.2") + +(ical:define-property ical:prodid "PRODID" + "Product Identifier. + +This property identifies the program that created an +`icalendar-vcalendar' object. It must be specified exactly once in a +calendar object. Its value should be a globally unique identifier for +the program. RFC5545 suggests using an ISO \"Formal Public Identifier\"; +see URL `https://en.wikipedia.org/wiki/Formal_Public_Identifier'." + ical:text + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.7.3") + +(ical:define-property ical:version "VERSION" + "Version (2.0 corresponds to RFC5545). + +This property specifies the version number of the iCalendar +specification to which an `icalendar-vcalendar' object conforms, +and must be specified exactly once in a calendar object. It is +either the string \"2.0\" or a string like MIN;MAX specifying +minimum and maximum versions of future revisions of the +specification." + (or "2.0" + ;; minver ";" maxver + (seq ical:iana-token ?\; ical:iana-token)) + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.7.4") + + +;;;; Section 3.8: +;;;;; Section 3.8.1: Descriptive Component Properties + +(ical:define-property ical:attach "ATTACH" + "Attachment. + +This property specifies a file attached to an iCalendar +component, either via a URI, or as encoded binary data. In +`icalendar-valarm' components, it is used to specify the +notification sent by the alarm." + ;; Groups 11, 12 are used in ical:uri + (or (group-n 13 ical:uri) + (group-n 14 ical:binary)) + :default-type ical:uri + :other-types (ical:binary) + :child-spec (:zero-or-one (ical:fmttypeparam + ical:valuetypeparam + ical:encodingparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:attach-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.1") + +(defun ical:attach-validator (node) + "Additional validator for an `icalendar-attach' NODE. +Checks that NODE has a correct `icalendar-encodingparam' and +`icalendar-valuetypeparam' if its value is an `icalendar-binary'. + +This function is called by `icalendar-ast-node-valid-p' for +ATTACH nodes; it is not normally necessary to call it directly." + (let* ((value-node (ical:ast-node-value node)) + (value-type (ical:ast-node-type value-node)) + (valtypeparam (ical:ast-node-first-child-of 'ical:valuetypeparam node)) + (encodingparam (ical:ast-node-first-child-of 'ical:encodingparam node))) + + (when (eq value-type 'ical:binary) + (unless (and (ical:ast-node-p valtypeparam) + (eq 'ical:binary + (ical:ast-node-value ; unwrap inner printed-value-type + (ical:ast-node-value valtypeparam)))) + (ical:signal-validation-error + "`icalendar-binary' attachment requires 'VALUE=BINARY' parameter" + :node node)) + (unless (and (ical:ast-node-p encodingparam) + (equal "BASE64" (ical:ast-node-value encodingparam))) + (ical:signal-validation-error + "`icalendar-binary' attachment requires 'ENCODING=BASE64' parameter" + :node node))) + ;; success: + node)) + +(ical:define-property ical:categories "CATEGORIES" + "Categories. + +This property lists categories or subtypes of an iCalendar +component for e.g. searching or filtering. The categories can be +any `icalendar-text' value." + ical:text + :list-sep "," + :child-spec (:zero-or-one (ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.2") + +(ical:define-property ical:class "CLASS" + "(Access) Classification. + +This property specifies the scope of access that the calendar +owner intends for a given component, e.g. public or private." + (or "PUBLIC" + "PRIVATE" + "CONFIDENTIAL" + (group-n 5 + (or ical:iana-token + ical:x-name))) + ;; "If not specified in a component that allows this property, the + ;; default value is PUBLIC. Applications MUST treat x-name and + ;; iana-token values they don't recognize the same way as they would + ;; the PRIVATE value." + :default "PUBLIC" + :unrecognized "PRIVATE" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.3") + +(ical:define-property ical:comment "COMMENT" + "Comment to calendar user. + +This property can be specified multiple times in calendar components, +and can contain any `icalendar-text' value." + ical:text + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.4") + +(ical:define-property ical:description "DESCRIPTION" + "Description. + +This property should be a longer, more complete description of +the calendar component than is contained in the +`icalendar-summary' property. In a `icalendar-vjournal' +component, it is used to capture a journal entry, and may be +specified multiple times. Otherwise it may only be specified +once. In an `icalendar-valarm' component, it contains the +notification text for a DISPLAY or EMAIL alarm." + ical:text + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.5") + +(defun ical:read-geo-coordinates (s) + "Read an `icalendar-geo-coordinates' value from string S." + (let ((vals (mapcar #'string-to-number (string-split s ";")))) + (cons (car vals) (cadr vals)))) + +(defun ical:print-geo-coordinates (val) + "Serialize an `icalendar-geo-coordinates' value to a string." + (concat (number-to-string (car val)) ";" (number-to-string (cdr val)))) + +(defun ical:geo-coordinates-p (val) + "Return non-nil if VAL is an `icalendar-geo-coordinates' value." + (and (floatp (car val)) (floatp (cdr val)))) + +(ical:define-type ical:geo-coordinates nil ; don't add to ical:value-types + "Type for global positions. + +This is not a type defined by RFC5545; it is defined here to +facilitate parsing the `icalendar-geo' property. When printed, it +is represented as a pair of `icalendar-float' values separated by +a semicolon, like LATITUDE;LONGITUDE. When read, it is a dotted +pair of Elisp floats (LATITUDE . LONGITUDE)." + '(satisfies ical:geo-coordinates-p) + (seq ical:float ";" ical:float) + :reader ical:read-geo-coordinates + :printer ical:print-geo-coordinates) + +(ical:define-property ical:geo "GEO" + "Global position of a component as a pair LATITUDE;LONGITUDE. + +Both values are floats representing a number of degrees. The +latitude value is north of the equator if positive, and south of +the equator if negative. The longitude value is east of the prime +meridian if positive, and west of it if negative." + ical:geo-coordinates + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.6") + +(ical:define-property ical:location "LOCATION" + "Location. + +This property describes the intended location or venue of a +component, e.g. a particular room or building, with an +`icalendar-text' value. RFC5545 suggests using the +`icalendar-altrep' parameter on this property to provide more +structured location information." + ical:text + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.7") + +;; TODO: type for percentages? +(ical:define-property ical:percent-complete "PERCENT-COMPLETE" + "Percent Complete. + +This property describes progress toward the completion of an +`icalendar-vtodo' component. It can appear at most once in such a +component. If this TODO is assigned to multiple people, the value +represents the completion state for each person individually. The +value should be between 0 and 100 (though this is not currently +enforced here)." + ical:integer + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.8") + +;; TODO: type for priority values? +(ical:define-property ical:priority "PRIORITY" + "Priority. + +This property describes the priority of a component. 0 means an +undefined priority. Other values range from 1 (highest priority) +to 9 (lowest priority). See RFC5545 for suggestions on how to +represent other priority schemes with this property." + ical:integer + :default "0" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.9") + +(ical:define-property ical:resources "RESOURCES" + "Resources for an activity. + +This property is a list of `icalendar-text' values that describe +any resources required or foreseen for the activity represented +by a component, e.g. a projector and screen for a meeting." + ical:text + :list-sep "," + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.10") + +(ical:define-type ical:status-keyword nil + "Keyword value of a STATUS property. + +This is not a real type defined by RFC5545; it is defined here to +facilitate parsing that property." + '(and string (satisfies ical:match-status-keyword-value)) + ;; Note that this type does NOT allow arbitrary text: + (or "TENTATIVE" + "CONFIRMED" + "CANCELLED" + "NEEDS-ACTION" + "COMPLETED" + "IN-PROCESS" + "DRAFT" + "FINAL")) + +(ical:define-property ical:status "STATUS" + "Overall status or confirmation. + +This property is a keyword used by an Organizer to inform +Attendees about the status of a component, e.g. whether an +`icalendar-vevent' has been cancelled, whether an +`icalendar-vtodo' has been completed, or whether an +`icalendar-vjournal' is still in draft form. It can be specified +at most once on these components." + ical:status-keyword + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.11") + +(ical:define-property ical:summary "SUMMARY" + "Short summary. + +This property provides a short, one-line description of a +component for display purposes. In an EMAIL `icalendar-valarm', +it is used as the subject of the email. A longer description of +the component can be provided in the `icalendar-description' +property." + ical:text + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.1.12") + +;;;;; Section 3.8.2: Date and Time Component Properties + +(defun ical:property-w/tzid-validator (node) + "Additional validator for property NODE with `icalendar-tzid' parameters. +Checks that this parameter does not occur in combination with an +`icalendar-date' value or an `icalendar-date-time' in UTC time." + (ical:with-property node + ((ical:tzidparam :first tzidnode)) + (when (and tzidnode (eq value-type 'ical:date)) + (icalendar-signal-validation-error + "Property cannot contain `icalendar-tzidparam' with `icalendar-date' value" + :node node)) + (when (and tzidnode (eq value-type 'ical:date-time) + (ical:date-time-is-utc-p value)) + (icalendar-signal-validation-error + "Property cannot contain `icalendar-tzidparam' in combination with UTC time" + :node node)))) + +(ical:define-property ical:completed "COMPLETED" + "Time completed. + +This property is a timestamp that records the date and time when +an `icalendar-vtodo' was actually completed. The value must be an +`icalendar-date-time' with a UTC time." + ical:date-time + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.1") + +(ical:define-property ical:dtend "DTEND" + "End time of an event or free/busy block. + +This property's value specifies when an `icalendar-vevent' or +`icalendar-freebusy' ends. Its value must be of the same type as +the value of the component's corresponding `icalendar-dtstart' +property. The value is a non-inclusive bound, i.e., the value of +this property must be the first time or date *after* the end of +the event or free/busy block." + (or ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date) + :child-spec (:zero-or-one (ical:valuetypeparam ical:tzidparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:property-w/tzid-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.2") + +(ical:define-property ical:due "DUE" + "Due date. + +This property specifies the date (and possibly time) by which an +`icalendar-todo' item is expected to be completed, i.e., its +deadline. If the component also has an `icalendar-dtstart' +property, the two properties must have the same value type, and +the value of the DTSTART property must be earlier than the value +of this property." + (or ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date) + :child-spec (:zero-or-one (ical:valuetypeparam ical:tzidparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:property-w/tzid-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.3") + +(ical:define-property ical:dtstart "DTSTART" + "Start time of a component. + +This property's value specifies when a component starts. In an +`icalendar-vevent', it specifies the start of the event. In an +`icalendar-vfreebusy', it specifies the start of the free/busy +block. In `icalendar-standard' and `icalendar-daylight' +sub-components, it defines the start time of a time zone +specification. + +It is required in any component with an `icalendar-rrule' +property, and in any `icalendar-vevent' component contained in a +calendar that does not have a `icalendar-method' property. + +Its value must be of the same type as the value of the +component's corresponding `icalendar-dtend' property. In an +`icalendar-vtodo' component, it must also be of the same type as +the value of an `icalendar-due' property (if present)." + (or ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date) + :child-spec (:zero-or-one (ical:valuetypeparam ical:tzidparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:property-w/tzid-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.4") + +(ical:define-property ical:duration "DURATION" + "Duration. + +This property specifies a duration of time for a component. +In an `icalendar-vevent', it can be used to implicitly specify +the end of the event, instead of an explicit `icalendar-dtend'. +In an `icalendar-vtodo', it can likewise be used to implicitly specify +the due date, instead of an explicit `icalendar-due'. +In an `icalendar-valarm', it used to specify the delay period +before the alarm repeats. + +If a related `icalendar-dtstart' property has an `icalendar-date' +value, then the duration must be given as a number of weeks or days." + ical:dur-value + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.5") + +(ical:define-property ical:freebusy "FREEBUSY" + "Free/Busy Times. + +This property specifies a list of periods of free or busy time in +an `icalendar-vfreebusy' component. Whether it specifies free or +busy times is determined by its `icalendar-fbtype' parameter. The +times in each period must be in UTC format." + ical:period + :list-sep "," + :child-spec (:zero-or-one (ical:fbtypeparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.6") + +(ical:define-property ical:transp "TRANSP" + "Time Transparency for free/busy searches. + +Note that this property only allows two values: \"TRANSPARENT\" +or \"OPAQUE\". An OPAQUE value means that the component consumes +time on a calendar. TRANSPARENT means it does not, and thus is +invisible to free/busy time searches." + ;; Note that this does NOT allow arbitrary text: + (or "TRANSPARENT" + "OPAQUE") + :default "OPAQUE" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.2.7") + +;;;;; Section 3.8.3: Time Zone Component Properties + +(ical:define-property ical:tzid "TZID" + "Time Zone Identifier. + +This property specifies the unique identifier for a time zone in +an `icalendar-vtimezone' component, and is a required property of +that component. This is an identifier that `icalendar-tzidparam' +parameters in other components may then refer to." + (seq (zero-or-one "/") ical:text) + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.3.1") + +(ical:define-property ical:tzname "TZNAME" + "Time Zone Name. + +This property specifies a customary name for a time zone in +`icalendar-daylight' and `icalendar-standard' sub-components." + ical:text + :child-spec (:zero-or-one (ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.3.2") + +(ical:define-property ical:tzoffsetfrom "TZOFFSETFROM" + "Time Zone Offset (prior to observance). + +This property specifies the time zone offset that is in use +*prior to* this time zone observance. It is used to calculate the +absolute time at which the observance takes place. It is a +required property of an `icalendar-vtimezone' component. Positive +numbers indicate time east of the prime meridian (ahead of UTC). +Negative numbers indicate time west of the prime meridian (behind +UTC)." + ical:utc-offset + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.3.3") + +(ical:define-property ical:tzoffsetto "TZOFFSETTO" + "Time Zone Offset (in this observance). + +This property specifies the time zone offset that is in use *in* +this time zone observance. It is used to calculate the absolute +time at which a new observance takes place. It is a required +property of `icalendar-standard' and `icalendar-daylight' +components. Positive numbers indicate time east of the prime +meridian (ahead of UTC). Negative numbers indicate time west of +the prime meridian (behind UTC)." + ical:utc-offset + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.3.4") + +(ical:define-property ical:tzurl "TZURL" + "Time Zone URL. + +This property specifies a URL where updated versions of an +`icalendar-vtimezone' component are published." + ical:uri + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.3.5") + +;;;;; Section 3.8.4: Relationship Component Properties + +(ical:define-property ical:attendee "ATTENDEE" + "Attendee. + +This property specfies a participant in a `icalendar-vevent', +`icalendar-vtodo', or `icalendar-valarm'. It is required when the +containing component represents event, task, or notification for +a *group* of people, but not for components that simply represent +these items in a single user's calendar (in that case, it should +not be specified). The property can be specified multiple times, +once for each participant in the event or task. In an +EMAIL-category VALARM component, this property specifies the +address of the user(s) who should receive the notification email. + +The parameters `icalendar-roleparam', `icalendar-partstatparam', +`icalendar-rsvpparam', `icalendar-delfromparam', and +`icalendar-deltoparam' are especially relevant for further +specifying the roles of each participant in the containing +component." + ical:cal-address + :child-spec (:zero-or-one (ical:cutypeparam + ical:memberparam + ical:roleparam + ical:partstatparam + ical:rsvpparam + ical:deltoparam + ical:delfromparam + ical:sentbyparam + ical:cnparam + ical:dirparam + ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.1") + +(ical:define-property ical:contact "CONTACT" + "Contact. + +This property provides textual contact information relevant to an +`icalendar-vevent', `icalendar-vtodo', `icalendar-vjournal', or +`icalendar-vfreebusy'." + ical:text + :child-spec (:zero-or-one (ical:altrepparam ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.2") + +(ical:define-property ical:organizer "ORGANIZER" + "Organizer. + +This property specifies the organizer of a group-scheduled +`icalendar-vevent', `icalendar-vtodo', or `icalendar-vjournal'. +It is required in those components if they represent a calendar +entity with multiple participants. In an `icalendar-vfreebusy' +component, it used to specify the user requesting free or busy +time, or the user who published the calendar that the free/busy +information comes from." + ical:cal-address + :child-spec (:zero-or-one (ical:cnparam + ical:dirparam + ical:sentbyparam + ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.3") + +(ical:define-property ical:recurrence-id "RECURRENCE-ID" + "Recurrence ID. + +This property is used together with the `icalendar-uid' and +`icalendar-sequence' properties to identify a specific instance +of a recurring `icalendar-vevent', `icalendar-vtodo', or +`icalendar-vjournal' component. The property value is the +original value of the `icalendar-dtstart' property of the +recurrence instance. Its value must have the same type as that +property's value, and both must specify times in the same way +(either local or UTC)." + (or ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date) + :child-spec (:zero-or-one (ical:valuetypeparam + ical:tzidparam + ical:rangeparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.4") + +(ical:define-property ical:related-to "RELATED-TO" + "Related To (component UID). + +This property specifies the `icalendar-uid' value of a different, +related calendar component. It can be specified on an +`icalendar-vevent', `icalendar-vtodo', or `icalendar-vjournal' +component. An `icalendar-reltypeparam' can be used to specify the +relationship type." + ical:text + :child-spec (:zero-or-one (ical:reltypeparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.5") + +(ical:define-property ical:url "URL" + "Uniform Resource Locator. + +This property specifies the URL associated with an +`icalendar-vevent', `icalendar-vtodo', `icalendar-vjournal', or +`icalendar-vfreebusy' component." + ical:uri + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.6") + +;; TODO: UID should probably be its own type +(ical:define-property ical:uid "UID" + "Unique Identifier. + +This property specifies a globally unique identifier for the +containing component, and is required in an `icalendar-vevent', +`icalendar-vtodo', `icalendar-vjournal', or `icalendar-vfreebusy' +component. + +RFC5545 requires that the program generating the UID guarantee +that it be unique, and recommends generating it in a format which +includes a timestamp on the left hand side of an '@' character, +and the domain name or IP address of the host on the right-hand +side." + ical:text + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.4.7") + +;;;;; Section 3.8.5: Recurrence Component Properties + +(ical:define-property ical:exdate "EXDATE" + "Exception Date-Times. + +This property defines a list of exceptions to a recurrence rule +in an `icalendar-vevent', `icalendar-todo', `icalendar-vjournal', +`icalendar-standard', or `icalendar-daylight' component. Together +with the `icalendar-dtstart', `icalendar-rrule', and +`icalendar-rdate' properties, it defines the recurrence set of +the component." + (or ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date) + :list-sep "," + :child-spec (:zero-or-one (ical:valuetypeparam ical:tzidparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:property-w/tzid-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.5.1") + +(ical:define-property ical:rdate "RDATE" + "Recurrence Date-Times. + +This property defines a list of date-times or dates on which an +`icalendar-vevent', `icalendar-todo', `icalendar-vjournal', +`icalendar-standard', or `icalendar-daylight' component recurs. +Together with the `icalendar-dtstart', `icalendar-rrule', and +`icalendar-exdate' properties, it defines the recurrence set of +the component." + (or ical:period + ical:date-time + ical:date) + :default-type ical:date-time + :other-types (ical:date ical:period) + :list-sep "," + :child-spec (:zero-or-one (ical:valuetypeparam ical:tzidparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:property-w/tzid-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.5.2") + +(ical:define-property ical:rrule "RRULE" + "Recurrence Rule. + +This property defines a rule or repeating pattern for the dates +and times on which an `icalendar-vevent', `icalendar-todo', +`icalendar-vjournal', `icalendar-standard', or +`icalendar-daylight' component recurs. Together with the +`icalendar-dtstart', `icalendar-rdate', and `icalendar-exdate' +properties, it defines the recurrence set of the component." + ical:recur + ;; TODO: faces for subexpressions? + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.5.3") + +;;;;; Section 3.8.6: Alarm Component Properties + +(ical:define-property ical:action "ACTION" + "Action (when alarm triggered). + +This property defines the action to be taken when the containing +`icalendar-valarm' component is triggered. It is a required +property in an alarm component." + (or "AUDIO" + "DISPLAY" + "EMAIL" + (group-n 5 + (or ical:iana-token + ical:x-name))) + ;; "Applications MUST ignore alarms with x-name and iana-token values + ;; they don't recognize." This substitute is not defined in the + ;; standard but is the simplest way to parse such alarms: + :unrecognized "IGNORE" + :default-type ical:text + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.6.1") + +(ical:define-property ical:repeat "REPEAT" + "Repeat Count (after initial trigger). + +This property specifies the number of times an `icalendar-valarm' +should repeat after it is initially triggered. This property, +along with the `icalendar-duration' property, is required if the +alarm triggers more than once." + ical:integer + :default "0" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.6.2") + +(ical:define-property ical:trigger "TRIGGER" + "Trigger. + +This property specifies when an `icalendar-valarm' should +trigger. If the value is an `icalendar-dur-value', it represents +a time of that duration relative to the start or end of a related +`icalendar-vevent' or `icalendar-vtodo'. Whether the trigger +applies to the start time or end time of the related component +can be specified with the `icalendar-trigrelparam' parameter. A +positive duration value triggers after the start or end of the +related component; a negative duration value triggers before. + +If the value is an `icalendar-date-time', it must be in UTC +format, and it triggers at the specified time." + (or ical:dur-value + ical:date-time) + :default-type ical:dur-value + :other-types (ical:date-time) + :child-spec (:zero-or-one (ical:valuetypeparam ical:trigrelparam) + :zero-or-more (ical:otherparam)) + :other-validator ical:trigger-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.6.3") + +(defun ical:trigger-validator (node) + "Additional validator for an `icalendar-trigger' NODE. +Checks that NODE has valid parameters depending on the type of its value. + +This function is called by `icalendar-ast-node-valid-p' for +TRIGGER nodes; it is not normally necessary to call it directly." + (let* ((params (ical:ast-node-children node)) + (value-node (ical:ast-node-value node)) + (value-type (and value-node (ical:ast-node-type value-node)))) + (when (eq value-type 'ical:date-time) + (let ((expl-type (ical:value-type-from-params params)) + (dt-value (ical:ast-node-value value-node))) + (unless (eq expl-type 'ical:date-time) + (ical:signal-validation-error + (concat "Explicit `icalendar-valuetypeparam' required in " + "`icalendar-trigger' with non-duration value") + :node node)) + (when (ical:ast-node-first-child-of 'ical:trigrelparam node) + (ical:signal-validation-error + (concat "`icalendar-trigrelparam' not allowed in " + "`icalendar-trigger' with non-duration value") + :node node)) + (unless (ical:date-time-is-utc-p dt-value) + (ical:signal-validation-error + (concat "`icalendar-date-time' value of `icalendar-trigger' " + "must be in UTC time") + :node node)))) + ;; success: + node)) + +;;;;; Section 3.8.7: Change Management Component Properties + +(ical:define-property ical:created "CREATED" + "Date-Time Created. + +This property specifies the date and time when the calendar user +initially created an `icalendar-vevent', `icalendar-vtodo', or +`icalendar-vjournal' in the calendar database. The value must be +in UTC time." + ical:date-time + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.7.1") + +(ical:define-property ical:dtstamp "DTSTAMP" + "Timestamp (of last revision or instance creation). + +In an `icalendar-vevent', `icalendar-vtodo', +`icalendar-vjournal', or `icalendar-vfreebusy', this property +specifies the date and time when the calendar user last revised +the component's data in the calendar database. (In this case, it +is equivalent to the `icalendar-last-modified' property.) + +If this property is specified on an `icalendar-vcalendar' object +which contains an `icalendar-method' property, it specifies the +date and time when that instance of the calendar object was +created. In this case, it differs from the `icalendar-creation' +and `icalendar-last-modified' properties: whereas those specify +the time the underlying data was created and last modified in the +calendar database, this property specifies when the calendar +object *representing* that data was created. + +The value must be in UTC time." + ical:date-time + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.7.2") + +(ical:define-property ical:last-modified "LAST-MODIFIED" + "Last Modified timestamp. + +This property specifies when the data in an `icalendar-vevent', +`icalendar-vtodo', `icalendar-vjournal', or `icalendar-vtimezone' +was last modified in the calendar database." + ical:date-time + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.7.3") + +(ical:define-property ical:sequence "SEQUENCE" + "Revision Sequence Number. + +This property specifies the number of the current revision in a +sequence of revisions in an `icalendar-vevent', +`icalendar-vtodo', or `icalendar-vjournal' component. It starts +at 0 and should be incremented monotonically every time the +Organizer makes a significant revision to the calendar data that +component represents." + ical:integer + :default "0" + :child-spec (:zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.7.4") + +;;;;; Section 3.8.8: Miscellaneous Component Properties +;; IANA and X- properties should be parsed and printed but can be ignored: +(ical:define-property ical:other-property nil ; don't add to ical:property-types + "IANA or X-name property. + +This property type corresponds to the IANA Properties and +Non-Standard Properties defined in RFC5545; it represents +properties with an unknown name (matching rx +`icalendar-iana-token' or `icalendar-x-name') whose values must +be parsed and preserved but not further interpreted. Its value +may be set to any type with the `icalendar-valuetypeparam' +parameter." + ical:value + :default-type ical:text + ;; "The default value type is TEXT. The value type can be set to any + ;; value type." TODO: should we specify :other-types? Without it, a + ;; VALUE param will be required to parse anything other than text, + ;; but that seems reasonable. + :child-spec (:allow-others t) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.8") + +(defun ical:read-req-status-info (s) + "Read a request status value from S. +S should have been previously matched against `icalendar-request-status-info'." + ;; TODO: this smells like a design flaw. Silence the byte compiler for now. + (ignore s) + (let ((code (match-string 11)) + (desc (match-string 12)) + (exdata (match-string 13))) + (list code (ical:read-text desc) (when exdata (ical:read-text exdata))))) + +(defun ical:print-req-status-info (rsi) + "Serialize request status info value RSI to a string." + (let ((code (car rsi)) + (desc (cadr rsi)) + (exdata (caddr rsi))) + (if exdata + (format "%s;%s;%s" code (ical:print-text desc) (ical:print-text exdata)) + (format "%s;%s" code (ical:print-text desc))))) + +(defun ical:req-status-info-p (val) + "Return non-nil if VAL is an `icalendar-request-status-info' value." + (and (listp val) + (length= val 3) + (stringp (car val)) + (stringp (cadr val)) + (cl-typep (caddr val) '(or string null)))) + +(ical:define-type ical:req-status-info nil + "Type for REQUEST-STATUS property values. + +When read, a list (CODE DESCRIPTION EXCEPTION). CODE is a hierarchical +numerical code, represented as a string, with the following meanings: + 1.xx Preliminary success + 2.xx Successful + 3.xx Client Error + 4.xx Scheduling Error +DESCRIPTION is a longer description of the request status, also a string. +EXCEPTION (which may be nil) is textual data describing an error. + +When printed, the three elements are separated by semicolons, like + CODE;DESCRIPTION;EXCEPTION +or + CODE;DESCRIPTION +if EXCEPTION is nil. + +This is not a type defined by RFC5545; it is defined here to +facilitate parsing the `icalendar-request-status' property." + '(satisfies ical:req-status-info-p) + (seq + ;; statcode: hierarchical status code + (group-n 11 + (seq (one-or-more digit) + (** 1 2 (seq ?. (one-or-more digit))))) + ?\; + ;; statdesc: status description + (group-n 12 ical:text) + ;; exdata: exception data + (zero-or-one (seq ?\; (group-n 13 ical:text)))) + :reader ical:read-req-status-info + :printer ical:print-req-status-info + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.8.3") + +(ical:define-property ical:request-status "REQUEST-STATUS" + "Request status" + ical:req-status-info + :child-spec (:zero-or-one (ical:languageparam) + :zero-or-more (ical:otherparam)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.8.8.3") + + +;;; Section 3.6: Calendar Components + +(defconst ical:component-types nil ;; populated by ical:define-component + "Alist mapping printed component names to type symbols.") + +(defun ical:parse-component (limit) + "Parse an iCalendar component from point up to LIMIT. +Point should be at the start of the component, i.e., at the start +of a line that looks like \"BEGIN:[COMPONENT-NAME]\". After parsing, +point is at the beginning of the next line following the component +\(or end of the buffer). Returns a syntax node representing the component." + (let ((begin-pos nil) + (body-begin-pos nil) + (end-pos nil) + (body-end-pos nil) + (begin-regex (rx line-start "BEGIN:" (group-n 2 ical:name) line-end))) + + (unless (re-search-forward begin-regex limit t) + (ical:signal-parse-error "Not at start of a component")) + + (setq begin-pos (match-beginning 0) + body-begin-pos (1+ (match-end 0))) ; start of next line + + (let* ((component-name (match-string 2)) + (known-type (alist-get (upcase component-name) + ical:component-types + nil nil #'equal)) + (component-type (or known-type 'ical:other-component)) + child children) + + ;; Find end of component: + (save-excursion + (if (re-search-forward (concat "^END:" component-name "$") limit t) + (setq end-pos (match-end 0) + body-end-pos (1- (match-beginning 0))) ; end of prev. line + (ical:signal-parse-error + (format "Matching 'END:%s' not found between %d and %d" + component-name begin-pos limit) + :restart-at (1+ limit)))) + + (while (not (bolp)) + (forward-char)) + + ;; Parse the properties and subcomponents of this component: + (while (<= (point) body-end-pos) + (condition-case err + (setq child (ical:parse-property-or-component end-pos)) + (ical:parse-error + (ical:handle-parse-error err) + (setq child nil))) + (when child (push child children))) + + ;; Set point up for the next parser: + (goto-char end-pos) + (while (and (< (point) (point-max)) (not (bolp))) + (forward-char)) + + ;; Return the syntax node for the component: + (when children + (ical:make-ast-node component-type + (list + :original-name + (when (eq component-type 'ical:other-component) + component-name) + :buffer (current-buffer) + :begin begin-pos + :end end-pos + :value-begin body-begin-pos + :value-end body-end-pos) + (nreverse children)))))) + +(defun ical:parse-property-or-component (limit) + "Parse a component or a property at point, up to LIMIT. +Point should be at the beginning of a line which begins a +component or contains a property." + (cond ((looking-at-p (rx line-start "BEGIN:" ical:name line-end)) + (ical:parse-component limit)) + ((looking-at-p (rx line-start ical:name)) + (ical:parse-property (line-end-position))) + (t (ical:signal-parse-error + "Not at start of property or component" + :restart-at ; find start of next content line: + (save-excursion + (if (re-search-forward (rx line-start ical:name) nil t) + (match-beginning 0) + (point-max))))))) + +(defun ical:print-component-node (node) + "Serialize a component syntax node NODE to a string." + (let* ((type (ical:ast-node-type node)) + (name (or (ical:ast-node-meta-get :original-name node) + (car (rassq type ical:component-types)))) + (children (ical:ast-node-children node)) + body) + + (unless name + (ical:signal-print-error + (format "Unknown component name for type `%s'" type) + :node node)) + + (dolist (child children) + (condition-case err + (setq body + (concat body (ical:print-property-or-component child))) + (ical:print-error + (if (ical:ast-node-required-child-p child node) + (ical:signal-print-error + (format + "Unable to print required `%s' %s in `%s' component. Error was:\n%s" + (ical:ast-node-type child) + (if (ical:component-node-p child) "subcomponent" "property") + (ical:ast-node-type node) + (plist-get (cdr err) :message)) + :node node) + (ical:handle-print-error err))))) + (concat + (format "BEGIN:%s\n" name) + body + (format "END:%s\n" name)))) + +(defun ical:print-property-or-component (node) + "Serialize a property or component node NODE to a string." + (cond ((ical:property-node-p node) + (ical:print-property-node node)) + ((ical:component-node-p node) + (ical:print-component-node node)) + (t (ical:signal-print-error "Not a component or property node" + :node node)))) + +(ical:define-component ical:vevent "VEVENT" + "Represents an event. + +This component contains properties which describe an event, such +as its start and end time (`icalendar-dtstart' and +`icalendar-dtend') and a summary (`icalendar-summary') and +description (`icalendar-description'). It may also contain +`icalendar-valarm' components as subcomponents which describe +reminder notifications related to the event. Event components can +only be direct children of an `icalendar-vcalendar'; they cannot +be subcomponents of any other component." + :child-spec (:one (ical:dtstamp ical:uid) + :zero-or-one (ical:dtstart + ;; TODO: dtstart required if METHOD not present + ;; in parent calendar + ical:class + ical:created + ical:description + ical:dtend + ical:duration + ical:geo + ical:last-modified + ical:location + ical:organizer + ical:priority + ical:sequence + ical:status + ical:summary + ical:transp + ical:url + ical:recurrence-id + ical:rrule) + :zero-or-more (ical:attach + ical:attendee + ical:categories + ical:comment + ical:contact + ical:exdate + ical:request-status + ical:related-to + ical:resources + ical:rdate + ical:other-property + ical:valarm)) + :other-validator ical:vevent-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.1") + +(defun ical:rrule-validator (node) + "Validate that NODE has the properties required by a recurrence rule. + +NODE should represent an iCalendar component. When NODE has an +`icalendar-rrule' property, this function validates that its +`icalendar-dtstart', `icalendar-rdate', and `icalendar-exdate' +properties satisfy the requirements imposed by this rule. + +This function is called by the additional validator functions for +component nodes (e.g. `icalendar-vevent-validator'); it is not normally +necessary to call it directly." + (let* ((rrule (ical:ast-node-first-child-of 'ical:rrule node)) + (recval (when rrule (ical:ast-node-value rrule))) + (dtstart (ical:ast-node-first-child-of 'ical:dtstart node)) + (start (when dtstart (ical:ast-node-value dtstart))) + (rdates (ical:ast-node-children-of 'ical:rdate node)) + (included (when rdates + (mapcar #'ical:ast-node-value + (apply #'append + (mapcar #'ical:ast-node-value rdates)))))) + (when rrule + (unless dtstart + (ical:signal-validation-error + "An `icalendar-rrule' requires an `icalendar-dtstart' property" + :node node)) + (when included + ;; ""RDATE" in this usage [i.e., in STANDARD and DAYLIGHT + ;; subcomponents] MUST be specified as a date with local time + ;; value, relative to the UTC offset specified in the + ;; "TZOFFSETFROM" property." + (when (and (memq (ical:ast-node-type node) '(ical:standard ical:daylight))) + (unless (ical:list-of-p included 'ical:date-time) + (ical:signal-validation-error + (format + (concat "`icalendar-rdate' values must be `icalendar-date-time' " + "values in %s components") + (ical:ast-node-type node)) + :node node)) + (when (seq-some #'decoded-time-zone included) + (ical:signal-validation-error + (format + (concat "`icalendar-rdate' values must be in local (\"floating\")" + "time in %s components") + (ical:ast-node-type node)) + :node node)))) + + (let* ((freq (car (alist-get 'FREQ recval))) + (until (car (alist-get 'UNTIL recval)))) + (when (eq 'ical:date (ical:ast-node-type start)) + (when (or (memq freq '(HOURLY MINUTELY SECONDLY)) + (assq 'BYSECOND recval) + (assq 'BYMINUTE recval) + (assq 'BYHOUR recval)) + (ical:signal-validation-error + (concat "`icalendar-rrule' must not contain time-based " + "rules when `icalendar-dtstart' is a plain date") + :node node))) + (when until + (unless (eq (ical:ast-node-type start) + (ical:ast-node-type until)) + (ical:signal-validation-error + (concat "`icalendar-rrule' UNTIL clause must agree with " + "type of `icalendar-dtstart' property") + :node node)) + (when (eq 'ical:date-time (ical:ast-node-type until)) + (let ((until-zone + (decoded-time-zone (ical:ast-node-value until))) + (start-zone + (decoded-time-zone (ical:ast-node-value start)))) + ;; "If the "DTSTART" property is specified as a date + ;; with local time, then the UNTIL rule part MUST also + ;; be specified as a date with local time": + (when (and (null start-zone) (not (null until-zone))) + (ical:signal-validation-error + (concat "`icalendar-rrule' UNTIL clause must be in " + "local time if `icalendar-dtstart' is") + :node node)) + ;; "If the "DTSTART" property is specified as a date + ;; with UTC time or a date with local time and time zone + ;; reference, then the UNTIL rule part MUST be specified + ;; as a date with UTC time": + (when (and (integerp start-zone) + (not (ical:date-time-is-utc-p until))) + (ical:signal-validation-error + (concat "`icalendar-rrule' UNTIL clause must be in UTC time " + "if `icalendar-dtstart' has a defined time zone") + :node node)))) + (when (memq (ical:ast-node-type node) '(ical:standard ical:daylight)) + ;; "In the case of the "STANDARD" and "DAYLIGHT" + ;; sub-components the UNTIL rule part MUST always be + ;; specified as a date with UTC time": + (unless (ical:date-time-is-utc-p until) + (ical:signal-validation-error + (concat "`icalendar-rrule' UNTIL clause must be in UTC time in " + "`icalendar-standard' and `icalendar-daylight' components") + :node node)))) + + ;; "DTSTART in this usage [i.e., in STANDARD and DAYLIGHT + ;; subcomponents] MUST be specified as a date with a local + ;; time value." + (when (memq (ical:ast-node-type node) '(ical:standard ical:daylight)) + (unless (eq 'ical:date-time (ical:ast-node-type start)) + (ical:signal-validation-error + (concat "`icalendar-dtstart' must be an `icalendar-date-time' in " + "`icalendar-standard' and `icalendar-daylight' components") + :node node)) + + (when (decoded-time-zone (ical:ast-node-value start)) + (ical:signal-validation-error + (concat "`icalendar-dtstart' must be in local (\"floating\") time in " + "`icalendar-standard' and `icalendar-daylight' components") + :node node))))) + + ;; Success: + node)) + +(defun ical:vevent-validator (node) + "Additional validator for an `icalendar-vevent' NODE. +Checks that NODE has does not have both `icalendar-duration' and +`icalendar-dtend' properties, and calls `icalendar-rrule-validator'. + +This function is called by `icalendar-ast-node-valid-p' for +VEVENT nodes; it is not normally necessary to call it directly." + (let* ((duration (ical:ast-node-first-child-of 'ical:duration node)) + (dur-value (when duration (ical:ast-node-value + (ical:ast-node-value duration)))) + (dtend (ical:ast-node-first-child-of 'ical:dtend node)) + (dtstart (ical:ast-node-first-child-of 'ical:dtstart node))) + (when (and dtend duration) + (ical:signal-validation-error + (concat "`icalendar-dtend' and `icalendar-duration' properties must " + "not appear in the same `icalendar-vevent'") + :node node)) + ;; don't allow time-based durations with dates + ;; TODO: check that the standard disallows this...? + (when (and dtstart duration + (eq 'ical:date (ical:ast-node-type dtstart)) + (or (not (integerp dur-value)) + (decoded-time-hour dur-value) + (decoded-time-minute dur-value) + (decoded-time-second dur-value))) + (ical:signal-validation-error + (concat "Event with `icalendar-date' value in `icalendar-dtstart' " + "cannot have time units in `icalendar-duration'") + :node node)) + + (ical:rrule-validator node) + ;; success: + node)) + +(ical:define-component ical:vtodo "VTODO" + "Represents a To-Do item or task. + +This component contains properties which describe a to-do item or +task, such as its due date (`icalendar-due') and a summary +(`icalendar-summary') and description (`icalendar-description'). +It may also contain `icalendar-valarm' components as +subcomponents which describe reminder notifications related to +the task. To-do components can only be direct children of an +`icalendar-vcalendar'; they cannot be subcomponents of any other +component." + :child-spec (:one (ical:dtstamp ical:uid) + :zero-or-one (ical:class + ical:completed + ical:created + ical:description + ical:dtstart + ical:due + ical:duration + ical:geo + ical:last-modified + ical:location + ical:organizer + ical:percent-complete + ical:priority + ical:recurrence-id + ical:sequence + ical:status + ical:summary + ical:url + ical:rrule) + :zero-or-more (ical:attach + ical:attendee + ical:categories + ical:comment + ical:contact + ical:exdate + ical:request-status + ical:related-to + ical:resources + ical:rdate + ical:other-property + ical:valarm)) + :other-validator ical:vtodo-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.2") + +(defun ical:vtodo-validator (node) + "Additional validator for an `icalendar-vtodo' NODE. +Checks that NODE has conformant `icalendar-due', +`icalendar-duration', and `icalendar-dtstart' properties, and calls +`icalendar-rrule-validator'. + +This function is called by `icalendar-ast-node-valid-p' for +VTODO nodes; it is not normally necessary to call it directly." + (let* ((due (ical:ast-node-first-child-of 'ical:due node)) + (duration (ical:ast-node-first-child-of 'ical:duration node)) + (dtstart (ical:ast-node-first-child-of 'ical:dtstart node))) + (when (and due duration) + (ical:signal-validation-error + (concat "`icalendar-due' and `icalendar-duration' properties " + "must not appear in the same `icalendar-vtodo'") + :node node)) + (when (and duration (not dtstart)) + (ical:signal-validation-error + (concat "`icalendar-duration' requires `icalendar-dtstart' " + "property in the same `icalendar-vtodo'") + :node node))) + (ical:rrule-validator node) + ;; success: + node) + +(ical:define-component ical:vjournal "VJOURNAL" + "Represents a journal entry. + +This component contains properties which describe a journal +entry, which might be any longer-form data (e.g., meeting notes, +a diary entry, or information needed to complete a task). It can +be associated with an `icalendar-vevent' or `icalendar-vtodo' via +the `icalendar-related-to' property. A journal entry does not +take up time in a calendar, and plays no role in searches for +free or busy time. Journal components can only be direct children +of `icalendar-vcalendar'; they cannot be subcomponents of any +other component." + :child-spec (:one (ical:dtstamp ical:uid) + :zero-or-one (ical:class + ical:created + ical:dtstart + ical:last-modified + ical:organizer + ical:recurrence-id + ical:sequence + ical:status + ical:summary + ical:url + ical:rrule) + :zero-or-more (ical:attach + ical:attendee + ical:categories + ical:comment + ical:contact + ical:description + ical:exdate + ical:related-to + ical:rdate + ical:request-status + ical:other-property) + :other-validator ical:rrule-validator) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.3") + +(ical:define-component ical:vfreebusy "VFREEBUSY" + "Represents a published set of free/busy time blocks, or a request +or response for such blocks. + +The free/busy information is represented by the +`icalendar-freebusy' property (which may be given more than once) +and the related `icalendar-fbtype' parameter. Note that +recurrence properties (`icalendar-rrule', `icalendar-rdate', and +`icalendar-exdate') are NOT permitted in this component. + +When used to publish blocks of free/busy time in a user's +schedule, the `icalendar-organizer' property specifies the user. + +When used to request free/busy time in a user's schedule, or to +respond to such a request, the `icalendar-attendee' property +specifies the user whose time is being requested, and the +`icalendar-organizer' property specifies the user making the +request. + +Free/busy components can only be direct children +of `icalendar-vcalendar'; they cannot be subcomponents of any +other component, and cannot contain subcomponents." + :child-spec (:one (ical:dtstamp ical:uid) + :zero-or-one (ical:contact + ical:dtstart + ical:dtend + ical:organizer + ical:url) + :zero-or-more (ical:attendee + ical:comment + ical:freebusy + ical:request-status + ical:other-property)) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.4") + +;; TODO: RFC7808 defines additional properties that are relevant here: +;; https://www.rfc-editor.org/rfc/rfc7808.html#section-7 +(ical:define-component ical:vtimezone "VTIMEZONE" + "Represents a time zone. + +A time zone is identified by an `icalendar-tzid' property, which +is required in this component. Times in other calendar components +can be specified in local time in this time zone with the +`icalendar-tzidparam' parameter. An `icalendar-vcalendar' object +must contain exactly one `icalendar-vtimezone' component for each +unique time zone identifier used in the calendar. + +Besides the time zone identifier, a time zone component must +contain at least one `icalendar-standard' or `icalendar-daylight' +subcomponent, which describe the observance of standard or +daylight time in the time zone, including the dates of the +observance and the relevant offsets from UTC time." + :child-spec (:one (ical:tzid) + :zero-or-one (ical:last-modified + ical:tzurl) + :zero-or-more (ical:standard + ical:daylight + ical:other-property)) + :other-validator ical:vtimezone-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.5") + +(defun ical:vtimezone-validator (node) + "Additional validator for an `icalendar-vtimezone' NODE. +Checks that NODE has at least one `icalendar-standard' or +`icalendar-daylight' child. + +This function is called by `icalendar-ast-node-valid-p' for +VTIMEZONE nodes; it is not normally necessary to call it directly." + (let ((child-counts (ical:count-children-by-type node))) + (when (and (= 0 (alist-get 'ical:standard child-counts 0)) + (= 0 (alist-get 'ical:daylight child-counts 0))) + (ical:signal-validation-error + (concat "`icalendar-vtimezone' must have at least one " + "`icalendar-standard' or `icalendar-daylight' child") + :node node))) + + ;; success: + node) + +(ical:define-component ical:standard "STANDARD" + "Represents a Standard Time observance in a time zone. + +The observance has a start time, specified by an +`icalendar-dtstart' property, which is required in this component +and must be in *local* time format. The observance may have a +recurring onset (e.g. each year on a particular day or date) +described by the `icalendar-rrule' and `icalendar-rdate' +properties. An end date for the observance, if there is one, must +be specified in the UNTIL clause of the `icalendar-rrule' in UTC +time. + +The offset from UTC time when the observance begins is specified +in the `icalendar-tzoffsetfrom' property, which is required. The +offset from UTC time while the observance is in effect is +specified by the `icalendar-tzoffsetto' property, which is also +required. A common identifier for the time zone observance can be +specified in the `icalendar-tzname' property. Other explanatory +comments can be provided in `icalendar-comment'. + +This component must be a direct child of an `icalendar-vtimezone' +component and cannot contain other subcomponents." + :child-spec (:one (ical:dtstart + ical:tzoffsetto + ical:tzoffsetfrom) + :zero-or-one (ical:rrule) + :zero-or-more (ical:comment + ical:rdate + ical:tzname + ical:other-property) + :other-validator ical:rrule-validator) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.5") + +(ical:define-component ical:daylight "DAYLIGHT" + "Represents a Daylight Savings Time observance in a time zone. + +The observance has a start time, specified by an +`icalendar-dtstart' property, which is required in this component +and must be in *local* time format. The observance may have a +recurring onset (e.g. each year on a particular day or date) +described by the `icalendar-rrule' and `icalendar-rdate' +properties. An end date for the observance, if there is one, must +be specified in the UNTIL clause of the `icalendar-rrule' in UTC +time. + +The offset from UTC time when the observance begins is specified +in the `icalendar-tzoffsetfrom' property, which is required. The +offset from UTC time while the observance is in effect is +specified by the `icalendar-tzoffsetto' property, which is also +required. A common identifier for the time zone observance can be +specified in the `icalendar-tzname' property. Other +explanatory comments can be provided in `icalendar-comment'. + +This component must be a direct child of an `icalendar-vtimezone' +component and cannot contain other subcomponents." + :child-spec (:one (ical:dtstart + ical:tzoffsetto + ical:tzoffsetfrom) + :zero-or-one (ical:rrule) + :zero-or-more (ical:comment + ical:rdate + ical:tzname + ical:other-property) + :other-validator ical:rrule-validator) + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.5") + +(ical:define-component ical:valarm "VALARM" + "Represents an alarm. + +An alarm is a notification or reminder for an event or task. The +type of notification is determined by this component's +`icalendar-action' property: it may be an AUDIO, DISPLAY, or +EMAIL notification. +If it is an audio alarm, it can include an +`icalendar-attach' property specifying the audio to be rendered. +If it is a DISPLAY alarm, it must include an `icalendar-description' +property containing the text to be displayed. +If it is an EMAIL alarm, it must include both an +`icalendar-summary' and an `icalendar-description', which specify +the subject and body of the email, and one or more +`icalendar-attendee' properties, which specify the recipients. + +The required `icalendar-trigger' property specifies when the +alarm triggers. If the alarm repeats, then `icalendar-duration' +and `icalendar-repeat' properties are also both required. + +This component must occur as a direct child of an +`icalendar-vevent' or `icalendar-vtodo' component, and cannot +contain any subcomponents." + :child-spec (:one (ical:action ical:trigger) + :zero-or-one (ical:duration ical:repeat) + :zero-or-more (ical:summary + ical:description + ical:attendee + ical:attach + ical:other-property)) + :other-validator ical:valarm-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6.6") + +(defun ical:valarm-validator (node) + "Additional validator function for `icalendar-valarm' components. +Checks that NODE has the right properties corresponding to its +`icalendar-action' type, e.g., that an EMAIL alarm has a +subject (`icalendar-summary') and recipients (`icalendar-attendee'). + +This function is called by `icalendar-ast-node-valid-p' for +VALARM nodes; it is not normally necessary to call it directly." + (let* ((action (ical:ast-node-first-child-of 'ical:action node)) + (duration (ical:ast-node-first-child-of 'ical:duration node)) + (repeat (ical:ast-node-first-child-of 'ical:repeat node)) + (child-counts (ical:count-children-by-type node))) + + (when (and duration (not repeat)) + (ical:signal-validation-error + (concat "`icalendar-valarm' node with `icalendar-duration' " + "must also have `icalendar-repeat' property") + :node node)) + + (when (and repeat (not duration)) + (ical:signal-validation-error + (concat "`icalendar-valarm' node with `icalendar-repeat' " + "must also have `icalendar-duration' property") + :node node)) + + (let ((action-str (upcase (ical:text-to-string + (ical:ast-node-value action))))) + (cond ((equal "AUDIO" action-str) + (unless (<= (alist-get 'ical:attach child-counts 0) 1) + (ical:signal-validation-error + (concat "AUDIO `icalendar-valarm' may not have " + "more than one `icalendar-attach'") + :node node)) + node) + + ((equal "DISPLAY" action-str) + (unless (= 1 (alist-get 'ical:description child-counts 0)) + (ical:signal-validation-error + (concat "DISPLAY `icalendar-valarm' must have " + "exactly one `icalendar-description'") + :node node)) + node) + + ((equal "EMAIL" action-str) + (unless (= 1 (alist-get 'ical:summary child-counts 0)) + (ical:signal-validation-error + (concat "EMAIL `icalendar-valarm' must have " + "exactly one `icalendar-summary'") + :node node)) + (unless (= 1 (alist-get 'ical:description child-counts 0)) + (ical:signal-validation-error + (concat "EMAIL `icalendar-valarm' must have " + "exactly one `icalendar-description'") + :node node)) + (unless (<= 1 (alist-get 'ical:attendee child-counts 0)) + (ical:signal-validation-error + (concat "EMAIL `icalendar-valarm' must have " + "at least one `icalendar-attendee'") + :node node)) + node) + + (t + ;; "Applications MUST ignore alarms with x-name and iana-token + ;; values they don't recognize." So this is not a validation-error: + (ical:warn + (format "Unknown ACTION value in VALARM: %s" action-str) + :buffer (ical:ast-node-meta-get node :buffer) + :position (ical:ast-node-meta-get node :value-begin)) + node))))) + +(ical:define-component ical:other-component nil + "Component type for unrecognized component names. + +This component type corresponds to the IANA and X-name components +allowed by RFC5545 sec. 3.6; it represents components with an +unknown name (matching rx `icalendar-iana-token' or +`icalendar-x-name') which must be parsed and preserved but not +further interpreted." + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.6") + +;; Technically VCALENDAR is not a "component", but for the +;; purposes of parsing and syntax highlighting, it looks just like +;; one, so we define it as such here. +;; (If this becomes a problem, modify `ical:component-node-p' +;; to return nil for VCALENDAR components.) +(ical:define-component ical:vcalendar "VCALENDAR" + "Calendar Object. + +This is the top-level data structure defined by RFC5545. A +VCALENDAR must contain the calendar properties `icalendar-prodid' +and `icalendar-version', and may contain the calendar properties +`icalendar-method' and `icalendar-calscale'. + +It must also contain at least one VEVENT, VTODO, VJOURNAL, +VFREEBUSY, or other component, and for every unique +`icalendar-tzidparam' value appearing in a property within these +components, the calendar object must contain an +`icalendar-vtimezone' defining a time zone with that TZID." + :child-spec (:one (ical:prodid ical:version) + :zero-or-one (ical:calscale ical:method) + :zero-or-more (ical:other-property + ical:vevent + ical:vtodo + ical:vjournal + ical:vfreebusy + ical:vtimezone + ical:other-component)) + :other-validator ical:vcalendar-validator + :link "https://www.rfc-editor.org/rfc/rfc5545#section-3.4") + +(defun ical:all-tzidparams-in (node) + "Recursively find all `icalendar-tzidparam' values in NODE and its children." + (cond ((ical:tzid-param-p node) + (list (ical:ast-node-value node))) + ((ical:param-node-p node) + nil) + (t ;; TODO: could prune search here when properties don't allow tzidparam + (seq-uniq (mapcan #'ical:all-tzidparams-in + (ical:ast-node-children node)))))) + +(defun ical:vcalendar-validator (node) + "Additional validator for `icalendar-vcalendar' NODE. + +Checks that NODE has at least one component child and that all of the +`ical-tzidparam' values appearing in subcomponents have a corresponding +`icalendar-vtimezone' definition. + +This function is called by `icalendar-ast-node-valid-p' for +VCALENDAR nodes; it is not normally necessary to call it directly." + (let* ((children (ical:ast-node-children node)) + (comp-children (seq-filter #'ical:component-node-p children)) + (tz-children (seq-filter #'ical:vtimezone-component-p children)) + (defined-tzs + (mapcar + (lambda (tz) + ;; ensure vtimezone component has a TZID property and + ;; extract its string value: + (when (ical:ast-node-valid-p tz) + (ical:with-component tz ((ical:tzid :value-node tzid-text)) + (ical:text-to-string tzid-text)))) + tz-children)) + (appearing-tzids (ical:all-tzidparams-in node))) + (unless comp-children + (ical:signal-validation-error + "`icalendar-vcalendar' must contain at least one component" + :node node)) + + (let ((seen nil)) + (dolist (tzid appearing-tzids) + (unless (member tzid seen) + (unless (member tzid defined-tzs) + (ical:signal-validation-error + (format "No `icalendar-vtimezone' with TZID '%s' in calendar" tzid) + :node node))) + (push tzid seen))) + + ;; success: + node)) + +(declare-function icr:tz-set-zones-in "icalendar-recur") + +(defun ical:contains-vcalendar-p (&optional buffer) + "Determine whether BUFFER contains \"BEGIN:VCALENDAR\". + +If so, then BUFFER is a candidate for parsing with, e.g., +`icalendar-parse-calendar'. BUFFER defaults to the current +buffer. Returns the position where parsing should start, or nil." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^BEGIN:VCALENDAR" nil t) + (beginning-of-line) + (point))))) + +;; `icalendar-parse-component' is sufficient to parse all the syntax in +;; a calendar, but a calendar-level parsing function is needed to add +;; support for time zones. This function ensures that every +;; `icalendar-tzidparam' in the calendar has a corresponding +;; `icalendar-vtimezone' component, and modifies the zone information of +;; the parsed date-time according to the offset in that time zone. +(defun ical:parse-calendar (limit) + "Parse an `icalendar-vcalendar' object from point up to LIMIT. +Point should be at the start of the calendar object, i.e., at the start +of a line that looks like \"BEGIN:VCALENDAR\". After parsing, point is +at the beginning of the next line following the calendar (or end of the +buffer). Returns a syntax node representing the calendar." + (require 'icalendar-recur) ; for icr:tz-set-zones-in; avoids circular require + (unless (looking-at-p "^BEGIN:VCALENDAR") + (ical:signal-parse-error "Not at start of VCALENDAR")) + (let ((cal-node (ical:parse-component limit))) + ;(when (ical:ast-node-valid-p cal-node t) + (ical:with-component cal-node + ((ical:vtimezone :all tzs)) + ;; After parsing the whole calendar, set the zone and dst slots + ;; in all date-times which are relative to a time zone defined + ;; in the calendar: + ;; (TODO: if this proves too slow in general, we could instead + ;; do it lazily when individual components are queried somehow. + ;; But I'm not convinced that will actually save any time, because + ;; if we're parsing, we're probably already in the middle of a + ;; function that will immediately query all these times, e.g. + ;; `diary-icalendar-import-buffer'.) + (dolist (comp (ical:ast-node-children cal-node)) + (unless (ical:vtimezone-component-p comp) + (icr:tz-set-zones-in tzs comp))));) + cal-node)) + +;; TODO: should we do anything to *create* VTIMEZONE nodes in VCALENDAR +;; when they're required but don't exist? +(defun ical:print-calendar-node (vcalendar) + "Serialize an `icalendar-vcalendar' VCALENDAR to a string. + +If VCALENDAR is not a valid `icalendar-vcalendar', an +`icalendar-validation-error' will be signaled. Any errors that arise +during printing will be logged in the buffer returned by +`icalendar-error-buffer'." + (when (ical:ast-node-valid-p vcalendar t) + (condition-case err + (ical:print-component-node vcalendar) + (ical:print-error + (ical:handle-print-error err))))) + + +;;; High-level parsing and printing functions. +(defun ical:parse (&optional buffer) + "Parse an `icalendar-vcalendar' object in BUFFER (default: current buffer). + +An unfolded copy of BUFFER (see `icalendar-unfolded-buffer-from-buffer') +will first be obtained if necessary. Parsing will begin at the first +occurrence of \"BEGIN:VCALENDAR\" in the unfolded buffer. + +The buffer may be tidied up by user functions before parsing begins; see +`icalendar-pre-unfolding-hook' and `icalendar-pre-parsing-hook'. + +If parsing is successful, the VCALENDAR object is returned. Otherwise, +nil is returned, a warning is issued, and errors are logged in the +buffer returned by `icalendar-error-buffer'." + (let* ((buf (or buffer (current-buffer))) + (unfolded (cond ((ical:unfolded-p buf) buf) + ((buffer-file-name buf) + (ical:unfolded-buffer-from-file (buffer-file-name buf))) + (t (ical:unfolded-buffer-from-buffer buf))))) + (ical:init-error-buffer) + (with-current-buffer unfolded + (run-hooks 'ical:pre-parsing-hook) + (let ((cal-start (ical:contains-vcalendar-p)) + vcalendar) + (unless cal-start + (ical:signal-parse-error "Buffer does not contain \"BEGIN:VCALENDAR\"")) + (save-excursion + (goto-char cal-start) + (ical:condition-case err + (setq vcalendar (ical:parse-calendar (point-max))) + (ical:parse-error + (ical:handle-parse-error err) + (warn "Errors while parsing %s; see buffer %s" + buffer (buffer-name (ical:error-buffer)))))) + vcalendar)))) + +;; TODO: The function `ical:print' below is not really useful yet. +;; Feels like it's needed for completeness but interface needs more thought. +;; Should this instead be a generic function that prints any +;; kind of node at point? at a given marker? +;; What about the coding system? If we want to use this function to print +;; iCalendar data to stdout, need to set up coding system correctly and +;; perform line folding. +;; Etc. +;; +;; (defun ical:print (vcalendar &optional buffer pos) +;; "Insert VCALENDAR as a string at position POS in BUFFER. +;; +;; VCALENDAR should be an `icalendar-vcalendar'. BUFFER defaults to the +;; current buffer and POS defaults to point. +;; +;; If printing is successful, VCALENDAR is returned. Otherwise, nil is +;; returned, a warning is issued, and errors are logged in the buffer +;; returned by `icalendar-error-buffer'." +;; (with-current-buffer (or buffer (current-buffer)) +;; (when pos (goto-char pos)) +;; (condition-case err +;; (insert (ical:print-calendar-node vcalendar)) +;; (ical:print-error +;; (ical:handle-print-error err) +;; (setq vcalendar nil) ; return +;; (warn "Errors while printing; see buffer %s" +;; (buffer-name (ical:error-buffer))))) +;; vcalendar)) + + +;;; Pre-parsing cleanup +;; +;; The following functions are based on observed syntax errors in +;; real-world data and can help clean up such data before parsing. +;; More functions can be added here based on user feedback. +(defcustom ical:pre-parsing-hook nil + "Hook run by `icalendar-parse' before parsing iCalendar data. + +If you routinely receive iCalendar data in an incorrect format, you can +add functions to this hook which clean up that data before parsing is +attempted. The functions in this hook will be run after the iCalendar +data has been \"unfolded\" but before parsing begins. (If you need to +clean up data before unfolding happens, see +`icalendar-pre-unfolding-hook'.) + +Each function should accept zero arguments and should perform its +operation on the entire current buffer." + :version "31.1" + :type '(hook) + :options '(ical:fix-blank-lines + ical:fix-hyphenated-dates + ical:fix-missing-mailtos)) + +(defun ical:fix-blank-lines () + "Remove blank lines. +This function is intended to be used from `icalendar-pre-parsing-hook', +which see." + (goto-char (point-min)) + (while (re-search-forward (rx "\n" (zero-or-more space) line-end) + nil t) + (replace-match "" nil nil))) + +(defun ical:fix-hyphenated-dates () + "Correct dates in \"YYYY-MM-DD...\" format to \"YYYYMMDD...\" format. +This function is intended to be used from `icalendar-pre-parsing-hook', +which see." + (goto-char (point-min)) + (while (re-search-forward + (rx line-start + (or "COMPLETED" "DTEND" "DUE" "DTSTART" "RECURRENCE-ID" + "EXDATE" "RDATE" "CREATED" "DTSTAMP" "LAST-MODIFIED") + (zero-or-more ical:other-param-safe) + ":") + nil t) + (unless (looking-at-p (rx (or ical:date ical:date-time))) + (while (re-search-forward ; exdate, rdate allow lists + (rx (group-n 1 (= 4 digit)) + "-" + (group-n 2 (= 2 digit)) + "-" + (group-n 3 (= 2 digit))) + (line-end-position) t) + (replace-match "\\1\\2\\3" nil nil))))) + +(defun ical:fix-missing-mailtos () + "Insert \"mailto:\" when it is missing before email addresses. +This function is intended to be used from `icalendar-pre-parsing-hook', +which see." + ;; fix property values in properties that require an address: + (goto-char (point-min)) + (while (re-search-forward + (rx line-start (or "ORGANIZER" "ATTENDEE") + (zero-or-more ical:other-param-safe) ":") + nil t) + (unless (looking-at-p (rx ical:cal-address)) + (when (looking-at + (rx + ;; match local part of mail address: all the characters + ;; allowed after a URI scheme, *except* + ;; ?@ (so we can match that after) and + ;; ?: (in case we're looking at a non-"mailto:" scheme) + (group-n 1 + (one-or-more + (any "A-Za-z0-9" ?- ?. ?_ ?~ ?/ ?? ?# ?\[ ?\] ?! ?$ ?& ?' + ?\( ?\) ?* ?+ ?, ?\; ?= ?%))) + "@")) + (when (or (< (length (match-string 0)) 7) + (not (equal "mailto:" + (substring (downcase (match-string 0)) 0 7)))) + (replace-match "mailto:\\1" nil nil nil 1))))) + + ;; fix parameter values in parameters that require an address: + (goto-char (point-min)) + (while (re-search-forward + (rx line-start ical:name + (zero-or-more icalendar-other-param-safe) + ";" + (or "DELEGATED-FROM" "DELEGATED-TO" "MEMBER" "SENT-BY") + "=") + nil t) + (unless (looking-at-p (rx ical:cal-address)) + (while ; DELEGATED* params accept lists + (looking-at + (rx + ?\" ; values of these params must always be quoted + (group-n 1 ; matches local part of mail address as above + (one-or-more + (any "A-Za-z0-9" ?- ?. ?_ ?~ ?/ ?? ?# ?\[ ?\] ?! ?$ ?& ?' + ?\( ?\) ?* ?+ ?, ?= ?%))) + "@" + (zero-or-more (not ?\")) + ?\" + (zero-or-one ","))) + (when (or (< (length (match-string 1)) 7) + (not (equal "mailto:" + (substring (downcase (match-string 1)) 0 7)))) + (replace-match "mailto:\\1" nil nil nil 1)) + (goto-char (match-end 0)))))) + + +;;; Caching and indexing parse trees +;; +;; The following functions provide a simple in-memory cache and index +;; for faster access to parsed iCalendar data by date, UID, and other +;; fields of interest. The index and parse tree are stored in a +;; buffer-local variable of the parsed buffer and not recomputed if the +;; buffer hasn't changed. Most users of the library should just call +;; `icalendar-parse-and-index' to get both the parse tree and a +;; reference to the index, and get objects of interest from them +;; with `icalendar-index-get'. +(defun ical:make-index () + "Create an empty index of iCalendar components." + (list :bydate (make-hash-table :test #'equal) ;; date => list of components + :byuid (make-hash-table :test #'equal) ;; UID => component + :bytzid (make-hash-table :test #'equal) ;; tzid => vtimezone + :recurring (list))) ;; list of components + +(defun ical:index-insert-tz (index vtimezone) + "Insert VTIMEZONE into INDEX." + (ical:with-component vtimezone + ((ical:tzid :value tzid)) + (let ((tzid-index (plist-get index :bytzid))) + (puthash tzid vtimezone tzid-index) + ;; Update and return the index: + (plist-put index :bytzid tzid-index)))) + +(declare-function icr:recurrences-to-count "icalendar-recur") +(declare-function ical:date/time-to-local "icalendar-utils") +(declare-function ical:date/time-to-date "icalendar-utils") +(declare-function ical:dates-until "icalendar-utils") + +(defun ical:index-insert (index component) + "Insert COMPONENT into INDEX." + (require 'icalendar-recur) ; avoid circular imports + (require 'icalendar-utils) ; + (ical:with-component component + ((ical:dtstart :first dtstart-node :value dtstart) + (ical:dtend :first dtend-node :value dtend) + (ical:due :value due) + (ical:duration :value duration) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes) + (ical:exdate :all exdate-nodes) + (ical:uid :value uid)) + (let ((date-index (plist-get index :bydate)) + (uid-index (plist-get index :byuid)) + (tzid-index (plist-get index :bytzid)) + (recurring (plist-get index :recurring)) + (rdates + (mapcar #'ical:ast-node-value + (apply #'append (mapcar #'ical:ast-node-value rdate-nodes)))) + (exdates + (mapcar #'ical:ast-node-value + (apply #'append (mapcar #'ical:ast-node-value exdate-nodes)))) + dates) + ;; Everything with a UID goes into the uid-index: + (when uid + (puthash uid component uid-index)) + ;; For all top-level components, we gather a list of dates on which + ;; they recur for date-index, or put them in the recurring list: + (when dtstart + (cond + ;; If the component has an RRULE that specifies a fixed number + ;; of recurrences, compute them now and index them for each date + ;; in each recurrence: + ((and recur-value (ical:recur-count recur-value)) + (let* ((tz (gethash (ical:with-param-of dtstart-node 'ical:tzidparam) + tzid-index)) + (recs (cons dtstart (icr:recurrences-to-count component tz)))) + (dolist (rec recs) + (let ((end-time + (when duration (ical:date/time-add-duration rec duration)))) + (setq dates + (append dates + (if end-time (ical:dates-until rec end-time t) + (list (ical:date/time-to-date + (ical:date/time-to-local rec)))))))))) + ;; Same with RDATEs when there's no RRULE: + ((and rdates (not recur-value)) + (dolist (rec (cons dtstart rdates)) + (unless (or (cl-typep rec 'ical:period) (member rec exdates)) + (let ((end-time + (when duration + (ical:date/time-add-duration rec duration)))) + (setq dates + (append dates + (if end-time (ical:dates-until rec end-time t) + (list (ical:date/time-to-date + (ical:date/time-to-local rec)))))))) + (when (cl-typep rec 'ical:period) + (let* ((start (ical:period-start rec)) + (end (or (ical:period-end rec) + (ical:date/time-add-duration + start (ical:period-dur-value rec))))) + (setq dates (append dates (ical:dates-until start end t))))))) + ;; A non-recurring event also gets an index entry for each date + ;; until its end time: + ((not recur-value) + (let ((end-time + (or dtend due + (when duration + (ical:date/time-add-duration dtstart duration))))) + (setq dates (if end-time (ical:dates-until dtstart end-time t) + (list + (ical:date/time-to-date + (ical:date/time-to-local dtstart))))))) + ;; Otherwise, we put off the computation of recurrences until queried: + (t (push component recurring))) + + (dolist (date (seq-uniq dates)) + (let ((others (gethash date date-index))) + ;; TODO: wonder if we should normalize, and instead store UIDs + ;; in the date index, then look them up by UID when queried. + (puthash date (cons component others) date-index)))) + + ;; Return the updated index: + (setq index (plist-put index :byuid uid-index)) + (setq index (plist-put index :bytzid tzid-index)) + (setq index (plist-put index :bydate date-index)) + (setq index (plist-put index :recurring recurring)) + index))) + +(defun ical:index-populate-from-calendar (index vcalendar) + "Insert all components in VCALENDAR into INDEX." + (let* ((tzs (ical:ast-node-children-of 'ical:vtimezone vcalendar)) + (vevents (ical:ast-node-children-of 'ical:vevent vcalendar)) + (vjournals (ical:ast-node-children-of 'ical:vjournal vcalendar)) + (vtodos (ical:ast-node-children-of 'ical:vtodo vcalendar)) + ;; TODO: customizable selection? what about valarms? + (to-index (append vevents vjournals vtodos))) + + ;; First insert the tzs, so that they're available when inserting + ;; the others by date: + (dolist (tz tzs) + (setq index (ical:index-insert-tz index tz))) + + (dolist (component to-index) + (setq index (ical:index-insert index component))) + index)) + +(declare-function icr:find-interval "icalendar-recur") +(declare-function icr:recurrences-in-interval "icalendar-recur") +(declare-function ical:date/time-in-period-p "icalendar-utils") +(declare-function ical:date/time<= "icalendar-utils") +(declare-function ical:date/time< "icalendar-utils") +(declare-function ical:date/time-add-duration "icalendar-utils") + +(cl-defun ical:index-get (index &rest args &key date uid tzid) + "Get an iCalendar component from INDEX by date, UID, or TZID. + +INDEX should be a reference to a parse tree index as returned by +`icalendar-parse-and-index', which see. The index can be queried by: + +:uid UID (string, see `icalendar-uid') - returns the component with that + UID. + +:tzid TZID (string, see `icalendar-tzid' and `icalendar-tzidparam') - + returns the `icalendar-vtimezone' component with that TZID. + +:date DT (an `icalendar-date', i.e. a list (M D Y)) - returns a list of + the components occurring (or recurring) on that date. + +Only one keyword argument can be queried at a time." + (require 'icalendar-recur) ; avoid circular imports + (require 'icalendar-utils) ; + (when (length> args 2) + (error "Only one keyword argument can be queried")) + (cond (uid (gethash uid (plist-get index :byuid))) + (tzid (gethash tzid (plist-get index :bytzid))) + (date + (let ((computed (gethash date (plist-get index :bydate))) + (recurring (plist-get index :recurring))) + (dolist (component recurring) + (ical:with-component component + ((ical:dtstart :first dtstart-node :value dtstart) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes) + (ical:duration :value duration)) + (unless (ical:date/time<= date dtstart) + (let* ((tz (ical:with-param-of dtstart-node 'ical:tzidparam nil + (gethash value (plist-get index :bytzid)))) + (int (icr:find-interval date dtstart recur-value tz)) + (recs (icr:recurrences-in-interval int component tz))) + (catch 'found + (dolist (rec recs) + (let* ((local-rec (ical:date/time-to-local rec)) + (end + (when duration + (ical:date/time-add-duration local-rec duration))) + (rec-dates + (if end (ical:dates-until local-rec end t) + (list (ical:date/time-to-date local-rec))))) + (when (member date rec-dates) + (push component computed) + (throw 'found nil)))) + (dolist (node rdate-nodes) + ;; normal RDATE recurrences have already been + ;; checked above, but we check whether `date' + ;; occurs in any RDATE period values here: + (when (eq 'ical:period + (ical:value-type-from-params + (ical:ast-node-children node))) + (let* ((tz + (ical:with-param-of node 'ical:tzidparam nil + (gethash value (plist-get index :bytzid))))) + (ical:with-property node nil + (dolist (period values) + (when (ical:date/time-in-period-p date period tz) + (push component computed) + (throw 'found nil)))))))))))) + computed)) + (t (error "At least one of :uid, :tzid, or :date is required")))) + +;; Buffer local variable to cache the index and parse tree. +;; Format: (TICKS VCALENDAR INDEX) +;; TICKS is the value of (buffer-modified-tick) at last parse +(defvar-local ical:-parsed-calendar-and-index '(0 nil nil)) + +(defun ical:parse-and-index (&optional buffer-or-file) + "Parse and index the first iCalendar VCALENDAR object in BUFFER-OR-FILE. + +Returns a list (VCALENDAR INDEX), where VCALENDAR is the parsed +`icalendar-vcalendar' syntax tree. The index can then be queried to +retrieve components from this calendar by UID, TZID, or date; see +`icalendar-index-get'. + +BUFFER-OR-FILE may be a buffer or a string containing a filename; it +defaults to the current buffer. If it is a filename, an unfolded buffer +containing its data will be found, or created if necessary (see +`icalendar-unfolded-buffer-from-file'). The resulting buffer must +contain an iCalendar VCALENDAR object, which will be parsed and indexed. + +The results of parsing and indexing are cached in buffer-local +variables, and subsequent calls with the same BUFFER-OR-FILE will return +the cached results as long as the buffer has not been modified in the +meantime." + (let* ((buffer (cond ((null buffer-or-file) (current-buffer)) + ((bufferp buffer-or-file) buffer-or-file) + ((and (stringp buffer-or-file) + (file-exists-p buffer-or-file)) + (find-buffer-visiting buffer-or-file)))) + (file-name (cond (buffer (buffer-file-name buffer)) + ((and (stringp buffer-or-file) + (file-exists-p buffer-or-file)) + (expand-file-name buffer-or-file)))) + (unfolded (cond ((and buffer (ical:unfolded-p buffer)) + buffer) + (file-name + (or (ical:find-unfolded-buffer-visiting file-name) + (ical:unfolded-buffer-from-file file-name))) + (buffer + (ical:unfolded-buffer-from-buffer buffer)) + (t + (error "Unable to get unfolded buffer for '%s'" + buffer-or-file))))) + (with-current-buffer unfolded + (when (ical:contains-vcalendar-p) + (if (eql (car ical:-parsed-calendar-and-index) (buffer-modified-tick)) + (cdr ical:-parsed-calendar-and-index) + (message "Parsing and indexing iCalendar data in %s..." (buffer-name)) + (let ((vcalendar (ical:parse))) + (when vcalendar + (setq ical:-parsed-calendar-and-index + (list + (buffer-modified-tick) + vcalendar + (ical:index-populate-from-calendar (ical:make-index) + vcalendar))) + (message "Parsing and indexing iCalendar data in %s...Done." + (buffer-name)) + (cdr ical:-parsed-calendar-and-index)))))))) + + + +;;; Documentation for all of the above via `describe-symbol': +(defun ical:documented-symbol-p (sym) + "Return non-nil if SYM is a symbol with iCalendar documentation." + (or (get sym 'icalendar-type-documentation) + ;; grammatical categories defined with rx-define, but with no + ;; other special icalendar docs: + (and (get sym 'rx-definition) + (length> (symbol-name sym) 10) + (equal "icalendar-" (substring (symbol-name sym) 0 10))))) + +(defun ical:documentation (sym buf frame) + "iCalendar documentation backend for `describe-symbol-backends'." + (ignore buf frame) ; Silence the byte compiler + (with-help-window (help-buffer) + (with-current-buffer standard-output + (let* ((type-doc (get sym 'icalendar-type-documentation)) + (link (get sym 'icalendar-link)) + (rx-def (get sym 'rx-definition)) + (rx-doc (when rx-def + (with-output-to-string + (pp rx-def)))) + (value-rx-def (get sym 'ical:value-rx)) + (value-rx-doc (when value-rx-def + (with-output-to-string + (pp value-rx-def)))) + (values-rx-def (get sym 'ical:values-rx)) + (values-rx-doc (when values-rx-def + (with-output-to-string + (pp values-rx-def)))) + + (full-doc + (concat + (when type-doc + (format "`%s' is an iCalendar type:\n\n%s\n\n" + sym type-doc)) + (when link + (format "For further information see\nURL `%s'\n\n" link)) + ;; FIXME: this is probably better done in rx.el! + ;; TODO: could also generalize this to recursively + ;; search rx-def for any symbol that starts with "icalendar-"... + (when rx-def + (format "`%s' is an iCalendar grammar category. +Its `rx' definition is:\n\n%s%s%s" + sym + rx-doc + (if value-rx-def + (format "\nIndividual values must match:\n%s" + value-rx-doc) + "") + (if values-rx-def + (format "\nLists of values must match:\n%s" + values-rx-doc) + ""))) + "\n"))) + + (insert full-doc) + full-doc)))) + + +(defconst ical:describe-symbol-backend + '(nil icalendar-documented-symbol-p icalendar-documentation) + "Entry for icalendar documentation in `describe-symbol-backends'.") + +(push ical:describe-symbol-backend describe-symbol-backends) + +;; Unloading: +(defun ical:parser-unload-function () + "Unload function for `icalendar-parser'." + (mapatoms + (lambda (sym) + (when (string-match "^icalendar-" (symbol-name sym)) + (makunbound sym) + (fmakunbound sym)))) + + (setq describe-symbol-backends + (remq ical:describe-symbol-backend describe-symbol-backends)) + ;; Proceed with normal unloading: + nil) + +(provide 'icalendar-parser) + +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-") ("icr:" . "icalendar-recur-")) +;; End: +;;; icalendar-parser.el ends here diff --git a/lisp/calendar/icalendar-recur.el b/lisp/calendar/icalendar-recur.el new file mode 100644 index 00000000000..2f9045f278e --- /dev/null +++ b/lisp/calendar/icalendar-recur.el @@ -0,0 +1,1993 @@ +;;; icalendar-recur.el --- Support for iCalendar recurrences and time zones -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Richard Lawrence + +;; Author: Richard Lawrence +;; Created: December 2024 +;; Keywords: calendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This is a sub-library for working with recurrence rules and time +;; zones, as defined by RFC5545 (see especially Secs. 3.3.10 and +;; 3.8.5.3, which are required reading before you make any changes to +;; the code below) and related standards (especially RFC8984 Sec. 4.3, +;; also strongly recommended reading). Recurrence rules and time zones +;; are mutually dependent: to calculate the date and time of future +;; instances of a recurring event, you must be able to apply time zone +;; rules; and to apply time zone rules, you must be able to calculate +;; the date and time of recurring events, namely the shifts between +;; observances of standard and daylight savings time. For example, an +;; event that occurs "on the last Friday of every month at 11AM" in a +;; given time zone should recur at 11AM daylight savings time in July, +;; but 11AM standard time in January, for a typical time zone that +;; shifts from standard to DST and back once each year. These shifts +;; occur at, say, "the last Sunday in March at 2AM" and "the first +;; Sunday in November at 2AM". So to calculate an absolute time for a +;; given instance of the original event, you first have to calculate the +;; nearest instance of the shift between standard and daylight savings +;; time, which itself involves applying a recurrence rule of the same +;; form. +;; +;; This mutual dependence between recurrence rules and time zones is not +;; a *vicious* circle, because the shifts between time zone observances +;; have fixed offsets from UTC time which are made explicit in iCalendar +;; data. But it does make things complicated. RFC5545 focuses on making +;; recurrence rules expressive enough to cover existing practices, +;; including time zone observance shifts, rather than on being easy to +;; implement. +;; +;; So be forewarned: here be dragons. The code here was difficult to get +;; working, in part because this mutual dependence means it is difficult +;; to implement anything less than the whole system, in part because +;; recurrence rules are very flexible in order to cover as many +;; practical uses as possible, in part because time zone practices are +;; themselves complicated, and in part because there are a *lot* of edge +;; cases to worry about. Much of it is tedious and repetitive but +;; doesn't lend itself to further simplification or abstraction. If you +;; need to make changes, make them slowly, and use the tests in +;; test/lisp/calendar/icalendar-recur-tests.el to make sure they don't +;; break anything. +;; +;; Notation: `date/time' with a slash in symbol names means "`date' or +;; `date-time'", i.e., is a way of indicating that a function can +;; accept either type of value, and `dt' is typically used for an +;; argument of either type. `date-time' should always refer to *just* +;; date-time values, not plain (calendar-style) dates. + +;;; Code: +(require 'icalendar-ast) +(require 'icalendar-parser) +(require 'icalendar-utils) +(require 'cl-lib) +(require 'calendar) +(require 'simple) +(require 'seq) +(eval-when-compile '(require 'icalendar-macs)) + + +;; Recurrence Intervals +;; +;; Two important ideas in the following: +;; +;; 1) Because recurrence sets are potentially infinite, we always +;; calculate recurrences within certain upper and lower bounds. These +;; bounds might be determined by a user interface (e.g. the week or +;; month displayed in a calendar) or might be derived from the logic of +;; the recurrence rule itself. In the former case, where the bounds can +;; be arbitrary, it's called a 'window' here (as in "window of +;; time"). In the latter case, it's called an 'interval' here (after the +;; "INTERVAL=..." clause in recurrence rules). +;; +;; Unlike a window, an interval must be synced up with the recurrence +;; rule: its bounds must fall at successive integer multiples of the +;; product of the recurrence rule's FREQ and INTERVAL values, relative +;; to a starting date/time. For example, a recurrence rule with a +;; MONTHLY frequency and INTERVAL=3 will have an interval that is three +;; months long. If its start date is, e.g., in November, then the first +;; interval runs from November to February, the next from February to +;; May, and so on. Because intervals depend only on the starting +;; date/time, the frequency, and the interval length, it is relatively +;; straightforward to compute the bounds of the interval surrounding an +;; arbitrary point in time (without enumerating them successively from +;; the start time); see `icalendar-recur-find-interval', which calls +;; this arbitrary point in time the 'target'. +;; +;; 2) An interval is the smallest unit of time for which we compute +;; values of the recurrence set. This is because the "BYSETPOS=..." +;; clause in a recurrence rule operates on the sequence of recurrences +;; in a single interval. Since it selects recurrences by their index in +;; this sequence, the sequence must have a determinate length and known +;; bounds. The function `icalendar-recur-recurrences-in-interval' is the +;; main function to compute recurrences in a given interval. +;; +;; The way to compute the recurrences in an arbitrary *window* is thus +;; to find the interval bounds which are closest to the window's lower +;; and upper bound, and then compute the recurrences for all the +;; intervals in between, i.e., that "cover" the window. This is what the +;; function `icalendar-recur-recurrences-in-window' does. +;; +;; Note that the recurrence set for a recurrence rule with a COUNT +;; clause cannot be computed for an arbitrary interval (or window); +;; instead, the set must be enumerated from the beginning, so that the +;; enumeration can stop after a fixed number of recurrences. This is +;; what the function `icalendar-recur-recurrences-to-count' does. But +;; also in this case, recurrences are generated for one interval at a +;; time, because a BYSETPOS clause might apply. +;; +;; An interval is represented as a list (LOW HIGH NEXT-LOW) of decoded +;; times. The length of time between LOW and HIGH corresponds to the +;; FREQ rule part: they are one year apart for a 'YEARLY rule, a month +;; apart for a 'MONTHLY rule, etc. NEXT-LOW is the upper bound of the +;; interval: it is equal to LOW in the subsequent interval. When the +;; INTERVAL rule part is equal to 1 (the default), HIGH and NEXT-LOW are +;; the same, but if it is > 1, NEXT-LOW is equal to LOW + INTERVAL * +;; FREQ. For example, in a 'MONTHLY rule where INTERVAL=3, which means +;; "every three months", LOW and HIGH bound the first month, while HIGH +;; and NEXT-LOW bound the following two months. +;; +;; The times between LOW and HIGH are candidates for recurrences. LOW +;; is an inclusive lower bound, and HIGH is an exclusive upper bound: +;; LOW <= R < HIGH for each recurrence R in the interval. The times +;; between HIGH and NEXT-LOW are not candidates for recurrences. +;; +;; The following functions deal with constructing intervals, given a +;; target, a start date/time, and intervalsize, and optionally a time +;; zone. The main entry point is `icalendar-recur-find-interval'. + +;; Look, dragons already: +(defun icr:find-absolute-interval (target dtstart intervalsize freqs + &optional vtimezone) + "Find a recurrence interval based on a fixed number of seconds. + +INTERVALSIZE should be the total size of the interval in seconds. FREQS +should be the number of seconds between the lower bound of the interval +and the upper bound for candidate recurrences; it is the number of +seconds in the unit of time in a recurrence rule's FREQ part. The +returned interval looks like (LOW LOW+FREQS LOW+INTERVALSIZE). See +`icalendar-recur-find-interval' for other arguments' meanings." + ;; We assume here that the interval needs to be calculated using + ;; absolute times for SECONDLY, MINUTELY, and HOURLY rules. + ;; There are two reasons for this: + ;; + ;; 1) Time zone shifts. If we don't use absolute times, and instead + ;; find interval boundaries using local clock times with e.g. + ;; `ical:date/time-add' (as we do with time units of a day or + ;; greater below), we have to adjust for clock time changes. Using + ;; absolute times is simpler. + ;; 2) More problematically, using local clock times, at least in its + ;; most straightforward implementation, has pathological results + ;; when `intervalsize' is relatively prime with 60 (for a SECONDLY + ;; rule, similarly for the others): intervals generated by + ;; successive enumeration from one target value will not in general + ;; align with intervals generated from a different, but nearby, + ;; target value. (So going this route seems to mean giving up on + ;; the idea that intervals can be calculated just from `target', + ;; `dtstart' and `intervalsize', and instead always enumerating + ;; them from the beginning.) + ;; + ;; In effect, we are deciding that a rule like "every 3 hours" always + ;; means every 3 * 60 * 60 = 10800 seconds after `dtstart', and not + ;; "every 10800 seconds, except when there's a time zone observance + ;; change". People who want the latter have another option: use a + ;; DAILY rule and specify the (local) times for the hours they want in + ;; the BYHOUR clause, etc. (People who want it for a number of hours, + ;; e.g. 7, which does not divide 24, unfortunately do *not* have this + ;; option, but anyone who wants that but does not want to understand + ;; "7 hours" as a fixed number of seconds has a pathology that I + ;; cannot cure here.) + ;; + ;; RFC5545 does not seem to pronounce one way or the other on whether + ;; this decision is correct: there are no examples of SECONDLY rules + ;; to go on, and the few examples for MINUTELY and HOURLY rules only + ;; use "nice" values in the INTERVAL clause (real-life examples + ;; probably(?) will too). Our assumption has some possibly + ;; unintuitive consequences for `intervalsize' values that are not + ;; "nice" (basically, whenever intervalsize and either 60 or 24 are + ;; relatively prime), and for how interval boundaries behave at the + ;; shifts between time zone observances (since local clock times in + ;; the interval bounds will shift from what they would have been + ;; before the observance change -- arguably correct but possibly + ;; surprising, depending on the case). But the alternative seems + ;; worse, so until countervailing evidence emerges, this approach + ;; seems reasonable. + (let* ((given-start-zone (decoded-time-zone dtstart)) + (start-w/zone (cond (given-start-zone dtstart) + ((ical:vtimezone-component-p vtimezone) + (ical:date-time-variant dtstart :tz vtimezone)) + (t + ;; "Floating" time should be interpreted in user's + ;; current time zone; see RFC5545 Sec 3.3.5 + (ical:date-time-variant + dtstart :zone (car (current-time-zone)))))) + (start-abs (ignore-errors + (time-convert (encode-time start-w/zone) 'integer))) + (given-target-zone (decoded-time-zone target)) + (target-w/zone (cond (given-target-zone target) + (vtimezone + (ical:date-time-variant target :tz vtimezone)) + (t + (ical:date-time-variant + target :zone (car (current-time-zone)))))) + (target-abs (ignore-errors + (time-convert (encode-time target-w/zone) 'integer))) + low-abs low high next-low) + + (unless (zerop (mod intervalsize freqs)) + ;; Bad things will happen if intervalsize is not an integer + ;; multiple of freqs + (error "FREQS=%d does not divide INTERVALSIZE=%d" freqs intervalsize)) + (unless (and start-abs target-abs) + (when (not start-abs) + (error "Could not determine an offset for DTSTART=%s" dtstart)) + (when (not target-abs) + (error "Could not determine an offset for TARGET=%s" target))) + + ;; Find the lower bound below target that is the closest integer + ;; multiple of intervalsize seconds from dtstart + (setq low-abs (- target-abs + (mod (- target-abs start-abs) intervalsize))) + + (if vtimezone + (setq low (icr:tz-decode-time low-abs vtimezone) + high (icr:tz-decode-time (+ low-abs freqs) vtimezone) + next-low (icr:tz-decode-time (+ low-abs intervalsize) vtimezone)) + ;; best we can do is decode into target's zone: + (let ((offset (decoded-time-zone target-w/zone))) + (setq low (icr:tz-decode-time low-abs offset) + high (icr:tz-decode-time (+ low-abs freqs) offset) + next-low (icr:tz-decode-time (+ low-abs intervalsize) offset)))) + + (unless (and given-start-zone given-target-zone) + ;; but if we started with floating times, we should return floating times: + (setf (decoded-time-zone low) nil) + (setf (decoded-time-dst low) -1) + (setf (decoded-time-zone high) nil) + (setf (decoded-time-dst high) -1) + (setf (decoded-time-zone next-low) nil) + (setf (decoded-time-dst next-low) -1)) + + (list low high next-low))) + +(defun icr:find-secondly-interval (target dtstart intervalsize &optional vtimezone) + "Find a SECONDLY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (icr:find-absolute-interval + target + dtstart + intervalsize + 1 + vtimezone)) + +(defun icr:find-minutely-interval (target dtstart intervalsize &optional vtimezone) + "Find a MINUTELY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (icr:find-absolute-interval + target + ;; A MINUTELY interval always runs from the beginning of a minute to + ;; the beginning of the next minute: + (ical:date-time-variant dtstart :second 0 :tz 'preserve) + (* 60 intervalsize) + 60 + vtimezone)) + +(defun icr:find-hourly-interval (target dtstart intervalsize &optional vtimezone) + "Find an HOURLY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (icr:find-absolute-interval + target + ;; An HOURLY interval always runs from the beginning of an hour to + ;; the beginning of the next hour: + (ical:date-time-variant dtstart :minute 0 :second 0 :tz 'preserve) + (* 60 60 intervalsize) + (* 60 60) + vtimezone)) + +(defun icr:find-daily-interval (target dtstart intervalsize &optional vtimezone) + "Find a DAILY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (let* ((start-absdate (calendar-absolute-from-gregorian + (ical:date/time-to-date dtstart))) + (target-absdate (calendar-absolute-from-gregorian + (ical:date/time-to-date target))) + ;; low-absdate is the closest absolute date below target that + ;; is an integer multiple of intervalsize days from dtstart + (low-absdate (- target-absdate + (mod (- target-absdate start-absdate) intervalsize))) + (high-absdate (1+ low-absdate)) + (next-low-absdate (+ low-absdate intervalsize))) + + (let* ((low-dt (ical:date-to-date-time + (calendar-gregorian-from-absolute low-absdate))) + (high-dt (ical:date-to-date-time + (calendar-gregorian-from-absolute high-absdate))) + (next-low-dt (ical:date-to-date-time + (calendar-gregorian-from-absolute next-low-absdate)))) + + (when vtimezone + (icr:tz-set-zone low-dt vtimezone) + (icr:tz-set-zone high-dt vtimezone) + (icr:tz-set-zone next-low-dt vtimezone)) + + ;; Return the bounds: + (list low-dt high-dt next-low-dt)))) + +(defun icr:find-weekly-interval (target dtstart intervalsize + &optional weekstart vtimezone) + "Find a WEEKLY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (let* ((target-date (ical:date/time-to-date target)) + (start-date (ical:date/time-to-date dtstart)) + ;; the absolute dates of the week start before target and + ;; dtstart; these are always a whole number of weeks apart: + (target-week-abs (calendar-nth-named-absday + -1 + (or weekstart 1) + (calendar-extract-month target-date) + (calendar-extract-year target-date) + (calendar-extract-day target-date))) + (start-abs (calendar-nth-named-absday + -1 + (or weekstart 1) + (calendar-extract-month start-date) + (calendar-extract-year start-date) + (calendar-extract-day start-date))) + (intsize-days (* 7 intervalsize)) + ;; the absolute date of the week start before target which is + ;; an integer multiple of intervalsize weeks from dtstart: + (low-abs (- target-week-abs + (mod (- target-week-abs start-abs) intsize-days))) + ;; then use this to find the interval bounds: + (low (ical:date-to-date-time + (calendar-gregorian-from-absolute low-abs))) + (high (ical:date-to-date-time + (calendar-gregorian-from-absolute (+ 7 low-abs)))) + (next-low (ical:date-to-date-time + (calendar-gregorian-from-absolute (+ intsize-days low-abs))))) + + (when vtimezone + (icr:tz-set-zone low vtimezone) + (icr:tz-set-zone high vtimezone) + (icr:tz-set-zone next-low vtimezone)) + + ;; Return the bounds: + (list low high next-low))) + +(defun icr:find-monthly-interval (target dtstart intervalsize &optional vtimezone) + "Find a MONTHLY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (let* ((start-month (ical:date/time-month dtstart)) + (start-year (ical:date/time-year dtstart)) + ;; we calculate in "absolute months", i.e., number of months + ;; since the beginning of the Gregorian calendar, to make + ;; finding the lower bound easier: + (start-abs-months (+ (* 12 (1- start-year)) (1- start-month))) + (target-month (ical:date/time-month target)) + (target-year (ical:date/time-year target)) + (target-abs-months (+ (* 12 (1- target-year)) (1- target-month))) + ;; number of "absolute months" between start of dtstart's month + ;; and start of target's month: + (nmonths (- target-abs-months start-abs-months)) + ;; the number of months after dtstart that is the closest integer + ;; multiple of intervalsize months before target: + (lmonths (- nmonths (mod nmonths intervalsize))) + ;; convert these "absolute months" back to Gregorian month and year: + (mod-month (mod (+ start-month lmonths) 12)) + (low-month (if (zerop mod-month) 12 mod-month)) + (low-year (+ (/ lmonths 12) start-year + ;; iff we cross a year boundary moving forward in + ;; time from start-month to target-month, we need + ;; to add one to the year: + (if (<= start-month target-month) 0 1))) + ;; and now we can use these to calculate the interval bounds: + (low (ical:make-date-time :year low-year :month low-month :day 1 + :hour 0 :minute 0 :second 0 :tz vtimezone)) + (high (ical:date/time-add low :month 1 vtimezone)) + (next-low (ical:date/time-add low :month intervalsize vtimezone))) + + ;; Return the bounds: + (list low high next-low))) + +(defun icr:find-yearly-interval (target dtstart intervalsize &optional vtimezone) + "Find a YEARLY recurrence interval. +See `icalendar-recur-find-interval' for arguments' meanings." + (let* ((start-year (ical:date/time-year dtstart)) + (target-year (ical:date/time-year target)) + ;; The year before target that is the closest integer multiple + ;; of intervalsize years after dtstart: + (low-year (- target-year + (mod (- target-year start-year) intervalsize))) + (low (ical:make-date-time :year low-year :month 1 :day 1 + :hour 0 :minute 0 :second 0 :tz vtimezone)) + (high (ical:make-date-time :year (1+ low-year) :month 1 :day 1 + :hour 0 :minute 0 :second 0 :tz vtimezone)) + (next-low (ical:make-date-time :year (+ low-year intervalsize) + :month 1 :day 1 :hour 0 :minute 0 :second 0 + :tz vtimezone))) + + ;; Return the bounds: + (list low high next-low))) + +(defun icr:find-interval (target dtstart recur-value &optional vtimezone) + "Return the recurrence interval around TARGET. + +TARGET and DTSTART should be `icalendar-date' or `icalendar-date-time' +values. RECUR-VALUE should be an `icalendar-recur'. + +The returned value is a list (LOW HIGH NEXT-LOW) which +represents the lower and upper bounds of a recurrence interval around +TARGET. For some N, LOW is equal to START + N*INTERVALSIZE units, HIGH +is equal to START + (N+1)*INTERVALSIZE units, and LOW <= TARGET < HIGH. +START here is a time derived from DTSTART depending on RECUR-VALUE's +FREQ part: the first day of the year for a \\='YEARLY rule, first day +of the month for a \\='MONTHLY rule, etc. + +RECUR-VALUE's interval determines INTERVALSIZE, and its frequency +determines the units: a month for \\='MONTHLY, etc. + +If VTIMEZONE is provided, it is used to set time zone information in the +returned interval bounds. Otherwise, the bounds contain no time zone +information and represent floating local times." + (let ((freq (ical:recur-freq recur-value)) + (intsize (ical:recur-interval-size recur-value)) + (weekstart (ical:recur-weekstart recur-value))) + (cl-case freq + (SECONDLY (icr:find-secondly-interval target dtstart intsize vtimezone)) + (MINUTELY (icr:find-minutely-interval target dtstart intsize vtimezone)) + (HOURLY (icr:find-hourly-interval target dtstart intsize vtimezone)) + (DAILY (icr:find-daily-interval target dtstart intsize vtimezone)) + (WEEKLY (icr:find-weekly-interval target dtstart intsize + weekstart vtimezone)) + (MONTHLY (icr:find-monthly-interval target dtstart intsize vtimezone)) + (YEARLY (icr:find-yearly-interval target dtstart intsize vtimezone))))) + +(defun icr:nth-interval (n dtstart recur-value &optional vtimezone) + "Return the Nth recurrence interval after DTSTART. + +The returned value is a list (LOW HIGH NEXT-LOW) which represent the Nth +recurrence interval after DTSTART. LOW is equal to START + +N*INTERVALSIZE units, HIGH is equal to START + (N+1)*INTERVALSIZE units, +and LOW <= TARGET < HIGH. START here is a time derived from DTSTART +depending on RECUR-VALUE's FREQ part: the first day of the year for a +\\='YEARLY rule, first day of the month for a \\='MONTHLY rule, etc. + +RECUR-VALUE's interval determines INTERVALSIZE, and its frequency +determines the units: a month for \\='MONTHLY, etc. + +N should be a non-negative integer. Interval 0 is the interval +containing DTSTART. DTSTART should be an `icalendar-date' or +`icalendar-date-time' value. RECUR-VALUE should be an +`icalendar-recur'. + +If VTIMEZONE is provided, it is used to set time zone information in the +returned interval bounds. Otherwise, the bounds contain no time zone +information and represent floating local times." + (when (< n 0) (error "Recurrence interval undefined for negative N")) + (let* ((start-dt (if (cl-typep dtstart 'ical:date) + (ical:date-to-date-time dtstart :tz vtimezone) + dtstart)) + (freq (ical:recur-freq recur-value)) + (intervalsize (ical:recur-interval-size recur-value)) + (unit (cl-case freq + (YEARLY :year) + (MONTHLY :month) + (WEEKLY :week) + (DAILY :day) + (HOURLY :hour) + (MINUTELY :minute) + (SECONDLY :second))) + (target (ical:date/time-add start-dt unit (* n intervalsize) vtimezone))) + (icr:find-interval target dtstart recur-value vtimezone))) + +(defun icr:next-interval (interval recur-value &optional vtimezone) + "Return the next recurrence interval after INTERVAL. + +Given a recurrence interval (LOW HIGH NEXT), returns the next interval +\(NEXT HIGHER HIGHER-NEXT), where HIGHER and HIGHER-NEXT are determined +by the frequency and interval sizes of RECUR-VALUE." + (let* ((new-low (caddr interval)) + (freq (ical:recur-freq recur-value)) + (unit (cl-case freq + (YEARLY :year) + (MONTHLY :month) + (WEEKLY :week) + (DAILY :day) + (HOURLY :hour) + (MINUTELY :minute) + (SECONDLY :second))) + (intervalsize (ical:recur-interval-size recur-value)) + (new-high (ical:date/time-add new-low unit 1 vtimezone)) + (new-next (ical:date/time-add new-low unit intervalsize vtimezone))) + + (when vtimezone + (icr:tz-set-zone new-low vtimezone) + ;; (icr:tz-set-zone new-high vtimezone) + ;; (icr:tz-set-zone new-next vtimezone) + ) + + (list new-low new-high new-next))) + +(defun icr:previous-interval (interval recur-value dtstart &optional vtimezone) + "Given a recurrence INTERVAL, return the previous interval. + +For an interval (LOW HIGH NEXT-LOW), the previous interval is +\(PREV-LOW PREV-HIGH LOW), where PREV-LOW and PREV-HIGH are determined by +the frequency and interval sizes of RECUR-VALUE (see +`icalendar-recur-find-interval'). If the resulting period of time +between PREV-LOW and PREV-HIGH occurs entirely before DTSTART, then the +interval does not exist; in this case nil is returned." + (let* ((upper (car interval)) + (freq (ical:recur-freq recur-value)) + (unit (cl-case freq + (YEARLY :year) + (MONTHLY :month) + (WEEKLY :week) + (DAILY :day) + (HOURLY :hour) + (MINUTELY :minute) + (SECONDLY :second))) + (intervalsize (ical:recur-interval-size recur-value)) + (new-low (ical:date/time-add upper unit (* -1 intervalsize) vtimezone)) + (new-high (ical:date/time-add new-low unit 1 vtimezone))) + + (when vtimezone + ;; (icr:tz-set-zone new-low vtimezone) + ;; (icr:tz-set-zone new-high vtimezone) + (icr:tz-set-zone upper vtimezone)) + + (unless (ical:date-time< new-high dtstart) + (list new-low new-high upper)))) + + + +;; Refining intervals into subintervals +;; +;; For a given interval, the various BY*=... clauses in a recurrence +;; rule specify the recurrences in that interval. +;; +;; RFC5545 unfortunately has an overly-complicated conceptual model for +;; how recurrences are to be calculated which is based on "expanding" or +;; "limiting" the recurrence set for each successive clause. This model +;; is difficult to think about and implement, and the text of the +;; standard is ambiguous. I did not succeed in producing a working +;; implementation based on the description in the standard, and the +;; existing implementations don't seem to agree on how it's to be +;; implemented anyway. +;; +;; Fortunately, RFC8984 (JSCalendar) is a forthcoming standard which +;; attempts to resolve the ambiguities while being semantically +;; backward-compatible with RFC5545. It provides a much cleaner +;; conceptual model: the recurrence set is generated by starting with a +;; list of candidates, which consist of every second in (what is here +;; called) an interval, and then filtering out any candidates which do +;; not match the rule's clauses. The most straightforward implementation +;; of this model, however, is unusably slow in typical cases. Consider +;; for example the case of calculating the onset of daylight savings +;; time in a given year: the interval is a year long, so it consists of +;; over 31 million seconds. Although it's easy to generate Lisp +;; timestamps for each of those seconds, filtering them through the +;; various BY* clauses means decoding each of those timestamps, which +;; means doing a fairly expensive computation over 31 million times, and +;; then throwing away the result in all but one case. When I implemented +;; this model, I was not patient enough to sit through the calculations +;; for even MONTHLY rules (which on my laptop took minutes). +;; +;; So instead of implementing RFC8984's model directly, the strategy +;; here is to do something equivalent but much more efficient: rather +;; than thinking of an interval as consisting of a set of successive +;; seconds, we think of it as described by its bounds; and for each BY* +;; clause, we *refine* the interval into subintervals by computing the +;; bounds of each subinterval corresponding to the value(s) in that +;; clause. For example, in a YEARLY rule, the initial interval is one +;; year long, say all of 2025. If it has a "BYMONTH=4,10" clause, then +;; we refine this interval into two subintervals, each one month long: +;; one for April 2025 and one for October 2025. This is much more +;; efficient in the typical case, because the number of bounds which +;; describe the final set of subintervals is usually *much* smaller than +;; the number of seconds in the original interval. +;; +;; The following functions are responsible for computing these +;; refinements. The main entry point here is +;; `icalendar-recur-refine-from-clauses', which takes care of +;; successively refining the interval both by the explicit values in the +;; rule's clauses and by the implicit values in DTSTART. (There, too, +;; RFC8984 is helpful: it gives a much more explicit description of how +;; the information in DTSTART interacts with the BY* clauses to further +;; refine the subintervals.) + +(defun icr:refine-byyearday (interval yeardays &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching YEARDAYS. + +YEARDAYS should be a list of values from a recurrence rule's +BYYEARDAY=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-ydays (sort yeardays + :lessp (lambda (a b) + (let ((pos-a (if (< 0 a) a (+ 366 a))) + (pos-b (if (< 0 b) b (+ 366 b)))) + (< pos-a pos-b))))) + (interval-start (car interval)) + (start-year (decoded-time-year interval-start)) + (interval-end (cadr interval)) + (end-year (decoded-time-year interval-end)) + (subintervals nil)) + (while (<= start-year end-year) + ;; For each year in the interval... + (dolist (n sorted-ydays) + ;; ...the subinterval is one day long on the nth yearday + (let* ((nthday (calendar-date-from-day-of-year start-year n)) + (low (ical:make-date-time :year start-year + :month (calendar-extract-month nthday) + :day (calendar-extract-day nthday) + :hour 0 :minute 0 :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :day 1 vtimezone))) + ;; "Clip" the subinterval bounds if they fall outside the + ;; interval. Careful! This clipping can lead to high <= low, + ;; so need to check it is still the case that low < high + ;; before pushing the subinterval + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date-time<= interval-start low) + (ical:date-time< low high) + (ical:date-time<= high interval-end)) + (push (list low high) subintervals)))) + + (setq start-year (1+ start-year))) + (nreverse subintervals))) + +(defun icr:refine-byweekno (interval weeknos &optional weekstart vtimezone) + "Resolve INTERVAL into a list of subintervals matching WEEKNOS. + +WEEKNOS should be a list of values from a recurrence rule's +BYWEEKNO=... clause, and WEEKSTART should be the value of its +WKST=... clause (if any). See `icalendar-recur' for the possible values." + (let* ((sorted-weeknos (sort weeknos + :lessp (lambda (a b) + (let ((pos-a (if (< 0 a) a (+ 53 a))) + (pos-b (if (< 0 b) b (+ 53 b)))) + (< pos-a pos-b))))) + (interval-start (car interval)) + (start-year (decoded-time-year interval-start)) + (interval-end (cadr interval)) + (end-year (decoded-time-year interval-end)) + (subintervals nil)) + (while (<= start-year end-year) + ;; For each year in the interval... + (dolist (wn sorted-weeknos) + ;; ...the subinterval is one week long in the wn-th week + (let* ((nth-wstart (ical:start-of-weekno wn start-year weekstart)) + (low (ical:make-date-time :year (calendar-extract-year nth-wstart) + :month (calendar-extract-month nth-wstart) + :day (calendar-extract-day nth-wstart) + :hour 0 :minute 0 :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :day 7 vtimezone))) + ;; "Clip" the subinterval bounds if they fall outside the + ;; interval, as above. This can happen often here because week + ;; boundaries generally do not align with year boundaries. + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date-time<= interval-start low) + (ical:date-time< low high) + (ical:date-time<= high interval-end)) + (push (list low high) subintervals)))) + (setq start-year (1+ start-year))) + (nreverse subintervals))) + +(defun icr:refine-bymonth (interval months &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching MONTHS. + +MONTHS should be a list of values from a recurrence rule's +BYMONTH=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-months (sort months)) + (interval-start (car interval)) + (start-year (decoded-time-year interval-start)) + (interval-end (cadr interval)) + (end-year (decoded-time-year interval-end)) + (subintervals nil)) + (while (<= start-year end-year) + ;; For each year in the interval... + (dolist (m sorted-months) + ;; ...the subinterval is from the first day of the given month + ;; to the first day of the next + (let* ((low (ical:make-date-time :year start-year :month m :day 1 + :hour 0 :minute 0 :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :month 1 vtimezone))) + + ;; Clip the subinterval bounds, as above + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time< low high) + (ical:date/time<= high interval-end)) + (push (list low high) subintervals)))) + (setq start-year (1+ start-year))) + + (nreverse subintervals))) + +(defun icr:refine-bymonthday (interval monthdays &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching MONTHDAYS. + +MONTHDAYS should be a list of values from a recurrence rule's +BYMONTHDAY=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-mdays (sort monthdays + :lessp (lambda (a b) + (let ((pos-a (if (< 0 a) a (+ 31 a))) + (pos-b (if (< 0 b) b (+ 31 b)))) + (< pos-a pos-b))))) + (interval-start (car interval)) + (interval-end (cadr interval)) + (subintervals nil)) + (while (ical:date-time<= interval-start interval-end) + ;; For each month in the interval... + (dolist (m sorted-mdays) + ;; ...the subinterval is one day long on the given monthday + (let* ((month (ical:date/time-month interval-start)) + (year (ical:date/time-year interval-start)) + (monthday (if (< 0 m) m + (+ m 1 (calendar-last-day-of-month month year)))) + (low (ical:date-time-variant interval-start :day monthday + :hour 0 :minute 0 :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :day 1 vtimezone))) + + (ignore-errors ; ignore invalid dates, e.g. 2025-02-29 + ;; Clip subinterval, as above + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time< low high) + (ical:date/time<= high interval-end)) + (push (list low high) subintervals))))) + (setq interval-start + (ical:date/time-add interval-start :month 1 vtimezone))) + (nreverse subintervals))) + +(defun icr:refine-byday (interval weekdays &optional in-month vtimezone) + "Refine INTERVAL to days matching the given WEEKDAYS. + +WEEKDAYS should be a list of values from a recurrence rule's +BYDAY=... clause; see `icalendar-recur' for the possible values. + +If WEEKDAYS contains pairs (DOW . OFFSET), then IN-MONTH indicates +whether OFFSET is relative to the month of the start of the interval. If +it is nil, OFFSET will be relative to the year, rather than the month." + (let* ((sorted-weekdays (sort (seq-filter #'natnump weekdays))) + (with-offsets (sort (seq-filter #'consp weekdays) + :lessp (lambda (w1 w2) (and (< (car w1) (car w2)))))) + (interval-start (car interval)) + (start-abs (calendar-absolute-from-gregorian + (ical:date-time-to-date interval-start))) + (interval-end (cadr interval)) + (end-abs (calendar-absolute-from-gregorian + (ical:date-time-to-date interval-end))) + (subintervals nil)) + + ;; For days where an offset was given, the subinterval is a single + ;; weekday relative to the month or year of interval-start: + (dolist (wo with-offsets) + (let* ((dow (car wo)) + (offset (cdr wo)) + (low-date + (ical:nth-weekday-in offset dow + (ical:date/time-year interval-start) + (when in-month + (ical:date/time-month interval-start)))) + (low (ical:date-to-date-time low-date :tz vtimezone)) + (high (ical:date/time-add low :day 1 vtimezone))) + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when vtimezone + (icr:tz-set-zone low vtimezone) + (icr:tz-set-zone high vtimezone)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time<= high interval-end) + (ical:date/time< low high)) + (push (list low high) subintervals)))) + + ;; When no offset was given, for each day in the interval... + (while (and (<= start-abs end-abs) + sorted-weekdays) + ;; ...the subinterval is one day long on matching weekdays. + (let* ((gdate (calendar-gregorian-from-absolute start-abs))) + (when (memq (calendar-day-of-week gdate) sorted-weekdays) + (let* ((low (ical:date-to-date-time gdate)) + (high (ical:date/time-add low :day 1 vtimezone))) + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when vtimezone + (icr:tz-set-zone low vtimezone) + (icr:tz-set-zone high vtimezone)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time<= high interval-end) + (ical:date/time< low high)) + (push (list low high) subintervals))))) + (setq start-abs (1+ start-abs))) + + ;; Finally, sort and return all subintervals: + (sort subintervals + :lessp (lambda (int1 int2) + (ical:date-time< (car int1) (car int2))) + :in-place t))) + +(defun icr:refine-byhour (interval hours &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching HOURS. + +HOURS should be a list of values from a recurrence rule's +BYHOUR=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-hours (sort hours)) + (interval-start (car interval)) + (interval-end (cadr interval)) + (subintervals nil)) + (while (ical:date-time<= interval-start interval-end) + ;; For each day in the interval... + (dolist (h sorted-hours) + ;; ...the subinterval is one hour long in the given hour + (let* ((low (ical:date-time-variant interval-start + :hour h :minute 0 :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :hour 1 vtimezone))) + (ignore-errors ; do not generate subintervals for nonexisting times + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time< low high) + (ical:date/time<= high interval-end)) + (push (list low high) subintervals))))) + (setq interval-start (ical:date/time-add interval-start :day 1 vtimezone))) + (nreverse subintervals))) + +(defun icr:refine-byminute (interval minutes &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching MINUTES. + +MINUTES should be a list of values from a recurrence rule's +BYMINUTE=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-minutes (sort minutes)) + (interval-start (car interval)) + (interval-end (cadr interval)) + ;; we use absolute times (in seconds) for the loop variables in + ;; case the interval crosses the boundary between two observances: + (low-ts (time-convert (encode-time interval-start) 'integer)) + (end-ts (time-convert (encode-time interval-end) 'integer)) + (subintervals nil)) + (while (<= low-ts end-ts) + ;; For each hour in the interval... + (dolist (m sorted-minutes) + ;; ...the subinterval is one minute long in the given minute + (let* ((low (ical:date-time-variant interval-start :minute m :second 0 + :tz vtimezone)) + (high (ical:date/time-add low :minute 1 vtimezone))) + (ignore-errors ; do not generate subintervals for nonexisting times + ;; Clip the subinterval, as above + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time< low high) + (ical:date/time<= high interval-end)) + (push (list low high) subintervals))))) + (setq low-ts (+ low-ts (* 60 60)) + interval-start (if vtimezone (icr:tz-decode-time low-ts vtimezone) + (ical:date/time-add interval-start :hour 1)))) + (nreverse subintervals))) + +(defun icr:refine-bysecond (interval seconds &optional vtimezone) + "Resolve INTERVAL into a list of subintervals matching SECONDS. + +SECONDS should be a list of values from a recurrence rule's +BYSECOND=... clause; see `icalendar-recur' for the possible values." + (let* ((sorted-seconds (sort seconds)) + (interval-start (car interval)) + (interval-end (cadr interval)) + ;; we use absolute times (in seconds) for the loop variables in + ;; case the interval crosses the boundary between two observances: + (low-ts (time-convert (encode-time interval-start) 'integer)) + (end-ts (time-convert (encode-time interval-end) 'integer)) + (subintervals nil)) + (while (<= low-ts end-ts) + ;; For each minute in the interval... + (dolist (s sorted-seconds) + ;; ...the subinterval is one second long: the given second + (let* ((low (ical:date-time-variant interval-start :second s + :tz vtimezone)) + (high (ical:date/time-add low :second 1 vtimezone))) + (when (ical:date/time< low interval-start) + (setq low interval-start)) + (when (ical:date/time< interval-end high) + (setq high interval-end)) + (when (and (ical:date/time<= interval-start low) + (ical:date/time< low high) + (ical:date/time<= high interval-end)) + (push (list low high) subintervals)))) + (setq low-ts (+ low-ts 60) + interval-start (if vtimezone + (icr:tz-decode-time low-ts vtimezone) + (ical:date/time-add interval-start :minute 1)))) + (nreverse subintervals))) + +;; TODO: should this just become a generic function, with the above +;; refine-by* functions becoming its methods? +(defun icr:refine-by (unit interval values + &optional byday-inmonth weekstart vtimezone) + "Resolve INTERVAL into a list of subintervals matching VALUES for UNIT." + (cl-case unit + (BYYEARDAY (icr:refine-byyearday interval values vtimezone)) + (BYWEEKNO (icr:refine-byweekno interval values weekstart vtimezone)) + (BYMONTH (icr:refine-bymonth interval values vtimezone)) + (BYMONTHDAY (icr:refine-bymonthday interval values vtimezone)) + (BYDAY (icr:refine-byday interval values byday-inmonth vtimezone)) + (BYHOUR (icr:refine-byhour interval values vtimezone)) + (BYMINUTE (icr:refine-byminute interval values vtimezone)) + (BYSECOND (icr:refine-bysecond interval values vtimezone)))) + +(defun icr:make-bysetpos-filter (setpos) + "Return a filter on values for the indices in SETPOS. + +SETPOS should be a list of positive or negative integers between -366 +and 366, indicating a fixed index in a set of recurrences for *one +interval* of a recurrence set, as found in the BYSETPOS=... clause of +an `icalendar-recur'. For example, in a YEARLY recurrence rule with an +INTERVAL of 1, the SETPOS represent indices in the recurrence instances +generated for a single year. + +The returned value is a closure which can be called on the list of +recurrences for one interval to filter it by index." + (lambda (dts) + (let* ((len (length dts)) + (keep-indices (mapcar + (lambda (pos) + ;; sequence indices are 0-based, POS's are 1-based: + (if (< pos 0) + (+ pos len) + (1- pos))) + setpos))) + (delq nil + (seq-map-indexed + (lambda (dt index) + (when (memq index keep-indices) + dt)) + dts))))) + +(defun icr:refine-from-clauses (interval recur-value dtstart + &optional vtimezone) + "Resolve INTERVAL into subintervals based on the clauses in RECUR-VALUE. + +The resulting list of subintervals represents all times in INTERVAL +which match the BY* clauses of RECUR-VALUE except BYSETPOS, as well as +the constraints implicit in DTSTART. (For example, if there is no +BYMINUTE clause, subintervals will have the same minute value as +DTSTART.) + +If specified, VTIMEZONES should be a list of `icalendar-vtimezone' +components and TZID should be the `icalendar-tzid' property value of one +of those timezones. In this case, TZID states the time zone of DTSTART, +and the offsets effective in that time zone on the dates and times of +recurrences will be local to that time zone." + (let ((freq (ical:recur-freq recur-value)) + (weekstart (ical:recur-weekstart recur-value)) + (subintervals (list interval))) + + (dolist (byunit (list 'BYMONTH 'BYWEEKNO + 'BYYEARDAY 'BYMONTHDAY 'BYDAY + 'BYHOUR 'BYMINUTE 'BYSECOND)) + (let ((values (ical:recur-by* byunit recur-value)) + (in-month nil)) + ;; When there is no explicit BY* clause, use the value implicit + ;; in DTSTART. (These conditions are adapted from RFC8984: + ;; https://www.rfc-editor.org/rfc/rfc8984.html#section-4.3.3.1-4.3.1 + ;; Basically, the conditions are somewhat complicated because + ;; the meanings of various BY* clauses are not independent and + ;; so we have to be careful about the information we take to be + ;; implicit in DTSTART, especially with MONTHLY and YEARLY + ;; rules. For example, we *do* want to take the weekday of + ;; DTSTART as an implicit constraint if a BYWEEKNO clause is + ;; present, but not if an explicit BYDAY or BYMONTHDAY clause is + ;; also present, since they might contain conflicting + ;; constraints.) + (when (and (eq byunit 'BYSECOND) + (not (eq freq 'SECONDLY)) + (not values)) + (setq values (list (ical:date/time-second dtstart)))) + (when (and (eq byunit 'BYMINUTE) + (not (memq freq '(SECONDLY MINUTELY))) + (not values)) + (setq values (list (ical:date/time-minute dtstart)))) + (when (and (eq byunit 'BYHOUR) + (not (memq freq '(SECONDLY MINUTELY HOURLY))) + (not values)) + (setq values (list (ical:date/time-hour dtstart)))) + (when (and (eq byunit 'BYDAY) + (eq freq 'WEEKLY) + (not values)) + (setq values (list (ical:date/time-weekday dtstart)))) + (when (and (eq byunit 'BYMONTHDAY) + (eq freq 'MONTHLY) + (not (ical:recur-by* 'BYDAY recur-value)) + (not values)) + (setq values (list (ical:date/time-monthday dtstart)))) + (when (and (eq freq 'YEARLY) + (not (ical:recur-by* 'BYYEARDAY recur-value))) + (when (and (eq byunit 'BYMONTH) + (not values) + (not (ical:recur-by* 'BYWEEKNO recur-value)) + (or (ical:recur-by* 'BYMONTHDAY recur-value) + (not (ical:recur-by* 'BYDAY recur-value)))) + (setq values (list (ical:date/time-month dtstart)))) + (when (and (eq byunit 'BYMONTHDAY) + (not values) + (not (ical:recur-by* 'BYWEEKNO recur-value)) + (not (ical:recur-by* 'BYDAY recur-value))) + (setq values (list (ical:date/time-monthday dtstart)))) + (when (and (eq byunit 'BYDAY) + (not values) + (ical:recur-by* 'BYWEEKNO recur-value) + (not (ical:recur-by* 'BYMONTHDAY recur-value))) + (setq values (list (ical:date/time-weekday dtstart))))) + + ;; Handle offsets in a BYDAY clause: + ;; "If present, this [offset] indicates the nth occurrence of a + ;; specific day within the MONTHLY or YEARLY "RRULE". For + ;; example, within a MONTHLY rule, +1MO (or simply 1MO) + ;; represents the first Monday within the month, whereas -1MO + ;; represents the last Monday of the month. The numeric value + ;; in a BYDAY rule part with the FREQ rule part set to YEARLY + ;; corresponds to an offset within the month when the BYMONTH + ;; rule part is present" + (when (and (eq byunit 'BYDAY) + (or (eq freq 'MONTHLY) + (and (eq freq 'YEARLY) + (ical:recur-by* 'BYMONTH recur-value)))) + (setq in-month t)) + + ;; On each iteration of the loop, we refine the subintervals + ;; with these explicit or implicit values: + (when values + (setq subintervals + (delq nil + (mapcan (lambda (in) + (icr:refine-by byunit in values in-month + weekstart vtimezone)) + subintervals)))))) + + ;; Finally return the refined subintervals after we've looked at all + ;; clauses: + subintervals)) + +;; Once we have refined an interval into a final set of subintervals, we +;; need to convert those subintervals into a set of recurrences. For a +;; recurrence set where DTSTART and the recurrences are date-times, the +;; recurrence set (in this interval) consists of every date-time +;; corresponding to each second of any subinterval. When DTSTART and the +;; recurrences are plain dates, the recurrence set consists of each +;; distinct date in any subinterval. +(defun icr:subintervals-to-date-times (subintervals &optional vtimezone) + "Transform SUBINTERVALS into a list of `icalendar-date-time' recurrences. + +The returned list of recurrences contains one date-time value for each +second of each subinterval." + (let (recurrences) + (dolist (int subintervals) + (let* ((start (car int)) + (dt start) + ;; Use absolute times for the loop in case the subinterval + ;; crosses the boundary between two observances. + ;; N.B. floating times will be correctly treated as local + ;; times by encode-time. + (end (time-convert (encode-time (cadr int)) 'integer)) + (tick (time-convert (encode-time start) 'integer))) + (while (time-less-p tick end) + (push dt recurrences) + (setq tick (1+ tick) + dt (if vtimezone (icr:tz-decode-time tick vtimezone) + (ical:date/time-add dt :second 1)))))) + (nreverse recurrences))) + +(defun icr:subintervals-to-dates (subintervals) + "Transform SUBINTERVALS into a list of `icalendar-date' recurrences. + +The returned list of recurrences contains one date value for each +day of each subinterval." + (let (recurrences) + (dolist (int subintervals) + (let* ((start (car int)) + (start-abs (calendar-absolute-from-gregorian + (ical:date-time-to-date start))) + (end (cadr int)) + (end-abs (calendar-absolute-from-gregorian + (ical:date-time-to-date end))) + ;; end is an exclusive upper bound, but number-sequence + ;; needs an *inclusive* upper bound, so if end is at + ;; midnight, the bound is the previous day: + (bound (if (zerop (+ (decoded-time-hour end) + (decoded-time-minute end) + (decoded-time-second end))) + (1- end-abs) + end-abs))) + (setq recurrences + (append recurrences + (mapcar #'calendar-gregorian-from-absolute + (number-sequence start-abs bound)))))) + recurrences)) + +(defun icr:subintervals-to-recurrences (subintervals dtstart &optional vtimezone) + "Transform SUBINTERVALS into a list of recurrences. + +The returned list of recurrences contains all distinct values in each +subinterval of the same type as DTSTART." + (if (cl-typep dtstart 'ical:date) + (icr:subintervals-to-dates subintervals) + (icr:subintervals-to-date-times subintervals vtimezone))) + + +;; Calculating recurrences in a given interval or window +;; +;; We can now put all of the above together to compute the set of +;; recurrences in a given interval (`icr:recurrences-in-interval'), and +;; thereby in a given window (`icr:recurences-in-window'); or, if the +;; rule describing the set has a COUNT clause, we can enumerate the +;; recurrences in each interval starting from the beginning of the set +;; (`icr:recurrences-to-count'). +(defun icr:recurrences-in-interval (interval component &optional vtimezone nmax) + "Return a list of the recurrences of COMPONENT in INTERVAL. + +INTERVAL should be a list (LOW HIGH NEXT) of date-times which bound a +single recurrence interval, as returned e.g. by +`icalendar-recur-find-interval'. (To find the recurrences in an +arbitrary window of time, rather than between interval boundaries, see +`icalendar-recur-recurrences-in-window'.) + +COMPONENT should be an iCalendar component node representing a recurring +event: it should contain at least an `icalendar-dtstart' and either an +`icalendar-rrule' or `icalendar-rdate' property. + +If specified, VTIMEZONE should be an `icalendar-vtimezone' component. +In this case, the dates and times of recurrences will be computed with +UTC offsets local to that time zone. + +If specified, NMAX should be a positive integer containing a maximum +number of recurrences to return from this interval. In this case, if the +interval contains more than NMAX recurrences, only the first NMAX +recurrences will be returned; otherwise all recurrences in the interval +are returned. (The NMAX argument mainly exists to support recurrence +rules with a COUNT clause; see `icalendar-recur-recurrences-to-count'.) + +The returned list is a list of `icalendar-date' or `icalendar-date-time' +values representing the start times of recurrences. Note that any +values of type `icalendar-period' in COMPONENT's `icalendar-rdate' +property (or properties) will NOT be included in the list; it is the +callee's responsibility to handle any such values separately. + +The computed recurrences for INTERVAL are cached in COMPONENT and +retrieved on subsequent calls with the same arguments." + (ical:with-component component + ((ical:dtstart :value dtstart) + (ical:tzoffsetfrom :value offset-from) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes) ;; TODO: these can also be ical:period values + (ical:exdate :all exdate-nodes)) + (if (not (or recur-value rdate-nodes)) + ;; No recurrences to calculate, so just return early: + nil + ;; Otherwise, calculate recurrences in the interval: + (when (memq (ical:ast-node-type component) '(ical:standard ical:daylight)) + ;; In time zone observances, set the zone field in dtstart + ;; from the TZOFFSETFROM property: + (setq dtstart + (ical:date-time-variant dtstart + :zone offset-from + :dst (not (ical:daylight-component-p + component))))) + (cl-labels ((get-interval + (apply-partially #'icr:-set-get-interval component)) + (put-interval + (apply-partially #'icr:-set-put-interval component))) + (let ((cached (get-interval interval))) + (cond ((eq cached :none) nil) + (cached cached) + (t + (let* (;; Start by generating all the recurrences matching the + ;; BY* clauses except for BYSETPOS: + (subs (icr:refine-from-clauses interval recur-value dtstart + vtimezone)) + (sub-recs (icr:subintervals-to-recurrences subs dtstart + vtimezone)) + ;; Apply any BYSETPOS clause to this set: + (keep-indices (ical:recur-by* 'BYSETPOS recur-value)) + (pos-recs + (if keep-indices + (funcall (icr:make-bysetpos-filter keep-indices) + sub-recs) + sub-recs)) + ;; Remove any recurrences before DTSTART or after UNTIL + ;; (both of which are inclusive bounds): + (until (ical:recur-until recur-value)) + (until-recs + (seq-filter + (lambda (rec) (and (ical:date/time<= dtstart rec) + (or (not until) + (ical:date/time<= rec until)))) + pos-recs)) + ;; Include any values in the interval from the + ;; RDATE property: + (low (car interval)) + (high (cadr interval)) + (rdates + (mapcar #'ical:ast-node-value + (apply #'append + (mapcar #'ical:ast-node-value + rdate-nodes)))) + (interval-rdates + (seq-filter + (lambda (rec) + ;; only include ical:date and ical:date-time + ;; values from RDATE; callee is responsible + ;; for handling ical:period values + (unless (cl-typep rec 'ical:period) + (and (ical:date/time<= low rec) + (ical:date/time< high rec)))) + rdates)) + (included-recs (append until-recs interval-rdates)) + ;; Exclude any values from the EXDATE property; + ;; this gives us the complete set of recurrences + ;; in this interval: + (exdates + (mapcar #'ical:ast-node-value + (append + (mapcar #'ical:ast-node-value exdate-nodes)))) + (all-recs + (if exdates + (seq-filter + (lambda (rec) (not (member rec exdates))) + included-recs) + included-recs)) + ;; Limit to the first NMAX recurrences if requested. + ;; `icr:recurrences-to-count' provides NMAX so as not to + ;; store more recurrences in the final interval than the + ;; COUNT clause allows: + (nmax-recs + (if nmax (seq-take all-recs nmax) + all-recs))) + ;; Store and return the computed recurrences: + (put-interval interval (or nmax-recs :none)) + nmax-recs)))))))) + +(defun icr:recurrences-in-window (lower upper component &optional vtimezone) + "Return the recurrences of COMPONENT in the window between LOWER and UPPER. + +LOWER and UPPER may be arbitrary `icalendar-date' or +`icalendar-date-time' values. COMPONENT should be an iCalendar component +node representing a recurring event: it should contain at least an +`icalendar-dtstart' and either an `icalendar-rrule' or `icalendar-rdate' +property. + +If specified, VTIMEZONE should be an `icalendar-vtimezone' component. +In this case, the dates and times of recurrences will be computed with +UTC offsets local to that time zone." + (ical:with-component component + ((ical:dtstart :value dtstart) + (ical:tzoffsetfrom :value offset-from) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes)) + (if (not (or recur-value rdate-nodes)) + ;; No recurrences to calculate, so just return early: + nil + ;; Otherwise, calculate the recurrences in the window: + (when (memq (ical:ast-node-type component) '(ical:standard ical:daylight)) + ;; in time zone observances, set the zone field in dtstart + ;; from the TZOFFSETFROM property: + (setq dtstart + (ical:date-time-variant dtstart + :zone offset-from + :dst (not (ical:daylight-component-p + component))))) + + (let* (;; don't look for nonexistent intervals: + (low-start (if (ical:date/time< lower dtstart) dtstart lower)) + (until (ical:recur-until recur-value)) + (high-end (if (and until (ical:date/time< until upper)) until upper)) + (curr-interval (icr:find-interval low-start dtstart recur-value + vtimezone)) + (high-interval (icr:find-interval high-end dtstart recur-value + vtimezone)) + (high-intbound (cadr high-interval)) + (recurrences nil)) + + (while (ical:date-time< (car curr-interval) high-intbound) + (setq recurrences + (append + (icr:recurrences-in-interval curr-interval component vtimezone) + recurrences)) + (setq curr-interval (icr:next-interval curr-interval recur-value + vtimezone))) + + ;; exclude any recurrences inside the first and last intervals but + ;; outside the window before returning: + (seq-filter + (lambda (dt) + (and (ical:date/time<= lower dt) + (ical:date/time< dt upper))) + recurrences))))) + +(defun icr:recurrences-in-window-w/end-times + (lower upper component &optional vtimezone) + "Like `icalendar-recurrences-in-window', but returns end times. + +The return value is a list of (START END) pairs representing the start +and end time of each recurrence of COMPONENT in the window defined by +LOWER and UPPER. + +In the returned pairs, START and END are both `icalendar-date' or +`icalendar-date-time' values of the same type as COMPONENT's +`icalendar-dtstart'. Each END time is computed by adding COMPONENT's +`icalendar-duration' value to START for each recurrence START between +LOWER and UPPER. Or, if the recurrence is given by an `icalendar-period' +value in an `icalendar-rdate' property, START and END are determined by +the period." + (ical:with-component component + ((ical:duration :value duration) + (ical:rdate :all rdate-nodes)) + ;; TODO: for higher-level applications showing a schedule, it might + ;; be useful to include recurrences which start outside the window, + ;; but end inside it. This would mean we can't simply use + ;; `recurrences-in-window' like this. + (let ((starts (icr:recurrences-in-window lower upper component vtimezone)) + (periods (seq-filter + (lambda (vnode) + (when (eq 'ical:period (ical:ast-node-type vnode)) + (ical:ast-node-value vnode))) + (append + (mapcar #'ical:ast-node-value rdate-nodes))))) + (when (or starts periods) + (seq-uniq + (append (mapcar + (lambda (dt) (list dt (ical:date/time-add-duration + dt duration vtimezone))) + starts) + (mapcar + (lambda (p) + (let ((start (ical:period-start p))) + (list start + (or (ical:period-end p) + (ical:date/time-add-duration + start (ical:period-dur-value p) vtimezone))))) + periods))))))) + +(defun icr:recurrences-to-count (component &optional vtimezone) + "Return all the recurrences in COMPONENT up to COUNT in its recurrence rule. + +COMPONENT should be an iCalendar component node representing a recurring +event: it should contain at least an `icalendar-dtstart' and an +`icalendar-rrule', which must contain a COUNT=... clause. + +Warning: this function finds *all* the recurrences in COMPONENT's +recurrence set. If the value of COUNT is large, this can be slow. + +If specified, VTIMEZONE should be an `icalendar-vtimezone' component. +In this case, the dates and times of recurrences will be computed with +UTC offsets local to that time zone." + (ical:with-component component + ((ical:dtstart :value dtstart) + (ical:tzoffsetfrom :value offset-from) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes)) + (when (memq (ical:ast-node-type component) '(ical:standard ical:daylight)) + ;; in time zone observances, set the zone field in dtstart + ;; from the TZOFFSETFROM property: + (setq dtstart + (ical:date-time-variant dtstart + :zone offset-from + :dst (not (ical:daylight-component-p + component))))) + (unless (or recur-value rdate-nodes) + (error "No recurrence data in component: %s" component)) + (unless (ical:recur-count recur-value) + (error "Recurrence rule has no COUNT clause")) + (let ((count (ical:recur-count recur-value)) + (int (icr:nth-interval 0 dtstart recur-value vtimezone)) + recs) + (while (length< recs count) + (setq recs + (append recs (icr:recurrences-in-interval int component vtimezone + (- count (length recs))))) + (setq int (icr:next-interval int recur-value vtimezone))) + recs))) + + + +;; Recurrence set representation +;; +;; We represent a recurrence set as a map from intervals to the +;; recurrences in that interval. The primary purpose of this +;; representation is to memoize the computation of recurrences, since +;; the computation is relatively expensive and the results are needed +;; repeatedly, particularly for time zone observances. The map is stored +;; in the `:recurrence-set' property of the iCalendar component which +;; represents the recurring event. +;; +;; Internally, we use a hash table for the map, since the set can grow +;; quite large. We use the start date-times of intervals as the keys, +;; since these uniquely identify intervals within a given component; we +;; ignore the weekday, zone and dst fields in the keys, mostly to avoid +;; cache misses during time zone observance lookups, which must generate +;; intervals with different zone values. +;; +;; In order to avoid repeating the computation of recurrences, we store +;; the keyword `:none' as the value when there are no recurrences in a +;; given interval. This distinguishes the value from nil, so that, +;; whereas (gethash some-key the-map) => nil means "We haven't computed +;; recurrences yet for this interval", (gethash some-key the-map) => +;; :none means "We've computed that there are no recurrences in this +;; interval", and can skip the computation of recurrences. See +;; `icalendar-recur-recurrences-in-interval', which performs the check. + +(defun icr:-make-set () + (make-hash-table :test #'equal)) + +(defsubst icr:-key-from-interval (interval) + (take 6 (car interval))) ; (secs mins hours day month year) + +(defun icr:-set-get-interval (component interval) + (let ((set (ical:ast-node-meta-get :recurrence-set component)) + (key (icr:-key-from-interval interval))) + (when (hash-table-p set) + (gethash key set)))) + +(defun icr:-set-put-interval (component interval recurrences) + (let ((set (or (ical:ast-node-meta-get :recurrence-set component) + (icr:-make-set))) + (key (icr:-key-from-interval interval))) + (setf (gethash key set) recurrences) + (ical:ast-node-meta-set component :recurrence-set set))) + + +;; Timezones: + +(define-error 'ical:tz-nonexistent-time "Date-time does not exist" 'ical:error) + +(define-error 'ical:tz-no-observance "No observance found for date-time" + 'ical:error) + +;; In RFC5545 Section 3.3.10, we read: "If the computed local start time +;; of a recurrence instance does not exist ... the time of the +;; recurrence instance is interpreted in the same manner as an explicit +;; DATE-TIME value describing that date and time, as specified in +;; Section 3.3.5." which in turn says: +;; "If, based on the definition of the referenced time zone, the local +;; time described occurs more than once (when changing from daylight to +;; standard time), the DATE-TIME value refers to the first occurrence of +;; the referenced time. Thus, TZID=America/New_York:20071104T013000 +;; indicates November 4, 2007 at 1:30 A.M. EDT (UTC-04:00). If the +;; local time described does not occur (when changing from standard to +;; daylight time), the DATE-TIME value is interpreted using the UTC +;; offset before the gap in local times. Thus, +;; TZID=America/New_York:20070311T023000 indicates March 11, 2007 at +;; 3:30 A.M. EDT (UTC-04:00), one hour after 1:30 A.M. EST (UTC-05:00)." + +;; TODO: verify that these functions are correct for time zones other +;; than US Eastern. +(defun icr:nonexistent-date-time-p (dt obs-onset observance) + "Return non-nil if DT does not exist in a given OBSERVANCE. + +Some local date-times do not exist in a given time zone. When switching +from standard to daylight savings time, the local clock time jumps over +a certain range of times. This function tests whether DT is one of those +non-existent local times. + +DT and OBS-ONSET should be `icalendar-date-time' values; OBS-ONSET +should be the (local) time immediately at the onset of the +OBSERVANCE. OBSERVANCE should be an `icalendar-standard' or +`icalendar-daylight' component. + +If this function returns t, then per RFC5545 Section 3.3.5, DT must be +interpreted using the UTC offset in effect prior to the onset of +OBSERVANCE. For example, at the switch from Standard to Daylight +Savings time in US Eastern, the nonexistent time 2:30AM (Standard) must +be re-interpreted as 3:30AM DST." + (when (ical:daylight-component-p observance) + (ical:with-component observance + ((ical:tzoffsetfrom :value offset-from) + (ical:tzoffsetto :value offset-to)) + (and (= (decoded-time-year dt) (decoded-time-year obs-onset)) + (= (decoded-time-month dt) (decoded-time-month obs-onset)) + (= (decoded-time-day dt) (decoded-time-day obs-onset)) + (let* ((onset-secs (+ (decoded-time-second obs-onset) + (* 60 (decoded-time-minute obs-onset)) + (* 60 60 (decoded-time-hour obs-onset)))) + (dt-secs (+ (decoded-time-second dt) + (* 60 (decoded-time-minute dt)) + (* 60 60 (decoded-time-hour dt)))) + (jumped (abs (- offset-from offset-to))) + (after-jumped (+ onset-secs jumped))) + (and + (<= onset-secs dt-secs) + (< dt-secs after-jumped))))))) + +(defun icr:date-time-occurs-twice-p (dt obs-onset observance) + "Return non-nil if DT occurs twice in the given OBSERVANCE. + +Some local date-times occur twice in a given time zone. When switching +from daylight savings to standard time time, the local clock time is +typically set back, so that a certain range of clock times occurs twice, +once in daylight savings time and once in standard time. This function +tests whether DT is one of those local times which occur twice. + +DT and OBS-ONSET should be `icalendar-date-time' values; OBS-ONSET +should be the (local) time immediately at the relevant onset of the +OBSERVANCE. OBSERVANCE should be an `icalendar-standard' or +`icalendar-daylight' component. + +If this function returns t, then per RFC5545 Section 3.3.5, DT must be +interpreted as the first occurrence of this clock time, i.e., in +daylight savings time, prior to OBS-ONSET." + (when (ical:standard-component-p observance) + (ical:with-component observance + ((ical:tzoffsetfrom :value offset-from) + (ical:tzoffsetto :value offset-to)) + (and (= (decoded-time-year dt) (decoded-time-year obs-onset)) + (= (decoded-time-month dt) (decoded-time-month obs-onset)) + (= (decoded-time-day dt) (decoded-time-day obs-onset)) + (let* ((onset-secs (+ (decoded-time-second obs-onset) + (* 60 (decoded-time-minute obs-onset)) + (* 60 60 (decoded-time-hour obs-onset)))) + (dt-secs (+ (decoded-time-second dt) + (* 60 (decoded-time-minute dt)) + (* 60 60 (decoded-time-hour dt)))) + (repeated (abs (- offset-from offset-to))) + (start-repeateds (- onset-secs repeated))) + (and + (<= start-repeateds dt-secs) + (< dt-secs onset-secs))))))) + +(defun icr:tz--get-updated-in (dt obs-onset observance) + "Determine how to update DT's zone and dst slots from OBSERVANCE. + +DT should be an `icalendar-date-time', OBSERVANCE an +`icalendar-standard' or `icalendar-daylight', and OBS-ONSET the nearest +onset of OBSERVANCE before DT. Returns an `icalendar-date-time' that can +be used to update DT. + +In most cases, the return value will contain a zone offset equal to +OBSERVANCE's `icalendar-tzoffsetto' value. + +However, when DT falls within a range of nonexistent times after +OBS-ONSET, or a range of local times that occur twice (see +`icalendar-recur-nonexistent-date-time-p' and +`icalendar-recur-date-time-occurs-twice-p'), it needs to be interpreted +with the UTC offset in effect prior to the OBS-ONSET of OBSERVANCE (see +RFC5545 Section 3.3.5). So e.g. at the switch from Standard to Daylight +in US Eastern, 2:30AM EST (a nonexistent time) becomes 3:30AM EDT, and +at the switch from Daylight to Standard, 1:30AM (which occurs twice) +becomes 1:30AM EDT, the first occurence." + (ical:with-component observance + ((ical:tzoffsetfrom :value offset-from) + (ical:tzoffsetto :value offset-to)) + (let* ((is-daylight (ical:daylight-component-p observance)) + (to-dt (ical:date-time-variant dt :dst is-daylight :zone offset-to)) + (from-dt (ical:date-time-variant dt :dst (not is-daylight) + :zone offset-from)) + updated) + (cond ((icr:nonexistent-date-time-p to-dt obs-onset observance) + ;; In this case, RFC5545 requires that we take the same + ;; point in absolute time as from-dt, but re-decode it into + ;; to-dt's zone: + (setq updated (decode-time (encode-time from-dt) offset-to)) + (setf (decoded-time-dst updated) is-daylight)) + ((icr:date-time-occurs-twice-p to-dt obs-onset observance) + ;; In this case, RFC5545 requires that we interpret dt as + ;; from-dt, since that is the first occurrence of the clock + ;; time in the zone: + (setq updated from-dt)) + (t + ;; Otherwise we interpret dt as to-dt, i.e., with the + ;; offset effective within the observance: + (setq updated to-dt))) + updated))) + +(defun icr:tz-for (tzid vtimezones) + "Return the `icalendar-vtimezone' for the TZID. + +VTIMEZONES should be a list of `icalendar-vtimezone' components. TZID +should be a time zone identifier, as found e.g. in an +`icalendar-tzidparam' parameter. The first time zone in VTIMEZONES whose +`icalendar-tzid' value matches this parameter's value is returned." + (catch 'found + (dolist (tz vtimezones) + (ical:with-component tz + ((ical:tzid :value tzidval)) + (when (equal tzidval tzid) + (throw 'found tz)))))) + +;; DRAGONS DRAGONS DRAGONS +(defun icr:tz-observance-on (dt vtimezone &optional update nonexisting) + "Return the time zone observance in effect on DT in VTIMEZONE. + +If there is such an observance, the returned value is a list (OBSERVANCE +ONSET). OBSERVANCE is an `icalendar-standard' or `icalendar-daylight' +component node. ONSET is the recurrence of OBSERVANCE (an +`icalendar-date-time') which occurs closest in time, but before, DT. + +If there is no such observance in VTIMEZONE, the returned value is nil. + +VTIMEZONE should be an `icalendar-vtimezone' component node. + +DT may be an an `icalendar-date-time' or a Lisp timestamp. If it is a +date-time, it represents a local time assumed to be in VTIMEZONE. Any +existing offset in DT is ignored, and DT is compared with the local +clock time at the start of each observance in VTIMEZONE to determine the +correct observance and onset. (This is so that the correct observance +can be found for clock times generated during recurrence rule +calculations.) + +If UPDATE is non-nil, the observance found will be used to update the +offset value in DT (as a side effect) before returning the observance +and onset. + +If UPDATE is non-nil, NONEXISTING specifies how to handle clock times +that do not exist in the observance (see +`icalendar-recur-tz-nonexistent-date-time-p'). The keyword `:error' +means to signal an \\='icalendar-tz-nonexistent-time error, without +modifying any of the fields in DT. Otherwise, the default is to +interpret DT using the offset from UTC before the onset of the found +observance, and then reset the clock time in DT to the corresponding +existing time after the onset of the observance. For example, the +nonexisting time 2:30AM in Standard time on the day of the switch to +Daylight time in the US Eastern time zone will be reset to 3:30AM +Eastern Daylight time. + +If DT is a Lisp timestamp, it represents an absolute time and +comparisons with the onsets in VTIMEZONE are performed with absolute +times. UPDATE and NONEXISTING have no meaning in this case and are +ignored." + (ical:with-component vtimezone + ((ical:standard :all stds) + (ical:daylight :all dls)) + (let (given-abs-time ;; = `dt', if given a Lisp timestamp + given-clock-time ;; = `dt', if given a decoded time + nearest-observance ;; the observance we're looking for + nearest-onset ;; latest onset of this observance before `dt' + updated) ;; stores how `dt's fields should be updated + ;; in line with this observance, if requested + + (if (cl-typep dt 'ical:date-time) + ;; We were passed a date-time with local clock time, not an + ;; absolute time; in this case, we must make local clock time + ;; comparisons with the observance onset start and recurrences + ;; (in order to determine the correct offset for it within the + ;; zone) + (setq given-clock-time dt + given-abs-time nil) + ;; We were passed an absolute time, not a date-time; in this + ;; case, we can make comparisons in absolute time with + ;; observance onset start and recurrences (in order to determine + ;; the correct offset for decoding it) + (setq given-abs-time dt + given-clock-time nil)) + + (dolist (obs (append stds dls)) + (ical:with-component obs + ((ical:dtstart :value start) + (ical:rrule :value recur-value) + (ical:rdate :all rdate-nodes) + (ical:tzoffsetfrom :value offset-from)) + ;; DTSTART of the observance must be given as local time, and is + ;; combined with TZOFFSETFROM to define the effective onset + ;; for the observance in absolute time. + (let* ((is-daylight (ical:daylight-component-p obs)) + (effective-start + (ical:date-time-variant start :zone offset-from + :dst (not is-daylight))) + (observance-might-apply + (if given-clock-time + (ical:date-time-locally<= effective-start given-clock-time) + (ical:time<= (encode-time effective-start) given-abs-time)))) + + (when observance-might-apply + ;; Initialize our return values on the first iteration + ;; where an observance potentially applies: + (unless nearest-onset + (setq nearest-onset effective-start + nearest-observance obs) + (when (and update given-clock-time) + (setq updated + (icr:tz--get-updated-in given-clock-time + effective-start obs)))) + + ;; We first check whether any RDATEs in the observance are + ;; the relevant onset: + (let ((rdates + (mapcar #'ical:ast-node-value + (apply #'append + (mapcar #'ical:ast-node-value rdate-nodes))))) + (dolist (rd rdates) + (let* ((effective-rd + ;; N.B.: we don't have to worry about rd being + ;; an ical:period or ical:date here because in + ;; time zone observances, RDATE values are + ;; *only* allowed to be local date-times; see + ;; https://www.rfc-editor.org/rfc/rfc5545#section-3.6.5 + ;; and `ical:rrule-validator' + (ical:date-time-variant rd :zone offset-from + :dst (not is-daylight))) + (onset-applies + (if given-clock-time + (ical:date-time-locally<= effective-rd + given-clock-time) + (ical:time<= (encode-time effective-rd) + given-abs-time)))) + + (when (and onset-applies nearest-onset + (ical:date-time< nearest-onset effective-rd)) + (setq nearest-onset effective-rd + nearest-observance obs) + + (when (and update given-clock-time) + (setq updated + (icr:tz--get-updated-in given-clock-time + effective-rd obs))))))) + + ;; If the observance has a recurrence value, it's the + ;; relevant observance if it: + ;; (1) has a recurrence which starts before dt + ;; (2) that recurrence is the nearest in the zone + ;; which starts before dt + ;; Note that we intentionally do *not* pass `vtimezone' + ;; through here to find-interval, recurrences-in-interval, + ;; etc. so as not to cause infinite recursion. Instead we + ;; directly pass `offset-from' (the offset from UTC at the + ;; start of each observance onset), which + ;; `icr:tz-set-zone' knows to handle specially without + ;; calling this function. + (when recur-value + (let* ((target (or given-clock-time + (decode-time given-abs-time offset-from))) + (int (icr:find-interval + target effective-start recur-value offset-from)) + (int-recs (icr:recurrences-in-interval + int obs offset-from)) + ;; The closest observance onset before `dt' might + ;; actually be in the previous interval, e.g. + ;; if `dt' is in January after an annual change to + ;; Standard Time in November. So check that as well. + (prev-int (icr:previous-interval int recur-value + effective-start + offset-from)) + (prev-recs (when prev-int + (icr:recurrences-in-interval + prev-int obs offset-from))) + (recs (append prev-recs int-recs)) + (keep-recs<=given + (if given-clock-time + (lambda (rec) + (ical:date-time-locally<= rec given-clock-time)) + (lambda (rec) + (ical:time<= (encode-time rec) given-abs-time)))) + (srecs (sort (seq-filter ; (1) + keep-recs<=given + recs) + :lessp #'ical:date-time< + :in-place t :reverse t)) + (latest-rec (car srecs))) + + (when (and latest-rec + (ical:date-time< nearest-onset latest-rec)) ; (2) + (setf (decoded-time-dst latest-rec) + ;; if obs is a DAYLIGHT observance, latest-rec + ;; represents the last moment of standard time, and + ;; vice versa + (not is-daylight)) + (setq nearest-onset latest-rec + nearest-observance obs) + (when (and update given-clock-time) + (setq updated + (icr:tz--get-updated-in given-clock-time + latest-rec obs)))))))))) + + ;; We've now found the nearest observance, if there was one. + ;; Update `dt' as a side effect if requested. This saves + ;; repeating a lot of the above in a separate function. + (when (and update given-clock-time nearest-observance updated) + ;; signal an error when `dt' does not exist if requested, so the + ;; nonexistence can be handled further up the stack: + (when (and (eq :error nonexisting) + (not (ical:date-time-locally-simultaneous-p dt updated))) + (signal 'ical:tz-nonexistent-time + (list + :message + (format "%d-%02d-%02d %02d:%02d:%02d does not exist in %s" + (decoded-time-year dt) + (decoded-time-month dt) + (decoded-time-day dt) + (decoded-time-hour dt) + (decoded-time-minute dt) + (decoded-time-second dt) + (or + (ical:with-property-of nearest-observance + 'ical:tzname nil value) + "time zone observance")) + :date-time dt + :observance nearest-observance))) + ;; otherwise we copy `updated' over to `dt', which resets the + ;; clock time in `dt' if it did not exist: + (setf (decoded-time-zone dt) (decoded-time-zone updated)) + (setf (decoded-time-dst dt) (decoded-time-dst updated)) + (setf (decoded-time-second dt) (decoded-time-second updated)) + (setf (decoded-time-minute dt) (decoded-time-minute updated)) + (setf (decoded-time-hour dt) (decoded-time-hour updated)) + (setf (decoded-time-day dt) (decoded-time-day updated)) + (setf (decoded-time-month dt) (decoded-time-month updated)) + (setf (decoded-time-year dt) (decoded-time-year updated)) + (setf (decoded-time-weekday dt) + (calendar-day-of-week (ical:date-time-to-date updated)))) + + ;; Return the observance and onset if found, nil if not: + (when nearest-observance + (list nearest-observance nearest-onset))))) + +(defun icr:tz-offset-in (observance) + "Return the offset (in seconds) from UTC in effect during OBSERVANCE. + +OBSERVANCE should be an `icalendar-standard' or `icalendar-daylight' +subcomponent of a particular `icalendar-vtimezone'. The returned value +is the value of its `icalendar-tzoffsetto' property." + (ical:with-property-of observance 'ical:tzoffsetto nil value)) + +(defun icr:tz-decode-time (ts vtimezone) + "Decode Lisp timestamp TS with the appropriate offset in VTIMEZONE. + +VTIMEZONE should be an `icalendar-vtimezone' component node. The correct +observance for TS will be looked up in VTIMEZONE, TS will be decoded +with the UTC offset of that observance, and its dst slot will be set +based on whether the observance is an `icalendar-standard' or +`icalendar-daylight' component. If VTIMEZONE does not have an +observance that applies to TS, it is decoded into UTC time. + +VTIMEZONE may also be an `icalendar-utc-offset'. In this case TS is +decoded directly into this UTC offset, and its dst slot is set to -1." + (let* ((observance (when (ical:vtimezone-component-p vtimezone) + (car (icr:tz-observance-on ts vtimezone)))) + (offset (cond (observance (icr:tz-offset-in observance)) + ((cl-typep vtimezone 'ical:utc-offset) + vtimezone) + (t 0)))) + + (ical:date-time-variant ; ensures weekday gets set, too + (decode-time ts offset) + :zone offset + :dst (if observance (ical:daylight-component-p observance) + -1)))) + +(defun icr:tz-set-zone (dt vtimezone &optional nonexisting) + "Set the time zone offset and dst flag in DT based on VTIMEZONE. + +DT should be an `icalendar-date-time' and VTIMEZONE should be an +`icalendar-vtimezone'. VTIMEZONE can also be an `icalendar-utc-offset', +in which case this value is directly set in DT's zone field (without +changing its dst flag). The updated DT is returned. + +This function generally sets only the zone and dst slots of DT, without +changing the other slots; its main purpose is to adjust date-times +generated from other date-times during recurrence rule calculations, +where a different time zone observance may be in effect in the original +date-time. It cannot be used to re-decode a fixed point in time into a +different time zone; for that, see `icalendar-recur-tz-decode-time'. + +If given, NONEXISTING is a keyword that specifies what to do if DT +represents a clock time that does not exist according to the relevant +observance in VTIMEZONE. The value :error means to signal an +\\='icalendar-tz-nonexistent-time error, and nil means to reset the +clock time in DT to an existing one; see +`icalendar-recur-tz-observance-on'." + (if (cl-typep vtimezone 'ical:utc-offset) + ;; This is where the recurrence rule/time zone mutual dependence + ;; bottoms out; don't remove this conditional! + (setf (decoded-time-zone dt) vtimezone) + + ;; Otherwise, if there's already zone information in dt, trust it + ;; without looking up the observance. This is partly a performance + ;; optimization (because the lookup is expensive) and partly about + ;; avoiding problems: looking up the observance uses the clock time + ;; in dt without considering the zone information, and doing this + ;; when dt has already been adjusted to contain valid zone + ;; information can invalidate that information. + ;; + ;; It's reliable to skip the lookup when dt already contains zone + ;; information only because `icalendar-make-date-time', + ;; `icalendar-date/time-add', and in particular + ;; `icalendar-date-time-variant' are careful to remove the UTC + ;; offset and DST information in the date-times they construct, + ;; unless provided with enough information to fill those slots. + (unless (and (cl-typep dt 'ical:date-time) + (decoded-time-zone dt) + (booleanp (decoded-time-dst dt))) + ;; This updates the relevant slots in dt as a side effect: + ;; TODO: if no observance is found, is it ever sensible to signal an error, + ;; instead of just leaving the zone slot unset? + (icr:tz-observance-on dt vtimezone t nonexisting))) + dt) + +(defun icr:tz-set-zones-in (vtimezones node) + "Recursively set time zone offset and dst flags in times in NODE. + +VTIMEZONES should be a list of the `icalendar-vtimezone' components in +the calendar containing NODE. NODE can be any iCalendar syntax node. If +NODE is a property node with an `icalendar-tzidparam' parameter and an +`icalendar-date-time' or `icalendar-period' value, the appropriate time +zone observance for its value is looked up in VTIMEZONES, and used to +set the zone and dst slots in its value. Otherwise, the function is +called recursively on NODE's children." + (cond + ((ical:property-node-p node) + (ical:with-property node + ((ical:tzidparam :value tzid)) + (when (and tzid (eq value-type 'ical:date-time)) + (let* ((tz (icr:tz-for tzid vtimezones)) + updated) + (cond ((eq value-type 'ical:date-time) + (setq updated (icr:tz-set-zone value tz))) + ((eq value-type 'ical:period) + (setq updated + (ical:make-period + (icr:tz-set-zone (ical:period-start value) tz) + :end + (if (ical:period--defined-end value) + (icr:tz-set-zone (ical:period--defined-end value) tz) + (ical:period-end value tz)) + :duration (ical:period-dur-value value))))) + (ical:ast-node-set-value value-node updated))))) + ((ical:component-node-p node) ; includes VCALENDAR nodes + (mapc (apply-partially #'icr:tz-set-zones-in vtimezones) + (ical:ast-node-children node))) + (t nil))) + +(defun icr:tzname-on (dt vtimezone) + "Return the name of the time zone observance in effect on DT in VTIMEZONE. + +DT should be an `icalendar-date' or `icalendar-date-time'. VTIMEZONE +should be the `icalendar-vtimezone' component in which to interpret DT. + +The observance in effect on DT within VTIMEZONE is computed. The +returned value is the value of the `icalendar-tzname' property of this +observance." + (when-let* ((obs/onset (icr:tz-observance-on dt vtimezone)) + (observance (car obs/onset))) + (ical:with-property-of observance 'ical:tzname))) + + + +(provide 'icalendar-recur) + +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-") ("icr:" . "icalendar-recur-")) +;; End: +;;; icalendar-recur.el ends here diff --git a/lisp/calendar/icalendar-utils.el b/lisp/calendar/icalendar-utils.el new file mode 100644 index 00000000000..f3fd1e73de4 --- /dev/null +++ b/lisp/calendar/icalendar-utils.el @@ -0,0 +1,749 @@ +;;; icalendar-utils.el --- iCalendar utility functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Richard Lawrence + +;; Author: Richard Lawrence +;; Created: January 2025 +;; Keywords: calendar + +;; This file is part of GNU Emacs. + +;; This file is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This file contains a variety of utility functions to work with +;; iCalendar data which are used throughout the rest of the iCalendar +;; library. Most of the functions here deal with calendar and clock +;; arithmetic, and help smooth over the type distinction between plain +;; dates and date-times. + +;;; Code: +(require 'cl-lib) +(require 'calendar) +(eval-when-compile (require 'icalendar-macs)) +(require 'icalendar-parser) + +;; Accessors for commonly used properties + +(defun ical:component-dtstart (component) + "Return the value of the `icalendar-dtstart' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:dtstart nil value)) + +(defun ical:component-dtend (component) + "Return the value of the `icalendar-dtend' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:dtend nil value)) + +(defun ical:component-rdate (component) + "Return the value of the `icalendar-rdate' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:rdate nil value)) + +(defun ical:component-summary (component) + "Return the value of the `icalendar-summary' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:summary nil value)) + +(defun ical:component-description (component) + "Return the value of the `icalendar-description' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:description nil value)) + +(defun ical:component-tzname (component) + "Return the value of the `icalendar-tzname' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:tzname nil value)) + +(defun ical:component-uid (component) + "Return the value of the `icalendar-uid' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:uid nil value)) + +(defun ical:component-url (component) + "Return the value of the `icalendar-url' property of COMPONENT. +COMPONENT can be any component node." + (ical:with-property-of component 'ical:url nil value)) + +(defun ical:property-tzid (property) + "Return the value of the `icalendar-tzid' parameter of PROPERTY." + (ical:with-param-of property 'ical:tzidparam nil value)) + +;; String manipulation + +(defun ical:strip-mailto (s) + "Remove \"mailto:\" case-insensitively from the start of S." + (let ((case-fold-search t)) + (replace-regexp-in-string "^mailto:" "" s))) + + +;; Date/time + +;; N.B. Notation: "date/time" is used in function names when a function +;; can accept either `icalendar-date' or `icalendar-date-time' values; +;; in contrast, "date-time" means it accepts *only* +;; `icalendar-date-time' values, not plain dates. +;; TODO: turn all the 'date/time' functions into methods dispatched by +;; type? + +(defun ical:date-time-to-date (dt) + "Convert an `icalendar-date-time' value DT to an `icalendar-date'." + (list (decoded-time-month dt) + (decoded-time-day dt) + (decoded-time-year dt))) + +(cl-defun ical:date-to-date-time (dt &key (hour 0) (minute 0) (second 0) (tz nil)) + "Convert an `icalendar-date' value DT to an `icalendar-date-time'. + +The following keyword arguments are accepted: + :hour, :minute, :second - integers representing a local clock time on date DT + :tz - an `icalendar-vtimezone' in which to interpret this clock time + +If these arguments are all unspecified, the hour, minute, and second +slots of the returned date-time will be zero, and it will contain no +time zone information. See `icalendar-make-date-time' for more on these +arguments." + (ical:make-date-time + :year (calendar-extract-year dt) + :month (calendar-extract-month dt) + :day (calendar-extract-day dt) + :hour hour + :minute minute + :second second + :tz tz)) + +(defun ical:date/time-to-date (dt) + "Extract a Gregorian date from DT. +An `icalendar-date' value is returned unchanged. +An `icalendar-date-time' value is converted to an `icalendar-date'." + (if (cl-typep dt 'ical:date) + dt + (ical:date-time-to-date dt))) + +;; Type-aware accessors for date/time slots that work for both ical:date +;; and ical:date-time: +;; NOTE: cl-typecase ONLY works here if dt is valid according to +;; `ical:-decoded-date-time-p'! May need to adjust this if it's +;; necessary to work with incomplete decoded-times +(defun ical:date/time-year (dt) + "Return DT's year slot. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (cl-typecase dt + (ical:date (calendar-extract-year dt)) + (ical:date-time (decoded-time-year dt)))) + +(defun ical:date/time-month (dt) + "Return DT's month slot. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (cl-typecase dt + (ical:date (calendar-extract-month dt)) + (ical:date-time (decoded-time-month dt)))) + +(defun ical:date/time-monthday (dt) + "Return DT's day of the month slot. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (cl-typecase dt + (ical:date (calendar-extract-day dt)) + (ical:date-time (decoded-time-day dt)))) + +(defun ical:date/time-weekno (dt &optional weekstart) + "Return DT's ISO week number. +DT may be either an `icalendar-date' or an `icalendar-date-time'. +WEEKSTART defaults to 1; it represents the day which starts the week, +and should be an integer between 0 (= Sunday) and 6 (= Saturday)." + ;; TODO: Add support for weekstart. + ;; calendar-iso-from-absolute doesn't support this yet. + (when (and weekstart (not (= weekstart 1))) + (error "Support for WEEKSTART other than 1 (=Monday) not implemented yet")) + (let* ((gdate (ical:date/time-to-date dt)) + (isodate (calendar-iso-from-absolute + (calendar-absolute-from-gregorian gdate))) + (weekno (car isodate))) + weekno)) + +(defun ical:date/time-weekday (dt) + "Return DT's day of the week. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (cl-typecase dt + (ical:date (calendar-day-of-week dt)) + (ical:date-time + (or (decoded-time-weekday dt) + ;; compensate for possibly-nil weekday slot if the date-time + ;; has been constructed by `make-decoded-time'; cf. comment + ;; in `icalendar--decoded-date-time-p': + (calendar-day-of-week (ical:date-time-to-date dt)))))) + +(defun ical:date/time-hour (dt) + "Return DT's hour slot, or nil. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (when (cl-typep dt 'ical:date-time) + (decoded-time-hour dt))) + +(defun ical:date/time-minute (dt) + "Return DT's minute slot, or nil. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (when (cl-typep dt 'ical:date-time) + (decoded-time-minute dt))) + +(defun ical:date/time-second (dt) + "Return DT's second slot, or nil. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (when (cl-typep dt 'ical:date-time) + (decoded-time-second dt))) + +(defun ical:date/time-zone (dt) + "Return DT's time zone slot, or nil. +DT may be either an `icalendar-date' or an `icalendar-date-time'." + (when (cl-typep dt 'ical:date-time) + (decoded-time-zone dt))) + +;;; Date/time comparisons and arithmetic: +(defun ical:date< (dt1 dt2) + "Return non-nil if date DT1 is strictly earlier than date DT2. +DT1 and DT2 must both be `icalendar-date' values of the form (MONTH DAY YEAR)." + (< (calendar-absolute-from-gregorian dt1) + (calendar-absolute-from-gregorian dt2))) + +(defun ical:date<= (dt1 dt2) + "Return non-nil if date DT1 is earlier than or the same date as DT2. +DT1 and DT2 must both be `icalendar-date' values of the form (MONTH DAY YEAR)." + (or (calendar-date-equal dt1 dt2) (ical:date< dt1 dt2))) + +(defun ical:date-time-locally-earlier (dt1 dt2 &optional or-equal) + "Return non-nil if date-time DT1 is locally earlier than DT2. + +Unlike `icalendar-date-time<', this function assumes both times are +local to some time zone and does not consider their zone information. + +If OR-EQUAL is non-nil, this function acts like `<=' rather than `<': +it will return non-nil if DT1 and DT2 are locally the same time." + (let ((year1 (decoded-time-year dt1)) + (year2 (decoded-time-year dt2)) + (month1 (decoded-time-month dt1)) + (month2 (decoded-time-month dt2)) + (day1 (decoded-time-day dt1)) + (day2 (decoded-time-day dt2)) + (hour1 (decoded-time-hour dt1)) + (hour2 (decoded-time-hour dt2)) + (minute1 (decoded-time-minute dt1)) + (minute2 (decoded-time-minute dt2)) + (second1 (decoded-time-second dt1)) + (second2 (decoded-time-second dt2))) + (or (< year1 year2) + (and (= year1 year2) + (or (< month1 month2) + (and (= month1 month2) + (or (< day1 day2) + (and (= day1 day2) + (or (< hour1 hour2) + (and (= hour1 hour2) + (or (< minute1 minute2) + (and (= minute1 minute2) + (if or-equal + (<= second1 second2) + (< second1 second2)))))))))))))) + +(defun ical:date-time-locally< (dt1 dt2) + "Return non-nil if date-time DT1 is locally strictly earlier than DT2. + +Unlike `icalendar-date-time<', this function assumes both times are +local to some time zone and does not consider their zone information." + (ical:date-time-locally-earlier dt1 dt2 nil)) + +(defun ical:date-time-locally<= (dt1 dt2) + "Return non-nil if date-time DT1 is locally earlier than, or equal to, DT2. + +Unlike `icalendar-date-time<=', this function assumes both times are +local to some time zone and does not consider their zone information." + (ical:date-time-locally-earlier dt1 dt2 t)) + +(defun ical:date-time< (dt1 dt2) + "Return non-nil if date-time DT1 is strictly earlier than DT2. + +DT1 and DT2 must both be decoded times, and either both or neither +should have time zone information. + +If one has a time zone offset and the other does not, the offset +returned from `current-time-zone' is used as the missing offset; if +`current-time-zone' cannot provide this information, an error is +signaled." + (let ((zone1 (decoded-time-zone dt1)) + (zone2 (decoded-time-zone dt2))) + (cond ((and (integerp zone1) (integerp zone2)) + (time-less-p (encode-time dt1) (encode-time dt2))) + ((and (null zone1) (null zone2)) + (ical:date-time-locally< dt1 dt2)) + (t + ;; Cf. RFC5545 Sec. 3.3.5: + ;; "The recipient of an iCalendar object with a property value + ;; consisting of a local time, without any relative time zone + ;; information, SHOULD interpret the value as being fixed to whatever + ;; time zone the "ATTENDEE" is in at any given moment. This means + ;; that two "Attendees", in different time zones, receiving the same + ;; event definition as a floating time, may be participating in the + ;; event at different actual times. Floating time SHOULD only be + ;; used where that is the reasonable behavior." + ;; I'm interpreting this to mean that if we get here, where + ;; one date-time has zone information and the other doesn't, + ;; we should use the offset from (current-time-zone). + (let* ((user-tz (current-time-zone)) + (user-offset (car user-tz)) + (dt1z (ical:date-time-variant dt1 :zone (or zone1 user-offset))) + (dt2z (ical:date-time-variant dt2 :zone (or zone2 user-offset)))) + (if user-offset + (time-less-p (encode-time dt1z) (encode-time dt2z)) + (error "Too little zone information for comparison: %s %s" + dt1 dt2))))))) + +;; Two different notions of equality are relevant to decoded times: +;; strict equality (`icalendar-date-time=') of all slots, or +;; simultaneity (`icalendar-date-time-simultaneous-p'). +;; Most tests probably want the strict notion, because it distinguishes +;; between simultaneous events decoded into different time zones, +;; whereas most user-facing functions (e.g. sorting events by date and time) +;; probably want simultaneity. +(defun ical:date-time= (dt1 dt2) + "Return non-nil if DT1 and DT2 are decoded-times with identical slot values. + +Note that this function returns nil if DT1 and DT2 represent times in +different time zones, even if they are simultaneous. For the latter, see +`icalendar-date-time-simultaneous-p'." + (equal dt1 dt2)) + +(defun ical:date-time-locally-simultaneous-p (dt1 dt2) + "Return non-nil if DT1 and DT2 are locally simultaneous date-times. +Note that this function ignores zone information in dt1 and dt2. It +returns non-nil if DT1 and DT2 represent the same clock time in +different time zones, even if they encode to different absolute times." + (and (eq (decoded-time-year dt1) (decoded-time-year dt2)) + (eq (decoded-time-month dt1) (decoded-time-month dt2)) + (eq (decoded-time-day dt1) (decoded-time-day dt2)) + (eq (decoded-time-hour dt1) (decoded-time-hour dt2)) + (eq (decoded-time-minute dt1) (decoded-time-minute dt2)) + (eq (decoded-time-second dt1) (decoded-time-second dt2)))) + +(defun ical:date-time-simultaneous-p (dt1 dt2) + "Return non-nil if DT1 and DT2 are simultaneous date-times. + +This function returns non-nil if DT1 and DT2 encode to the same Lisp +timestamp. Thus they can count as simultaneous even if they represent +times in different timezones. If both date-times lack an offset from +UTC, they are treated as simultaneous if they encode to the same +timestamp in UTC. + +If only one date-time has an offset, they are treated as +non-simultaneous if they represent different clock times according to +`icalendar-date-time-locally-simultaneous-p'. Otherwise an error is +signaled." + (let ((zone1 (decoded-time-zone dt1)) + (zone2 (decoded-time-zone dt2))) + (cond ((and (integerp zone1) (integerp zone2)) + (time-equal-p (encode-time dt1) (encode-time dt2))) + ((and (null zone1) (null zone2)) + (time-equal-p (encode-time (ical:date-time-variant dt1 :zone 0)) + (encode-time (ical:date-time-variant dt2 :zone 0)))) + (t + ;; Best effort: + ;; TODO: I'm not convinced this is the right thing to do yet. + ;; Might want to be stricter here and fix the problem of comparing + ;; times with and without zone information elsewhere. + (if (ical:date-time-locally-simultaneous-p dt1 dt2) + (error "Missing zone information: %s %s" dt1 dt2) + nil))))) + +(defun ical:date-time<= (dt1 dt2) + "Return non-nil if DT1 is earlier than, or simultaneous with, DT2. +DT1 and DT2 must both be decoded times, and either both or neither must have +time zone information." + (or (ical:date-time< dt1 dt2) + (ical:date-time-simultaneous-p dt1 dt2))) + +(defun ical:date/time< (dt1 dt2) + "Return non-nil if DT1 is strictly earlier than DT2. +DT1 and DT2 must be either `icalendar-date' or `icalendar-date-time' +values. If they are not of the same type, only the date in the +`icalendar-date-time' value will be considered." + (cl-typecase dt1 + (ical:date + (if (cl-typep dt2 'ical:date) + (ical:date< dt1 dt2) + (ical:date< dt1 (ical:date-time-to-date dt2)))) + + (ical:date-time + (if (cl-typep dt2 'ical:date-time) + (ical:date-time< dt1 dt2) + (ical:date< (ical:date-time-to-date dt1) dt2))))) + +(defun ical:date/time<= (dt1 dt2) + "Return non-nil if DT1 is earlier than or simultaneous to DT2. +DT1 and DT2 must be either `icalendar-date' or `icalendar-date-time' +values. If they are not of the same type, only the date in the +`icalendar-date-time' value will be considered." + (cl-typecase dt1 + (ical:date + (if (cl-typep dt2 'ical:date) + (ical:date<= dt1 dt2) + (ical:date<= dt1 (ical:date-time-to-date dt2)))) + + (ical:date-time + (if (cl-typep dt2 'ical:date-time) + (ical:date-time<= dt1 dt2) + (ical:date<= (ical:date-time-to-date dt1) dt2))))) + +(defun ical:date/time-min (&rest dts) + "Return the earliest date or date-time among DTS. + +The DTS may be any `icalendar-date' or `icalendar-date-time' values, and +will be ordered by `icalendar-date/time<='." + (car (sort dts :lessp #'ical:date/time<=))) + +(defun ical:date/time-max (&rest dts) + "Return the latest date or date-time among DTS. + +The DTS may be any `icalendar-date' or `icalendar-date-time' values, and +will be ordered by `icalendar-date/time<='." + (car (sort dts :reverse t :lessp #'ical:date/time<=))) + +(defun ical:date-add (date unit n) + "Add N UNITs to DATE. + +UNIT should be `:year', `:month', `:week', or `:day'; time units will be +ignored. N may be a positive or negative integer." + (if (memq unit '(:hour :minute :second)) + date + (let* ((dt (ical:make-date-time :year (calendar-extract-year date) + :month (calendar-extract-month date) + :day (calendar-extract-day date))) + (delta (if (eq unit :week) + (make-decoded-time :day (* 7 n)) + (make-decoded-time unit n))) + (new-dt (decoded-time-add dt delta))) + (ical:date-time-to-date new-dt)))) + +(declare-function icalendar-recur-tz-decode-time "icalendar-recur") + +(defun ical:date-time-add (dt delta &optional vtimezone) + "Like `decoded-time-add', but also updates weekday and time zone slots. + +DT and DELTA should be `icalendar-date-time' values (decoded times), as +in `decoded-time-add'. VTIMEZONE, if given, should be an +`icalendar-vtimezone'. The resulting date-time will be given the offset +determined by VTIMEZONE at the local time determined by adding DELTA to +DT. + +This function assumes that time units in DELTA larger than an hour +should not affect the local clock time in the result, even when crossing +an observance boundary in VTIMEZONE. This means that e.g. if DT is at +9AM daylight savings time on the day before the transition to standard +time, then the result of adding a DELTA of two days will be at 9AM +standard time, even though this is not exactly 48 hours later. Adding a +DELTA of 48 hours, on the other hand, will result in a time exactly 48 +hours later, but at a different local time." + (require 'icalendar-recur) ; for icr:tz-decode-time; avoids circular requires + (if (not vtimezone) + ;; the simple case: we have no time zone info, so just use + ;; `decoded-time-add': + (let ((sum (decoded-time-add dt delta))) + (ical:date-time-variant sum)) + ;; `decoded-time-add' does not take time zone shifts into account, + ;; so we need to do the adjustment ourselves. We first add the units + ;; larger than an hour using `decoded-time-add', holding the clock + ;; time fixed, as described in the docstring. Then we add the time + ;; units as a fixed number of seconds and re-decode the resulting + ;; absolute time into the time zone. + (let* ((cal-delta (make-decoded-time :year (or (decoded-time-year delta) 0) + :month (or (decoded-time-month delta) 0) + :day (or (decoded-time-day delta) 0))) + (cal-sum (decoded-time-add dt cal-delta)) + (dt-w/zone (ical:date-time-variant cal-sum + :tz vtimezone)) + (secs-delta (+ (or (decoded-time-second delta) 0) + (* 60 (or (decoded-time-minute delta) 0)) + (* 60 60 (or (decoded-time-hour delta) 0)))) + (sum-ts (time-add (encode-time dt-w/zone) secs-delta))) + (icalendar-recur-tz-decode-time sum-ts vtimezone)))) + +;; TODO: rework so that it's possible to add dur-values to plain dates. +;; Perhaps rename this to "date/time-inc" or so, or use kwargs to allow +;; multiple units, or... +(defun ical:date/time-add (dt unit n &optional vtimezone) + "Add N UNITs to DT. + +DT should be an `icalendar-date' or `icalendar-date-time'. UNIT should +be `:year', `:month', `:week', `:day', `:hour', `:minute', or `:second'; +time units will be ignored if DT is an `icalendar-date'. N may be a +positive or negative integer." + (cl-typecase dt + (ical:date-time + (let ((delta (if (eq unit :week) (make-decoded-time :day (* 7 n)) + (make-decoded-time unit n)))) + (ical:date-time-add dt delta vtimezone))) + (ical:date (ical:date-add dt unit n)))) + +(defun ical:date/time-add-duration (start duration &optional vtimezone) + "Return the end date(-time) which is a length of DURATION after START. + +START should be an `icalendar-date' or `icalendar-date-time'; the +returned value will be of the same type as START. DURATION should be an +`icalendar-dur-value'. VTIMEZONE, if specified, should be the +`icalendar-vtimezone' representing the time zone of START." + (if (integerp duration) + ;; number of weeks: + (setq duration (make-decoded-time :day (* 7 duration)))) + (cl-typecase start + (ical:date + (ical:date-time-to-date + (ical:date-time-add (ical:date-to-date-time start) duration))) + (ical:date-time + (ical:date-time-add start duration vtimezone)))) + +(defun ical:duration-between (start end) + "Return the duration between START and END. + +START should be an `icalendar-date' or `icalendar-date-time'; END must +be of the same type as START. The returned value is an +`icalendar-dur-value', i.e., a time delta in the sense of +`decoded-time-add'." + (cl-typecase start + (ical:date + (make-decoded-time :day (- (calendar-absolute-from-gregorian end) + (calendar-absolute-from-gregorian start)))) + (ical:date-time + (let* ((start-abs (time-convert (encode-time start) 'integer)) + (end-abs (time-convert (encode-time end) 'integer)) + (dur-secs (- end-abs start-abs)) + (days (/ dur-secs (* 60 60 24))) + (dur-nodays (mod dur-secs (* 60 60 24))) + (hours (/ dur-nodays (* 60 60))) + (dur-nohours (mod dur-nodays (* 60 60))) + (minutes (/ dur-nohours 60)) + (seconds (mod dur-nohours 60))) + (make-decoded-time :day days + :hour hours :minute minutes :second seconds))))) + +(defun ical:date/time-to-local (dt) + "Reinterpret DT in Emacs local time if necessary. +If DT is an `icalendar-date-time', encode and re-decode it into Emacs +local time. If DT is an `icalendar-date', return it unchanged." + (cl-typecase dt + (ical:date dt) + (ical:date-time + (ical:date-time-variant ; ensure weekday is present too + (decode-time (encode-time dt)))))) + +(declare-function icalendar-recur-subintervals-to-dates "icalendar-recur") + +(defun ical:dates-until (start end &optional locally) + "Return a list of `icalendar-date' values between START and END. + +START and END may be either `icalendar-date' or `icalendar-date-time' +values. START is an inclusive lower bound, and END is an exclusive +upper bound. (Note, however, that if END is a date-time and its time is +after midnight, then its date will be included in the returned list.) + +If LOCALLY is non-nil and START and END are date-times, these will be +interpreted into Emacs local time, so that the dates returned are valid +for the local time zone." + (require 'icalendar-recur) + (when locally + (when (cl-typep start 'ical:date-time) + (setq start (ical:date/time-to-local start))) + (when (cl-typep end 'ical:date-time) + (setq end (ical:date/time-to-local end)))) + (cl-typecase start + (ical:date + (cl-typecase end + (ical:date + (icalendar-recur-subintervals-to-dates + (list (list (ical:date-to-date-time start) + (ical:date-to-date-time end))))) + (ical:date-time + (icalendar-recur-subintervals-to-dates + (list (list (ical:date-to-date-time start) end)))))) + (ical:date-time + (cl-typecase end + (ical:date + (icalendar-recur-subintervals-to-dates + (list (list start (ical:date-to-date-time end))))) + (ical:date-time + (icalendar-recur-subintervals-to-dates (list (list start end)))))))) + + +(cl-defun ical:make-date-time (&key second minute hour day month year + (dst -1 given-dst) zone tz) + "Make an `icalendar-date-time' from the given keyword arguments. + +This function is like `make-decoded-time', except that it automatically +sets the weekday slot set based on the date arguments, and it accepts an +additional keyword argument: `:tz'. If provided, its value should be an +`icalendar-vtimezone', and the `:zone' and `:dst' arguments should not +be provided. In this case, the zone and dst slots in the returned +date-time will be adjusted to the correct values in the given time zone +for the local time represented by the remaining arguments." + (when (and tz (or zone given-dst)) + (error "Possibly conflicting time zone data in args")) + (apply #'ical:date-time-variant (make-decoded-time) + `(:second ,second :minute ,minute :hour ,hour + :day ,day :month ,month :year ,year + ;; Don't pass these keywords unless they were given explicitly. + ;; TODO: is there a cleaner way to write this? + ,@(when tz (list :tz tz)) + ,@(when given-dst (list :dst dst)) + ,@(when zone (list :zone zone))))) + +(declare-function icalendar-recur-tz-set-zone "icalendar-recur") + +(cl-defun ical:date-time-variant (dt &key second minute hour + day month year + (dst -1 given-dst) + (zone nil given-zone) + tz) + "Return a variant of DT with slots modified as in the given arguments. + +DT should be an `icalendar-date-time'; the keyword arguments have the +same meanings as in `make-decoded-time'. The returned variant will have +slot values as specified by the arguments or copied from DT, except that +the weekday slot will be updated if necessary, and the zone and dst +fields will not be set unless given explicitly (because varying the date +and clock time generally invalidates the time zone information in DT). + +One additional keyword argument is accepted: `:tz'. If provided, its +value should be an `icalendar-vtimezone', an `icalendar-utc-offset', or +the symbol \\='preserve. If it is a time zone component, the zone and +dst slots in the returned variant will be adjusted to the correct +values in the given time zone for the local time represented by the +variant. If it is a UTC offset, the variant's zone slot will contain +this value, but its dst slot will not be adjusted. If it is the symbol +\\='preserve, then both the zone and dst fields are copied from DT into +the variant." + (require 'icalendar-recur) ; for icr:tz-set-zone; avoids circular requires + (let ((variant + (make-decoded-time :second (or second (decoded-time-second dt)) + :minute (or minute (decoded-time-minute dt)) + :hour (or hour (decoded-time-hour dt)) + :day (or day (decoded-time-day dt)) + :month (or month (decoded-time-month dt)) + :year (or year (decoded-time-year dt)) + ;; For zone and dst slots, trust the value + ;; if explicitly specified or explicitly + ;; requested to preserve, but not otherwise + :dst (cond (given-dst dst) + ((eq 'preserve tz) (decoded-time-dst dt)) + (t -1)) + :zone (cond (given-zone zone) + ((eq 'preserve tz) (decoded-time-zone dt)) + (t nil))))) + ;; update weekday slot when possible, since it depends on the date + ;; slots, which might have changed. (It's not always possible, + ;; because pure time values are also represented as decoded-times, + ;; with empty date slots.) + (unless (or (null (decoded-time-year variant)) + (null (decoded-time-month variant)) + (null (decoded-time-day variant))) + (setf (decoded-time-weekday variant) + (calendar-day-of-week (ical:date-time-to-date variant)))) + ;; if given a time zone or UTC offset, update zone and dst slots, + ;; which also might have changed: + (when (and tz (not (eq 'preserve tz))) + (icalendar-recur-tz-set-zone variant tz)) + variant)) + +(defun ical:date/time-in-period-p (dt period &optional vtimezone) + "Return non-nil if DT occurs within PERIOD. + +DT can be an `icalendar-date' or `icalendar-date-time' value. PERIOD +should be an `icalendar-period' value. VTIMEZONE, if given, is passed +to `icalendar-period-end' to compute the end time of the period if it +was not specified explicitly." + (and (ical:date/time<= (ical:period-start period) dt) + (ical:date/time< dt (ical:period-end period vtimezone)))) + +;; TODO: surely this exists already? +(defun ical:time<= (a b) + "Compare two Lisp timestamps A and B: is A <= B?" + (or (time-equal-p a b) + (time-less-p a b))) + +(defun ical:number-of-weeks (year &optional weekstart) + "Return the number of weeks in (Gregorian) YEAR. + +RFC5545 defines week 1 as the first week to include at least four days +in the year. Weeks are assumed to start on Monday (= 1) unless WEEKSTART +is specified, in which case it should be an integer between 0 (= Sunday) +and 6 (= Saturday)." + ;; There are 53 weeks in a year if Jan 1 is the fourth day after + ;; WEEKSTART, e.g. if the week starts on Monday and Jan 1 is a + ;; Thursday, or in a leap year if Jan 1 is the third day after WEEKSTART + (let* ((jan1wd (calendar-day-of-week (list 1 1 year))) + (delta (mod (- jan1wd (or weekstart 1)) 7))) + (if (or (= 4 delta) + (and (= 3 delta) (calendar-leap-year-p year))) + 53 + 52))) + +(defun ical:start-of-weekno (weekno year &optional weekstart) + "Return the start of the WEEKNOth week in the (Gregorian) YEAR. + +RFC5545 defines week 1 as the first week to include at least four days +in the year. Weeks are assumed to start on Monday (= 1) unless WEEKSTART +is specified, in which case it should be an integer between 0 (= Sunday) +and 6 (= Saturday). The returned value is an `icalendar-date'. + +If WEEKNO is negative, it refers to the WEEKNOth week before the end of +the year: -1 is the last week of the year, -2 second to last, etc." + (calendar-gregorian-from-absolute + (+ + (* 7 (if (< 0 weekno) + (1- weekno) + (+ 1 weekno (ical:number-of-weeks year weekstart)))) + (calendar-dayname-on-or-before + (or weekstart 1) + ;; Three days after Jan 1. gives us the nearest occurrence; + ;; see `calendar-dayname-on-or-before' + (+ 3 (calendar-absolute-from-gregorian (list 1 1 year))))))) + +(defun ical:nth-weekday-in (n weekday year &optional month) + "Return the Nth WEEKDAY in YEAR or MONTH. + +If MONTH is specified, it refers to MONTH in YEAR, and N acts as an +index for WEEKDAYs within the month. Otherwise, N acts as an index for +WEEKDAYs within the entire YEAR. + +N should be an integer. If N<0, it counts from the end of the month or +year: if N=-1, it refers to the last WEEKDAY in the month or year, if +N=-2 the second to last, and so on." + (if month + (calendar-nth-named-day n weekday month year) + (let* ((jan1 (calendar-absolute-from-gregorian (list 1 1 year))) + (dec31 (calendar-absolute-from-gregorian (list 12 31 year)))) + ;; Adapted from `calendar-nth-named-absday'. + ;; TODO: we could generalize that function to make month an optional + ;; argument, but that would mean changing its interface. + (calendar-gregorian-from-absolute + (if (> n 0) + (+ (* 7 (1- n)) + (calendar-dayname-on-or-before + weekday + (+ 6 jan1))) + (+ (* 7 (1+ n)) + (calendar-dayname-on-or-before + weekday + dec31))))))) + +(provide 'icalendar-utils) +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; End: +;;; icalendar-utils.el ends here diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index b3334e483c1..3d8d31dffcb 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -26,6 +26,11 @@ ;;; Commentary: +;; Most of the code in this file is now obsolete and has been marked as such. +;; For the new implementation of diary import/export, see diary-icalendar.el. +;; Error handling code, global variables, and user options relevant for the +;; entire iCalendar library remain in this file. + ;; This package is documented in the Emacs Manual. ;; Please note: @@ -73,39 +78,11 @@ ;; 0.01: (2003-03-21) ;; - First published version. Trial version. Alpha version. -;; ====================================================================== -;; To Do: - -;; * Import from ical to diary: -;; + Need more properties for icalendar-import-format -;; (added all that Mozilla Calendar uses) -;; From iCal specifications (RFC2445: 4.8.1), icalendar.el lacks -;; ATTACH, CATEGORIES, COMMENT, GEO, PERCENT-COMPLETE (VTODO), -;; PRIORITY, RESOURCES) not considering date/time and time-zone -;; + check vcalendar version -;; + check (unknown) elements -;; + recurring events! -;; + works for european style calendars only! Does it? -;; + alarm -;; + exceptions in recurring events -;; + the parser is too soft -;; + error log is incomplete -;; + nice to have: #include "webcal://foo.com/some-calendar.ics" -;; + timezones probably still need some improvements. - -;; * Export from diary to ical -;; + diary-date, diary-float, and self-made sexp entries are not -;; understood - -;; * Other things -;; + clean up all those date/time parsing functions -;; + Handle todo items? -;; + Check iso 8601 for datetime and period -;; + Which chars to (un)escape? - - ;;; Code: +(eval-when-compile (require 'compile)) +(eval-when-compile (require 'cl-lib)) + ;; ====================================================================== ;; Customizables ;; ====================================================================== @@ -138,6 +115,12 @@ argument. It must return a string. See (function :tag "Function")) :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-summary "%s" "Format string defining how the summary element is formatted. @@ -146,6 +129,12 @@ by the summary." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-summary + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-description "\n Desc: %s" "Format string defining how the description element is formatted. @@ -154,6 +143,12 @@ replaced by the description." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-description + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-location "\n Location: %s" "Format string defining how the location element is formatted. @@ -162,6 +157,12 @@ by the location." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-location + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-organizer "\n Organizer: %s" "Format string defining how the organizer element is formatted. @@ -170,6 +171,12 @@ replaced by the organizer." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-organizer + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-url "\n URL: %s" "Format string defining how the URL element is formatted. @@ -178,6 +185,12 @@ the URL." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-url + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-uid "\n UID: %s" "Format string defining how the UID element is formatted. @@ -187,6 +200,12 @@ the UID." :version "24.3" :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-uid + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-status "\n Status: %s" "Format string defining how the status element is formatted. @@ -195,6 +214,12 @@ the status." :type 'string :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-status + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") + (defcustom icalendar-import-format-class "\n Class: %s" "Format string defining how the class element is formatted. @@ -203,68 +228,65 @@ the class." :type 'string :group 'icalendar) -(defcustom icalendar-recurring-start-year - 2005 - "Start year for recurring events. -Some calendar browsers only propagate recurring events for -several years beyond the start time. Set this string to a year -just before the start of your personal calendar." - :type 'integer - :group 'icalendar) +(make-obsolete-variable + 'icalendar-import-format-class + "please use `diary-icalendar-vevent-skeleton-command' for import +formatting instead." + "31.1") -(defcustom icalendar-export-hidden-diary-entries - t - "Determines whether hidden diary entries are exported. -If non-nil hidden diary entries (starting with `&') get exported, -if nil they are ignored." - :type 'boolean - :group 'icalendar) +(define-obsolete-variable-alias + 'icalendar-recurring-start-year + 'diary-icalendar-recurring-start-year + "31.1") + +(define-obsolete-variable-alias + 'icalendar-export-hidden-diary-entries + 'diary-icalendar-export-nonmarking-entries + "31.1") + +(defcustom ical:uid-format + "%h" + "Format string for unique ID (UID) values for iCalendar components. + +This string is used by `icalendar-make-uid' to generate UID values when +creating iCalendar components. -(defcustom icalendar-uid-format - "emacs%t%c" - "Format of unique ID code (UID) for each iCalendar object. The following specifiers are available: %c COUNTER, an integer value that is increased each time a uid is generated. This may be necessary for systems which do not provide time-resolution finer than a second. -%h HASH, a hash value of the diary entry, -%s DTSTART, the start date (excluding time) of the diary entry, +%h HASH, a hash value of the component's contents or system information, %t TIMESTAMP, a unique creation timestamp, -%u USERNAME, the variable `user-login-name'. +%u USERNAME, the value of `user-login-name'. +%s (obsolete, ignored) -For example, a value of \"%s_%h@mydomain.com\" will generate a -UID code for each entry composed of the time of the event, a hash -code for the event, and your personal domain name." +For example, a value of \"%h%t@mydomain.com\" will generate a UID code +for each entry composed of a hash of the event data, a creation +timestamp, and your personal domain name." :type 'string :group 'icalendar) -(defcustom icalendar-export-sexp-enumeration-days - 14 - "Number of days over which a sexp diary entry is enumerated. -In general sexp entries cannot be translated to icalendar format. -They are therefore enumerated, i.e. explicitly evaluated for a -certain number of days, and then exported. The enumeration starts -on the current day and continues for the number of days given here. - -See `icalendar-export-sexp-enumerate-all' for a list of sexp -entries which by default are NOT enumerated." - :version "25.1" - :type 'integer +(defcustom ical:vcalendar-prodid + (format "-//gnu.org//GNU Emacs %s//EN" emacs-version) + "The value of the `icalendar-prodid' property for VCALENDAR objects +produced by this Emacs." + :type 'string :group 'icalendar) -(defcustom icalendar-export-sexp-enumerate-all - nil - "Determines whether ALL sexp diary entries are enumerated. -If non-nil all sexp diary entries are enumerated for -`icalendar-export-sexp-enumeration-days' days instead of -translating into an icalendar equivalent. This affects the -following sexp diary entries: `diary-anniversary', -`diary-cyclic', `diary-date', `diary-float', `diary-block'. All -other sexp entries are enumerated in any case." - :version "25.1" - :type 'boolean - :group 'icalendar) +(defconst ical:vcalendar-version "2.0" + "The current version of the VCALENDAR object, used in the +`icalendar-version' property. \"2.0\" is the version corresponding to +RFC5545.") +(define-obsolete-variable-alias + 'icalendar-export-sexp-enumeration-days + 'diary-icalendar-export-sexp-enumeration-days + "31.1") + +(define-obsolete-variable-alias + 'icalendar-export-sexp-enumerate-all + 'diary-icalendar-export-sexp-enumerate-all + "31.1") (defcustom icalendar-export-alarms nil @@ -286,16 +308,38 @@ other sexp entries are enumerated in any case." (string :tag "Email")))))) :group 'icalendar) +(make-obsolete-variable + 'icalendar-export-alarms + "please use the new format in `diary-icalendar-export-alarms' instead." + "31.1") + +(defcustom icalendar-debug-level 1 + "Minimum severity for logging iCalendar error messages. +A value of 2 only logs errors. +A value of 1 also logs warnings. +A value of 0 also logs debugging information." + :type 'integer + :group 'icalendar) (defvar icalendar-debug nil "Enable icalendar debug messages.") +(make-obsolete-variable + 'icalendar-debug + 'icalendar-debug-level + "31.1") + ;; ====================================================================== ;; NO USER SERVICEABLE PARTS BELOW THIS LINE ;; ====================================================================== (defconst icalendar--weekday-array ["SU" "MO" "TU" "WE" "TH" "FR" "SA"]) +(make-obsolete-variable + 'icalendar--weekday-array + 'icalendar-weekday-numbers + "31.1") + ;; ====================================================================== ;; all the other libs we need ;; ====================================================================== @@ -307,8 +351,304 @@ other sexp entries are enumerated in any case." ;; ====================================================================== (defun icalendar--dmsg (&rest args) "Print message ARGS if `icalendar-debug' is non-nil." - (if icalendar-debug - (apply 'message args))) + (declare (obsolete icalendar-warn "31.1")) + (if (or icalendar-debug (= 0 icalendar-debug-level)) + (with-current-buffer (ical:error-buffer) + (goto-char (point-max)) + (insert (apply #'format-message args)) + (insert "\n")))) + +;; ====================================================================== +;; Error handling +;; ====================================================================== +(define-error 'ical:error "iCalendar error") + +(defconst ical:error-buffer-name "*icalendar-errors*" + "Name of buffer in which errors are listed when processing iCalendar data.") + +(defun ical:error-buffer () + "Return the iCalendar errors buffer, creating it if necessary. +The buffer name is based on `icalendar-error-buffer-name'." + (get-buffer-create ical:error-buffer-name)) + +(defvar ical:inhibit-error-erasure nil + "When non-nil, `icalendar-init-error-buffer' will not erase the errors +buffer.") + +(defun ical:init-error-buffer (&optional err-buffer) + "Prepare ERR-BUFFER for iCalendar errors. +ERR-BUFFER defaults to the buffer returned by `icalendar-error-buffer'. +Erases ERR-BUFFER and places it in `icalendar-errors-mode'." + (with-current-buffer (or err-buffer (ical:error-buffer)) + (unless ical:inhibit-error-erasure + (let ((inhibit-read-only t)) + (erase-buffer))) + (if (not (eq major-mode 'icalendar-errors-mode)) + (icalendar-errors-mode)))) + +(defun ical:errors-p (&optional err-buffer) + "Return non-nil if iCalendar errors have been reported in ERR-BUFFER. +ERR-BUFFER defaults to the buffer returned by `icalendar-error-buffer'." + (with-current-buffer (or err-buffer (ical:error-buffer)) + (not (= (point-min) (point-max))))) + +(defun ical:warn (msg &rest err-plist) + "Write a warning to the `icalendar-error-buffer' without signaling an error." + (plist-put err-plist :message msg) + (unless (plist-get err-plist :severity) + (plist-put err-plist :severity 1)) + (ical:handle-generic-error `(ical:warning . ,err-plist))) + +(defconst ical:error-regexp + (rx line-start + (zero-or-one + (group "(" + (or (group-n 3 "ERROR") (group-n 4 "WARNING") (group-n 5 "INFO")) + ")")) + (group-n 1 (zero-or-more (not ":"))) ":" + (zero-or-one (group-n 2 (one-or-more digit))) + ":") + "Regexp to match iCalendar errors. + +Group 1 contains the buffer name where the error originated. +Group 2 contains the buffer position. +Groups 3-5 match the severity: + 3 matches ERROR + 4 matches WARNING + 5 matches INFO") + +(cl-defun ical:format-error (&rest error-plist + &key (message "Unknown error") + severity + buffer + position + &allow-other-keys) + "Format iCalendar error data to a string. + +MESSAGE should be a string; it defaults to \"Unknown error\". +BUFFER should be a buffer; POSITION should be a position in BUFFER. +SEVERITY can be 0 for debug information, or 1 for a warning; otherwise +a genuine error is reported. + +The returned error message looks like + +(LEVEL)BUFFER:POSITION: MESSAGE +DEBUG-INFO... + +where LEVEL is derived from SEVERITY. DEBUG-INFO contains any additional +data in ERROR-PLIST, if `icalendar-debug-level' is +0. `icalendar-error-regexp' matches the fields in such messages." + (let ((name (copy-sequence (buffer-name buffer))) + (pos (if (integer-or-marker-p position) + (format "%d" position) + "")) + (level (cond ((eq severity 0) "INFO") + ((eq severity 1) "WARNING") + (t "ERROR"))) + (debug-info (if (not (= 0 icalendar-debug-level)) + "" + (mapconcat ;; (:key val...) => "Key: val\n..." + (lambda (val) + (if (keywordp val) + (capitalize (substring (symbol-name val) 1)) + (format ": %s\n" val))) + error-plist)))) + ;; Make sure buffer name doesn't take too much space: + (when (< 8 (length name)) + (put-text-property 9 (length name) 'display "..." name)) + (format "(%s)%s:%s: %s\n%s" level name pos message debug-info))) + +(defun ical:handle-generic-error (err-data &optional err-buffer) + "Log error data to ERR-BUFFER (default: the iCalendar error buffer). +ERR-DATA should be a list (ERROR-SYMBOL . SIGNAL-DATA) where +SIGNAL-DATA is a plist of error data." + (let* ((signal-data (cdr err-data)) + (err-plist (when (plistp signal-data) signal-data)) + (err-symbol (car err-data)) + (severity (or (plist-get err-plist :severity) 2)) + (buf (current-buffer))) + (when (<= ical:debug-level severity) + (with-current-buffer (or err-buffer (ical:error-buffer)) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (unless (bolp) (insert "\n")) + (insert (apply #'ical:format-error + (or err-plist + (list :buffer buf + :message + (format "Unhandled %s error: %s" + err-symbol signal-data)))))))))) + +(defmacro ical:condition-case (var bodyform &rest handlers) + "Like `condition-case', but with default handler for unhandled iCalendar errors. +If none of HANDLERS handles an error, it will be handled by +`icalendar-handle-generic-error'." + `(condition-case ,var + ,bodyform + ,@handlers + (ical:error (ical:handle-generic-error ,var)))) + +;;; Mode based on compilation-mode for navigating error buffer: +(defun ical:-buffer-from-error () + (when-let* ((name (match-string 1))) + (or (get-buffer name) + (find-buffer-visiting name)))) + +(defun ical:-filename-from-error () + (when-let* ((buf (ical:-buffer-from-error))) + (buffer-file-name buf))) + +(defun ical:-lineno-from-error () + (when-let* ((buf (ical:-buffer-from-error)) + (posstr (match-string 2)) + (pos (string-to-number posstr))) + (with-current-buffer buf + (line-number-at-pos pos)))) + +(defconst ical:error-regexp-alist + (list (list icalendar-error-regexp + #'ical:-filename-from-error + #'ical:-lineno-from-error + nil + nil + nil + '(2 compilation-line-face) + '(3 compilation-error-face) + '(4 compilation-warning-face) + '(5 compilation-info-face))) + "Specifies how errors are parsed in `icalendar-errors-mode'; +see `compilation-error-regexp-alist'.") + +(define-compilation-mode ical:errors-mode "iCalendar Errors" + "Mode for listing and visiting errors when processing iCalendar data." + :group 'icalendar + (setq-local compilation-error-regexp-alist ical:error-regexp-alist)) + +;; ====================================================================== +;; UIDs +;; ====================================================================== +(defvar ical:-uid-count 0 + "Internal counter for creating unique ids.") + +(defun ical:make-uid (&optional contents _) + "Construct a unique ID from `icalendar-uid-format'. + +CONTENTS can be any object which represents the contents of the +iCalendar component for which the UID is generated. If CONTENTS is a +string with the text property \\='uid, that property's value will be +used as the returned UID. + +Otherwise, CONTENTS will be used to create the hash substituted for +\\='%h' in `icalendar-uid-format'. If CONTENTS is not given, the hash +will be based on an internal counter, the system name, and the current +time in nanoseconds. + +The second optional argument is for backward compatibility and is ignored." + (cl-incf icalendar--uid-count) + (let* ((uid icalendar-uid-format) + (timestamp (format-time-string "%s%N")) + (tohash (or contents + (format "%d%s%s" ical:-uid-count (system-name) timestamp)))) + (if (and (stringp contents) (get-text-property 0 'uid contents)) + ;; "Allow other apps (such as org-mode) to create its own uid" + ;; FIXME: is this necessary? If caller already has a UID, why + ;; call this function at all? + (setq uid (get-text-property 0 'uid contents)) + (progn + (setq uid (replace-regexp-in-string + "%c" (format "%d" icalendar--uid-count) uid t t)) + (setq uid (replace-regexp-in-string + "%t" timestamp uid t t)) + (setq uid (replace-regexp-in-string + "%h" (format "%d" (abs (sxhash tohash))) uid t t)) + (setq uid (replace-regexp-in-string + "%u" (or user-login-name "UNKNOWN_USER") uid t t)) + ;; `%s' no longer used, but allowed for backward compatibility: + (setq uid (replace-regexp-in-string "%s" "" uid t t)))) + uid)) + + +;; Essentially everything beyond this point is obsoleted by the new +;; implementation in diary-icalendar.el. Since the functions below call +;; each other and they still need to live in this file for now (see +;; Bug#74994), prevent byte compiler warnings when compiling this file: +(with-suppressed-warnings + ((obsolete icalendar-import-format + icalendar-import-format-summary + icalendar-import-format-description + icalendar-import-format-location + icalendar-import-format-organizer + icalendar-import-format-url + icalendar-import-format-uid + icalendar-import-format-status + icalendar-import-format-class + icalendar-recurring-start-year + icalendar-export-hidden-diary-entries + icalendar-export-sexp-enumeration-days + icalendar-export-sexp-enumerate-all + icalendar-export-alarms + icalendar-debug nil + icalendar--weekday-array + icalendar--dmsg + icalendar--get-unfolded-buffer + icalendar--clean-up-line-endings + icalendar--rris + icalendar--read-element + icalendar--get-event-property + icalendar--get-event-property-attributes + icalendar--get-event-properties + icalendar--get-children + icalendar--all-events + icalendar--split-value + icalendar--convert-tz-offset + icalendar--parse-vtimezone + icalendar--get-most-recent-observance + icalendar--convert-all-timezones + icalendar--find-time-zone + icalendar--decode-isodatetime + icalendar--decode-isoduration + icalendar--add-decoded-times + icalendar--datetime-to-american-date + icalendar--datetime-to-european-date + icalendar--datetime-to-iso-date + icalendar--datetime-to-diary-date + icalendar--datetime-to-colontime + icalendar--get-month-number + icalendar--get-weekday-number + icalendar--get-weekday-numbers + icalendar--get-weekday-abbrev + icalendar--date-to-isodate + icalendar--datestring-to-isodate + icalendar--diarytime-to-isotime + icalendar--convert-string-for-export + icalendar--convert-string-for-import + icalendar-export-file + icalendar-export-region + icalendar--create-uid + icalendar--convert-to-ical + icalendar--parse-summary-and-rest + icalendar--create-ical-alarm + icalendar--do-create-ical-alarm + icalendar--convert-ordinary-to-ical + icalendar-first-weekday-of-year + icalendar--convert-weekly-to-ical + icalendar--convert-yearly-to-ical + icalendar--convert-sexp-to-ical + icalendar--convert-block-to-ical + icalendar--convert-float-to-ical + icalendar--convert-date-to-ical + icalendar--convert-cyclic-to-ical + icalendar--convert-anniversary-to-ical + icalendar-import-file + icalendar-import-buffer + icalendar--format-ical-event + icalendar--convert-ical-to-diary + icalendar--convert-recurring-to-diary + icalendar--convert-non-recurring-all-day-to-diary + icalendar--convert-non-recurring-not-all-day-to-diary + icalendar--add-diary-entry + icalendar-import-format-sample + icalendar-version)) ;; ====================================================================== ;; Core functionality @@ -321,6 +661,7 @@ Folding is the iCalendar way of wrapping long lines. In the created buffer all occurrences of CR LF BLANK are replaced by the empty string. Argument FOLDED-ICAL-BUFFER is the folded input buffer." + (declare (obsolete icalendar-unfolded-buffer-from-buffer "31.1")) (let ((unfolded-buffer (get-buffer-create " *icalendar-work*"))) (save-current-buffer (set-buffer unfolded-buffer) @@ -337,6 +678,7 @@ buffer." All occurrences of (CR LF) and (LF CF) are replaced with LF in the current buffer. This is necessary in buffers which contain a mix of different line endings." + (declare (obsolete nil "31.1")) (save-excursion (goto-char (point-min)) (while (re-search-forward "\r\n\\|\n\r" nil t) @@ -352,6 +694,8 @@ INPARAMS gives the current parameters..... This function calls itself recursively for each nested calendar element it finds. The current buffer should be an unfolded buffer as returned from `icalendar--get-unfolded-buffer'." + (declare (obsolete "use `icalendar-parse' or one of `icalendar-parse-component', +`icalendar-parse-property', `icalendar-parse-params' instead." "31.1")) (let (element children line name params param param-name param-value value (continue t)) @@ -408,6 +752,7 @@ from `icalendar--get-unfolded-buffer'." (defun icalendar--get-event-property (event prop) "For the given EVENT return the value of the first occurrence of PROP." + (declare (obsolete icalendar-with-component "31.1")) (catch 'found (let ((props (car (cddr event))) pp) (while props @@ -419,6 +764,7 @@ from `icalendar--get-unfolded-buffer'." (defun icalendar--get-event-property-attributes (event prop) "For the given EVENT return attributes of the first occurrence of PROP." + (declare (obsolete icalendar-with-component "31.1")) (catch 'found (let ((props (car (cddr event))) pp) (while props @@ -430,6 +776,7 @@ from `icalendar--get-unfolded-buffer'." (defun icalendar--get-event-properties (event prop) "For the given EVENT return a list of all values of the property PROP." + (declare (obsolete icalendar-with-component "31.1")) (let ((props (car (cddr event))) pp result) (while props (setq pp (car props)) @@ -456,6 +803,7 @@ from `icalendar--get-unfolded-buffer'." "Return all children of the given NODE which have a name NAME. For instance the VCALENDAR node can have VEVENT children as well as VTODO children." + (declare (obsolete icalendar-ast-node-children "31.1")) (let ((result nil) (children (cadr (cddr node)))) (when (eq (car node) name) @@ -476,6 +824,7 @@ children." ;; private (defun icalendar--all-events (icalendar) "Return the list of all existing events in the given ICALENDAR." + (declare (obsolete icalendar-with-component "31.1")) (let ((result '())) (mapc (lambda (elt) (setq result (append (icalendar--get-children elt 'VEVENT) @@ -485,6 +834,7 @@ children." (defun icalendar--split-value (value-string) "Split VALUE-STRING at `;='." + (declare (obsolete nil "31.1")) (let ((result '()) param-name param-value) (when value-string @@ -509,6 +859,7 @@ children." ALIST is an alist entry from a VTIMEZONE, like STANDARD. DST-P is non-nil if this is for daylight savings time. The strings are suitable for assembling into a TZ variable." + (declare (obsolete nil "31.1")) (let* ((offsetto (car (cddr (assq 'TZOFFSETTO alist)))) (offsetfrom (car (cddr (assq 'TZOFFSETFROM alist)))) (rrule-value (car (cddr (assq 'RRULE alist)))) @@ -561,6 +912,7 @@ The strings are suitable for assembling into a TZ variable." "Turn a VTIMEZONE ALIST into a cons (ID . TZ-STRING). Consider only the most recent date specification. Return nil if timezone cannot be parsed." + (declare (obsolete nil "31.1")) (let* ((tz-id (icalendar--convert-string-for-import (icalendar--get-event-property alist 'TZID))) (daylight (cadr (cdar (icalendar--get-most-recent-observance alist 'DAYLIGHT)))) @@ -578,6 +930,7 @@ Return nil if timezone cannot be parsed." "Return the latest observance for SUB-COMP DAYLIGHT or STANDARD. ALIST is a VTIMEZONE potentially containing historical records." ;FIXME?: "most recent" should be relative to a given date + (declare (obsolete icalendar-recur-tz-observance-on "31.1")) (let ((components (icalendar--get-children alist sub-comp))) (list (car @@ -600,6 +953,7 @@ ALIST is a VTIMEZONE potentially containing historical records." "Convert all timezones in the ICALENDAR into an alist. Each element of the alist is a cons (ID . TZ-STRING), like `icalendar--parse-vtimezone'." + (declare (obsolete nil "31.1")) (let (result) (dolist (zone (icalendar--get-children (car icalendar) 'VTIMEZONE)) (setq zone (icalendar--parse-vtimezone zone)) @@ -610,6 +964,7 @@ like `icalendar--parse-vtimezone'." (defun icalendar--find-time-zone (prop-list zone-map) "Return a timezone string for the time zone in PROP-LIST, or nil if none. ZONE-MAP is a timezone alist as returned by `icalendar--convert-all-timezones'." + (declare (obsolete nil "31.1")) (let ((id (plist-get prop-list 'TZID))) (if id (cdr (assoc id zone-map))))) @@ -628,6 +983,7 @@ in any format understood by `encode-time'. RESULT-ZONE, if provided, is the timezone for encoding the result in any format understood by `decode-time'. FIXME: multiple comma-separated values should be allowed!" + (declare (obsolete icalendar-read-date-time "31.1")) (icalendar--dmsg isodatetimestring) (if isodatetimestring ;; day/month/year must be present @@ -685,6 +1041,7 @@ Optional argument DURATION-CORRECTION shortens result by one day. FIXME: TZID-attributes are ignored....! FIXME: multiple comma-separated values should be allowed!" + (declare (obsolete icalendar-read-dur-value "31.1")) (if isodurationstring (save-match-data (string-match @@ -740,6 +1097,7 @@ FIXME: multiple comma-separated values should be allowed!" "Add TIME1 to TIME2. Both times must be given in decoded form. One of these times must be valid (year > 1900 or something)." + (declare (obsolete icalendar-date-time-add "31.1")) ;; FIXME: does this function exist already? Can we use decoded-time-add? (decode-time (encode-time ;; FIXME: Support subseconds. @@ -761,6 +1119,8 @@ valid (year > 1900 or something)." Optional argument SEPARATOR gives the separator between month, day, and year. If nil a blank character is used as separator. American format: \"month day year\"." + (declare (obsolete "use `icalendar-date/time-to-date' and +`diary-icalendar-format-date' instead." "31.1")) (if datetime (format "%d%s%d%s%d" (nth 4 datetime) ;month (or separator " ") @@ -776,6 +1136,7 @@ Optional argument SEPARATOR gives the separator between month, day, and year. If nil a blank character is used as separator. European format: (day month year). FIXME" + (declare (obsolete "use `icalendar-date/time-to-date' and `diary-icalendar-format-date' instead." "31.1")) (if datetime (format "%d%s%d%s%d" (nth 3 datetime) ;day (or separator " ") @@ -790,6 +1151,7 @@ FIXME" Optional argument SEPARATOR gives the separator between month, day, and year. If nil a blank character is used as separator. ISO format: (year month day)." + (declare (obsolete "use `icalendar-date/time-to-date' and `diary-icalendar-format-date' instead." "31.1")) (if datetime (format "%d%s%d%s%d" (nth 5 datetime) ;year (or separator " ") @@ -805,6 +1167,7 @@ Optional argument SEPARATOR gives the separator between month, day, and year. If nil a blank character is used as separator. Call icalendar--datetime-to-*-date according to the current calendar date style." + (declare (obsolete "use `icalendar-date/time-to-date' and `diary-icalendar-format-date' instead." "31.1")) (funcall (intern-soft (format "icalendar--datetime-to-%s-date" calendar-date-style)) datetime separator)) @@ -812,10 +1175,12 @@ calendar date style." (defun icalendar--datetime-to-colontime (datetime) "Extract the time part of a decoded DATETIME into 24-hour format. Note that this silently ignores seconds." + (declare (obsolete diary-icalendar-format-time "31.1")) (format "%02d:%02d" (nth 2 datetime) (nth 1 datetime))) (defun icalendar--get-month-number (monthname) "Return the month number for the given MONTHNAME." + (declare (obsolete nil "31.1")) (catch 'found (let ((num 1) (m (downcase monthname))) @@ -831,6 +1196,7 @@ Note that this silently ignores seconds." (defun icalendar--get-weekday-number (abbrevweekday) "Return the number for the ABBREVWEEKDAY." + (declare (obsolete "see `icalendar-weekday-numbers'" "31.1")) (if abbrevweekday (catch 'found (let ((num 0) @@ -846,6 +1212,7 @@ Note that this silently ignores seconds." (defun icalendar--get-weekday-numbers (abbrevweekdays) "Return the list of numbers for the comma-separated ABBREVWEEKDAYS." + (declare (obsolete "see `icalendar-weekday-numbers'" "31.1")) (when abbrevweekdays (let* ((num -1) (weekday-alist (mapcar (lambda (day) @@ -860,6 +1227,7 @@ Note that this silently ignores seconds." (defun icalendar--get-weekday-abbrev (weekday) "Return the abbreviated WEEKDAY." + (declare (obsolete "see `icalendar-weekday-numbers'" "31.1")) (catch 'found (let ((num 0) (w (downcase weekday))) @@ -877,6 +1245,7 @@ Note that this silently ignores seconds." "Convert DATE to iso-style date. DATE must be a list of the form (month day year). If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days." + (declare (obsolete icalendar-print-date "31.1")) (let ((mdy (calendar-gregorian-from-absolute (+ (calendar-absolute-from-gregorian date) (or day-shift 0))))) @@ -891,6 +1260,7 @@ non-nil, the result is shifted by YEAR-SHIFT years -- YEAR-SHIFT must be either nil or an integer. This function tries to figure the date style from DATESTRING itself. If that is not possible it uses the current calendar date style." + (declare (obsolete "use `diary-icalendar-parse-date-form' and `icalendar-print-date' instead." "31.1")) (let ((day -1) month year) (save-match-data (cond ( ;; iso-style numeric date @@ -981,6 +1351,7 @@ In this example the TIMESTRING would be \"9:30\" and the AMPMSTRING would be \"pm\". The minutes may be missing as long as the colon is missing as well, i.e. \"9\" is allowed as TIMESTRING and has the same result as \"9:00\"." + (declare (obsolete "use `diary-icalendar-parse-time' and `icalendar-print-date-time' instead." "31.1")) (if timestring (let* ((parts (save-match-data (split-string timestring ":"))) (h (car parts)) @@ -1018,20 +1389,19 @@ TIMESTRING and has the same result as \"9:00\"." "Export diary file to iCalendar format. All diary entries in the file DIARY-FILENAME are converted to iCalendar format. The result is appended to the file ICAL-FILENAME." + (declare (obsolete diary-icalendar-export-file "31.1")) (interactive "FExport diary data from file: \n\ Finto iCalendar file: ") (save-current-buffer (set-buffer (find-file diary-filename)) (icalendar-export-region (point-min) (point-max) ical-filename))) -(defvar icalendar--uid-count 0 - "Auxiliary counter for creating unique ids.") - (defun icalendar--create-uid (entry-full contents) "Construct a unique iCalendar UID for a diary entry. ENTRY-FULL is the full diary entry string. CONTENTS is the current iCalendar object, as a string. Increase `icalendar--uid-count'. Returns the UID string." + (declare (obsolete icalendar-make-uid "31.1")) (let ((uid icalendar-uid-format)) (if ;; Allow other apps (such as org-mode) to create its own uid @@ -1055,7 +1425,6 @@ current iCalendar object, as a string. Increase (substring contents (match-beginning 1) (match-end 1)) "DTSTART"))) (setq uid (replace-regexp-in-string "%s" dtstart uid t t)))) - ;; Return the UID string uid)) @@ -1068,6 +1437,7 @@ ICAL-FILENAME. This function attempts to return t if something goes wrong. In this case an error string which describes all the errors and problems is written into the buffer `*icalendar-errors*'." + (declare (obsolete diary-icalendar-export-region "31.1")) (interactive "r FExport diary data into iCalendar file: ") (let ((result "") @@ -1179,6 +1549,7 @@ FExport diary data into iCalendar file: ") "Convert a diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (or (unless icalendar-export-sexp-enumerate-all (or @@ -1208,6 +1579,7 @@ entries. ENTRY-MAIN is the first line of the diary entry." (defun icalendar--parse-summary-and-rest (summary-and-rest) "Parse SUMMARY-AND-REST from a diary to fill iCalendar properties. Returns an alist." + (declare (obsolete diary-icalendar-parse-entry "31.1")) (save-match-data (if (functionp icalendar-import-format) ;; can't do anything @@ -1322,6 +1694,7 @@ Returns an alist." (defun icalendar--create-ical-alarm (summary) "Return VALARM blocks for the given SUMMARY." + (declare (obsolete diary-icalendar-add-valarms "31.1")) (when icalendar-export-alarms (let* ((advance-time (car icalendar-export-alarms)) (alarm-specs (cadr icalendar-export-alarms)) @@ -1337,6 +1710,7 @@ is a list which must be one of (audio), (display) or \(email (ADDRESS1 ...)), see `icalendar-export-alarms'. Argument SUMMARY is a string which contains a short description for the alarm." + (declare (obsolete diary-icalendar-add-valarms "31.1")) (let* ((action (car alarm-spec)) (act (format "\nACTION:%s" (cdr (assoc action '((audio . "AUDIO") @@ -1362,6 +1736,7 @@ alarm." "Convert \"ordinary\" diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\)\\s-*" ; date @@ -1445,6 +1820,7 @@ entries. ENTRY-MAIN is the first line of the diary entry." (defun icalendar-first-weekday-of-year (abbrevweekday year) "Find the first ABBREVWEEKDAY in a given YEAR. Returns day number." + (declare (obsolete icalendar-nth-weekday-in "31.1")) (let* ((day-of-week-jan01 (calendar-day-of-week (list 1 1 year))) (result (+ 1 (- (icalendar--get-weekday-number abbrevweekday) @@ -1459,6 +1835,7 @@ Returns day number." "Convert weekly diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (and (string-match (concat nonmarker "\\([a-z]+\\)\\s-+" "\\(\\([0-9][0-9]?:[0-9][0-9]\\)" @@ -1541,6 +1918,7 @@ entries. ENTRY-MAIN is the first line of the diary entry." "Convert yearly diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker (if (eq calendar-date-style 'european) "\\([0-9]+[0-9]?\\)\\s-+\\([a-z]+\\)\\s-+" @@ -1626,6 +2004,7 @@ ENTRY-MAIN is the first line of the diary entry. Optional argument START determines the first day of the enumeration, given as a Lisp time value -- used for test purposes." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (cond ((string-match (concat nonmarker "%%(and \\(([^)]+)\\))\\(\\s-*.*?\\) ?$") entry-main) @@ -1678,6 +2057,7 @@ enumeration, given as a Lisp time value -- used for test purposes." "Convert block diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "%%(diary-block \\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\)" " +\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*" @@ -1753,10 +2133,11 @@ entries. ENTRY-MAIN is the first line of the diary entry." (defun icalendar--convert-float-to-ical (nonmarker entry-main) "Convert float diary entry to iCalendar format -- partially unsupported! - FIXME! DAY from `diary-float' yet unimplemented. + FIXME! DAY from `diary-float' yet unimplemented. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "%%\\((diary-float .+\\) ?$") entry-main) (with-temp-buffer (insert (match-string 1 entry-main)) @@ -1817,6 +2198,7 @@ FIXME! NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "%%(diary-date \\([^)]+\\))\\s-*\\(.*?\\) ?$") entry-main) @@ -1830,6 +2212,7 @@ entries. ENTRY-MAIN is the first line of the diary entry." "Convert `diary-cyclic' diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "%%(diary-cyclic \\([^ ]+\\) +" "\\([^ /]+[ /]+[^ /]+[ /]+[^ ]+\\))\\s-*" @@ -1904,6 +2287,7 @@ entries. ENTRY-MAIN is the first line of the diary entry." "Convert `diary-anniversary' diary entry to iCalendar format. NONMARKER is a regular expression matching the start of non-marking entries. ENTRY-MAIN is the first line of the diary entry." + (declare (obsolete "use `diary-icalendar-parse-entry' and `icalendar-print-component-node' instead." "31.1")) (if (string-match (concat nonmarker "%%(diary-anniversary \\([^)]+\\))\\s-*" "\\(\\([0-9][0-9]?:[0-9][0-9]\\)\\([ap]m\\)?" @@ -1986,6 +2370,7 @@ Argument ICAL-FILENAME output iCalendar file. Argument DIARY-FILENAME input `diary-file'. Optional argument NON-MARKING determines whether events are created as non-marking or not." + (declare (obsolete diary-icalendar-import-file "31.1")) (interactive "fImport iCalendar data from file: \nFInto diary file: \nP") ;; clean up the diary file (save-current-buffer @@ -2012,6 +2397,7 @@ non-marking. Return code t means that importing worked well, return code nil means that an error has occurred. Error messages will be in the buffer `*icalendar-errors*'." + (declare (obsolete diary-icalendar-import-buffer "31.1")) (interactive) (save-current-buffer ;; prepare ical @@ -2048,6 +2434,7 @@ buffer `*icalendar-errors*'." (defun icalendar--format-ical-event (event) "Create a string representation of an iCalendar EVENT." + (declare (obsolete diary-icalendar-format-entry "31.1")) (if (functionp icalendar-import-format) (funcall icalendar-import-format event) (let ((string icalendar-import-format) @@ -2093,6 +2480,7 @@ events are created as non-marking. This function attempts to return t if something goes wrong. In this case an error string which describes all the errors and problems is written into the buffer `*icalendar-errors*'." + (declare (obsolete diary-icalendar-import-buffer "31.1")) (let* ((ev (icalendar--all-events ical-list)) (error-string "") (event-ok t) @@ -2255,6 +2643,7 @@ written into the buffer `*icalendar-errors*'." DTSTART-DEC is the DTSTART property of E. START-T is the event's start time in diary format. END-T is the event's end time in diary format." + (declare (obsolete diary-icalendar-format-entry "31.1")) (icalendar--dmsg "recurring event") (let* ((rrule (icalendar--get-event-property e 'RRULE)) (rrule-props (icalendar--split-value rrule)) @@ -2492,6 +2881,7 @@ END-T is the event's end time in diary format." DTSTART is the decoded DTSTART property of E. Argument START-D gives the first day. Argument END-D gives the last day." + (declare (obsolete diary-icalendar-format-time-range "31.1")) (icalendar--dmsg "non-recurring all-day event") (format "%%%%(and (diary-block %s %s))" start-d end-d)) @@ -2503,6 +2893,7 @@ Argument END-D gives the last day." DTSTART-DEC is the decoded DTSTART property of E. START-T is the event's start time in diary format. END-T is the event's end time in diary format." + (declare (obsolete diary-icalendar-format-time-range "31.1")) (icalendar--dmsg "not all day event") (cond (end-t (format "%s %s-%s" @@ -2523,6 +2914,8 @@ determines whether diary events are created as non-marking. If SUMMARY is not nil it must be a string that gives the summary of the entry. In this case the user will be asked whether he wants to insert the entry." + (declare (obsolete "see `diary-icalendar-post-entry-format-hook' and +`diary-icalendar--entry-import'" "31.1")) (when (or (not summary) (y-or-n-p (format-message "Add appointment for `%s' to diary? " summary))) @@ -2541,6 +2934,7 @@ the entry." ;; ====================================================================== (defun icalendar-import-format-sample (event) "Example function for formatting an iCalendar EVENT." + (declare (obsolete "see `diary-icalendar-vevent-skeleton'" "31.1")) (format (concat "SUMMARY='%s' DESCRIPTION='%s' LOCATION='%s' ORGANIZER='%s' " "STATUS='%s' URL='%s' CLASS='%s'") (or (icalendar--get-event-property event 'SUMMARY) "") @@ -2551,6 +2945,8 @@ the entry." (or (icalendar--get-event-property event 'URL) "") (or (icalendar--get-event-property event 'CLASS) ""))) +) ; Closes the top-level `with-suppressed-warnings' form above + ;; Obsolete (defconst icalendar-version "0.19" "Version number of icalendar.el.") @@ -2558,4 +2954,7 @@ the entry." (provide 'icalendar) +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; End: ;;; icalendar.el ends here diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-american new file mode 100644 index 00000000000..3f810d31f3b --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-american @@ -0,0 +1,8 @@ +&5/15/2012 15:00-15:30 Query + Location: phone + Status: confirmed + Organizer: A. Luser + Attendee: Luser, Other (needs-action) + Access: public + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 + Description: Whassup? diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-european new file mode 100644 index 00000000000..0555ea90364 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-european @@ -0,0 +1,8 @@ +&15/5/2012 15:00-15:30 Query + Location: phone + Status: confirmed + Organizer: A. Luser + Attendee: Luser, Other (needs-action) + Access: public + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 + Description: Whassup? diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-iso new file mode 100644 index 00000000000..0e3a3fb8715 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-11473.diary-iso @@ -0,0 +1,8 @@ +&2012/5/15 15:00-15:30 Query + Location: phone + Status: confirmed + Organizer: A. Luser + Attendee: Luser, Other (needs-action) + Access: public + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 + Description: Whassup? diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-american new file mode 100644 index 00000000000..d7866ddb899 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-american @@ -0,0 +1,6 @@ +&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Location: Stavanger-Sola + Category: Appointment + Access: public + UID: RFCALITEM1 + Description: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-european new file mode 100644 index 00000000000..ce9933aa5f8 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-european @@ -0,0 +1,6 @@ +&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Location: Stavanger-Sola + Category: Appointment + Access: public + UID: RFCALITEM1 + Description: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-iso new file mode 100644 index 00000000000..9c45f848e76 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-22092.diary-iso @@ -0,0 +1,6 @@ +&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - + Location: Stavanger-Sola + Category: Appointment + Access: public + UID: RFCALITEM1 + Description: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-24199.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-bug-24199.diary-all new file mode 100644 index 00000000000..cf3e5884710 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-24199.diary-all @@ -0,0 +1,11 @@ +&%%(diary-rrule :rule '((FREQ MONTHLY) (BYDAY ((3 . 1))) (INTERVAL 1)) + :exclude + '((0 46 11 6 1 2016 3 -1 0) (0 46 11 3 2 2016 3 -1 0) + (0 46 11 2 3 2016 3 -1 0) (0 46 10 4 5 2016 3 -1 0) + (0 46 10 1 6 2016 3 -1 0)) + :start '(0 46 12 2 12 2015 3 -1 nil) :duration + '(0 14 3 0 nil nil nil -1 nil)) Summary + Location: Loc + Access: private + UID: 9188710a-08a7-4061-bae3-d4cf4972599a + Description: Desc diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-american new file mode 100644 index 00000000000..c546fa9a97c --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-american @@ -0,0 +1 @@ +&11/5/2018 21:00 event with same start/end time diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-european new file mode 100644 index 00000000000..28e53960536 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-european @@ -0,0 +1 @@ +&5/11/2018 21:00 event with same start/end time diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-iso new file mode 100644 index 00000000000..faa7aeafeb5 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-33277.diary-iso @@ -0,0 +1 @@ +&2018/11/5 21:00 event with same start/end time diff --git a/test/lisp/calendar/diary-icalendar-resources/import-bug-6766.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-bug-6766.diary-all new file mode 100644 index 00000000000..4e1b69158c9 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-bug-6766.diary-all @@ -0,0 +1,12 @@ +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 1) (BYDAY (1 3 4 5))) + :start '(0 30 11 21 4 2010 3 -1 nil) :duration + '(0 30 0 0 nil nil nil -1 nil)) Scrum + Status: confirmed + Access: public + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 + +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 1) (BYDAY (2 4))) :start + '(4 22 2010) :duration + '(nil nil nil 1 nil nil nil -1 nil)) Tues + Thurs thinking + Access: public + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 diff --git a/test/lisp/calendar/diary-icalendar-resources/import-duration-2.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-duration-2.diary-all new file mode 100644 index 00000000000..5d018c1cb6e --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-duration-2.diary-all @@ -0,0 +1,5 @@ +&%%(diary-rrule :rule + '((FREQ DAILY) (UNTIL (12 29 2001)) (INTERVAL 1) (WKST 0)) + :start '(12 21 2001)) Urlaub + Access: public + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda diff --git a/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-american new file mode 100644 index 00000000000..b44b4aed72c --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-american @@ -0,0 +1 @@ +&%%(diary-block 2 17 2005 2 23 2005) duration diff --git a/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-european new file mode 100644 index 00000000000..caee11e0a38 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-european @@ -0,0 +1 @@ +&%%(diary-block 17 2 2005 23 2 2005) duration diff --git a/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-iso new file mode 100644 index 00000000000..573121644d5 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-duration.diary-iso @@ -0,0 +1 @@ +&%%(diary-block 2005 2 17 2005 2 23) duration diff --git a/test/lisp/calendar/diary-icalendar-resources/import-legacy-function.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-legacy-function.diary-all new file mode 100644 index 00000000000..e0d27f4d1b0 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-legacy-function.diary-all @@ -0,0 +1,10 @@ + SUMMARY: Testing legacy `icalendar-import-format' function + DESCRIPTION: described + CLASS: private + LOCATION: somewhere + ORGANIZER: mailto:baz@example.com + STATUS: CONFIRMED + URL: http://example.com/foo/baz + UID: some-unique-id-here + DTSTART: 20250919T090000 + DTEND: 20250919T113000 diff --git a/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-american new file mode 100644 index 00000000000..42076a32138 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-american @@ -0,0 +1,8 @@ +9/19/2025 09:00-11:30 Testing legacy `icalendar-import-format*' vars + CLASS=private + DESCRIPTION=described + LOCATION=somewhere + ORGANIZER=mailto:baz@example.com + STATUS=confirmed + URL=http://example.com/foo/baz + UID=some-unique-id-here \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-european new file mode 100644 index 00000000000..699c627e2f9 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-european @@ -0,0 +1,8 @@ +19/9/2025 09:00-11:30 Testing legacy `icalendar-import-format*' vars + CLASS=private + DESCRIPTION=described + LOCATION=somewhere + ORGANIZER=mailto:baz@example.com + STATUS=confirmed + URL=http://example.com/foo/baz + UID=some-unique-id-here \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-iso new file mode 100644 index 00000000000..f6d69805c19 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-legacy-vars.diary-iso @@ -0,0 +1,8 @@ +2025/9/19 09:00-11:30 Testing legacy `icalendar-import-format*' vars + CLASS=private + DESCRIPTION=described + LOCATION=somewhere + ORGANIZER=mailto:baz@example.com + STATUS=confirmed + URL=http://example.com/foo/baz + UID=some-unique-id-here \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-american new file mode 100644 index 00000000000..ef28f1abfc1 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-american @@ -0,0 +1,7 @@ +&7/23/2011 event-1 + +&7/24/2011 event-2 + +&7/25/2011 event-3a + +&7/25/2011 event-3b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-european new file mode 100644 index 00000000000..db9625f390d --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-european @@ -0,0 +1,7 @@ +&23/7/2011 event-1 + +&24/7/2011 event-2 + +&25/7/2011 event-3a + +&25/7/2011 event-3b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-iso new file mode 100644 index 00000000000..bbe009c200e --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-multiple-vcalendars.diary-iso @@ -0,0 +1,7 @@ +&2011/7/23 event-1 + +&2011/7/24 event-2 + +&2011/7/25 event-3a + +&2011/7/25 event-3b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-american new file mode 100644 index 00000000000..780e3a8ce64 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-american @@ -0,0 +1 @@ +&9/19/2003 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-european new file mode 100644 index 00000000000..7e0cd21b784 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-european @@ -0,0 +1 @@ +&19/9/2003 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-iso new file mode 100644 index 00000000000..c7311286619 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-1.diary-iso @@ -0,0 +1 @@ +&2003/9/19 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-american new file mode 100644 index 00000000000..1d4bb6a337e --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-american @@ -0,0 +1 @@ +&9/19/2003 non-recurring allday diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-european new file mode 100644 index 00000000000..b56c7f4e17f --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-european @@ -0,0 +1 @@ +&19/9/2003 non-recurring allday diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-iso new file mode 100644 index 00000000000..f1c70ab34c3 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-all-day.diary-iso @@ -0,0 +1 @@ +&2003/9/19 non-recurring allday diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-american new file mode 100644 index 00000000000..847e7cf6cab --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-american @@ -0,0 +1,4 @@ +&11/23/2004 14:45-15:45 another example + Status: tentative + Access: private + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-european new file mode 100644 index 00000000000..5c70e58f4d0 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-european @@ -0,0 +1,4 @@ +&23/11/2004 14:45-15:45 another example + Status: tentative + Access: private + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-iso new file mode 100644 index 00000000000..d663965404b --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-another-example.diary-iso @@ -0,0 +1,4 @@ +&2004/11/23 14:45-15:45 another example + Status: tentative + Access: private + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-american new file mode 100644 index 00000000000..c795ebf2abc --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-american @@ -0,0 +1,4 @@ +&%%(diary-block 7 19 2004 8 27 2004) Sommerferien + Status: tentative + Access: private + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-european new file mode 100644 index 00000000000..4d6b71600a8 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-european @@ -0,0 +1,4 @@ +&%%(diary-block 19 7 2004 27 8 2004) Sommerferien + Status: tentative + Access: private + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-iso new file mode 100644 index 00000000000..f6d23b049ed --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-block.diary-iso @@ -0,0 +1,4 @@ +&%%(diary-block 2004 7 19 2004 8 27) Sommerferien + Status: tentative + Access: private + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-american new file mode 100644 index 00000000000..a86f560fb08 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-american @@ -0,0 +1,4 @@ +&11/23/2004 14:00-14:30 folded summary + Status: tentative + Access: private + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-european new file mode 100644 index 00000000000..0c5e640a615 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-european @@ -0,0 +1,4 @@ +&23/11/2004 14:00-14:30 folded summary + Status: tentative + Access: private + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-iso new file mode 100644 index 00000000000..699358dc504 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-folded-summary.diary-iso @@ -0,0 +1,4 @@ +&2004/11/23 14:00-14:30 folded summary + Status: tentative + Access: private + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-american new file mode 100644 index 00000000000..84cd464c568 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-american @@ -0,0 +1 @@ +&9/19/2003 long summary diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-european new file mode 100644 index 00000000000..5d6524202c3 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-european @@ -0,0 +1 @@ +&19/9/2003 long summary diff --git a/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-iso new file mode 100644 index 00000000000..d2300522d9a --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-non-recurring-long-summary.diary-iso @@ -0,0 +1 @@ +&2003/9/19 long summary diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-american new file mode 100644 index 00000000000..53711dc68ed --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-american @@ -0,0 +1,10 @@ +&5/9/2003 10:30-15:30 On-Site Interview + Location: Cccc + Status: confirmed + Organizer: Aaaaaa Aaaaa + Attendees: + Xxxxxxxx Xxxxxxxxxxxx (needs-action) + Yyyyyyy Yyyyy (needs-action) + Zzzz Zzzzzz (needs-action) + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 + Description: 10:30am - Blah diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-european new file mode 100644 index 00000000000..17efbd64c18 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-05-29.diary-european @@ -0,0 +1,10 @@ +&9/5/2003 10:30-15:30 On-Site Interview + Location: Cccc + Status: confirmed + Organizer: Aaaaaa Aaaaa + Attendees: + Xxxxxxxx Xxxxxxxxxxxx (needs-action) + Yyyyyyy Yyyyy (needs-action) + Zzzz Zzzzzz (needs-action) + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 + Description: 10:30am - Blah diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-american new file mode 100644 index 00000000000..1b819404abf --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-american @@ -0,0 +1,8 @@ +&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Status: confirmed + Organizer: ABCD,TECHTRAINING(A-Americas,exgen1) + Attendee: + AAAAA,AAAAA (A-AAAAAAA,ex1) (needs-action) + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E + Description: 753 Zeichen hier radiert diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-european new file mode 100644 index 00000000000..379c612419f --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18a.diary-european @@ -0,0 +1,8 @@ +&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Status: confirmed + Organizer: ABCD,TECHTRAINING(A-Americas,exgen1) + Attendee: + AAAAA,AAAAA (A-AAAAAAA,ex1) (needs-action) + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E + Description: 753 Zeichen hier radiert diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-american new file mode 100644 index 00000000000..0e34b5d7fa9 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-american @@ -0,0 +1,6 @@ +&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier frĂŒher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-european new file mode 100644 index 00000000000..e6151c78dce --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2003-06-18b.diary-european @@ -0,0 +1,5 @@ +&23/6/2003 09:00-10:00 Updated: Dress Rehearsal for ABC01-15 + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Status: confirmed + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E + Description: Viele Zeichen standen hier frĂŒher \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-american new file mode 100644 index 00000000000..17dff899314 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-american @@ -0,0 +1,28 @@ +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 1) (BYDAY (1))) :start + '(11 1 2004) :duration + '(nil nil nil 1 nil nil nil -1 nil)) Wwww aa hhhh + Status: tentative + Access: private + +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 2) (BYDAY (5))) :start + '(0 0 14 12 11 2004 5 -1 nil) :duration + '(0 30 4 0 nil nil nil -1 nil)) MMM Aaaaaaaaa + Status: tentative + Access: private + +&%%(diary-block 11 19 2004 11 19 2004) Rrrr/Cccccc ii Aaaaaaaa + Status: tentative + Access: private + Description: Vvvvv Rrrr aaa Cccccc + +&11/23/2004 11:00-12:00 Hhhhhhhh + Status: tentative + Access: private + +&11/23/2004 14:00-14:30 Jjjjj & Wwwww + Status: tentative + Access: private + +&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: tentative + Access: private diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-european new file mode 100644 index 00000000000..cfd3a43d55c --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2004-11-19.diary-european @@ -0,0 +1,28 @@ +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 1) (BYDAY (1))) :start + '(11 1 2004) :duration + '(nil nil nil 1 nil nil nil -1 nil)) Wwww aa hhhh + Status: tentative + Access: private + +&%%(diary-rrule :rule '((FREQ WEEKLY) (INTERVAL 2) (BYDAY (5))) :start + '(0 0 14 12 11 2004 5 -1 nil) :duration + '(0 30 4 0 nil nil nil -1 nil)) MMM Aaaaaaaaa + Status: tentative + Access: private + +&%%(diary-block 19 11 2004 19 11 2004) Rrrr/Cccccc ii Aaaaaaaa + Status: tentative + Access: private + Description: Vvvvv Rrrr aaa Cccccc + +&23/11/2004 11:00-12:00 Hhhhhhhh + Status: tentative + Access: private + +&23/11/2004 14:00-14:30 Jjjjj & Wwwww + Status: tentative + Access: private + +&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: tentative + Access: private diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-american new file mode 100644 index 00000000000..f7518918f30 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-american @@ -0,0 +1,6 @@ +&%%(diary-block 2 6 2005 2 6 2005) Waitangi Day + Status: confirmed + Category: Public Holiday + Access: private + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 + Description: abcdef diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-european new file mode 100644 index 00000000000..c65526a5551 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-02-07.diary-european @@ -0,0 +1,6 @@ +&%%(diary-block 6 2 2005 6 2 2005) Waitangi Day + Status: confirmed + Category: Public Holiday + Access: private + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 + Description: abcdef diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-american new file mode 100644 index 00000000000..9290254f1ce --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-american @@ -0,0 +1,2 @@ +&%%(diary-block 2 17 2005 2 23 2005) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-european new file mode 100644 index 00000000000..61cbbc726d3 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-2005-03-01.diary-european @@ -0,0 +1,2 @@ +&%%(diary-block 17 2 2005 23 2 2005) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-american new file mode 100644 index 00000000000..6c1d6667e63 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-american @@ -0,0 +1,4 @@ +&11/16/2014 07:00-08:00 NoDST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com + Description: Test event from timezone without DST diff --git a/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-european new file mode 100644 index 00000000000..b710b4c61e5 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-real-world-no-dst.diary-european @@ -0,0 +1,4 @@ +&16/11/2014 07:00-08:00 NoDST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com + Description: Test event from timezone without DST diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-anniversary.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-anniversary.diary-all new file mode 100644 index 00000000000..ce87095c080 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-anniversary.diary-all @@ -0,0 +1 @@ +&%%(diary-rrule :rule '((FREQ YEARLY)) :start '(8 15 2004)) Maria Himmelfahrt diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-bi-weekly.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-bi-weekly.diary-all new file mode 100644 index 00000000000..9c5cb38ddb8 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-bi-weekly.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ WEEKLY) (COUNT 3) (INTERVAL 2)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count bi-weekly 3 times \ No newline at end of file diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-long.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-long.diary-all new file mode 100644 index 00000000000..3b7b4532506 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-long.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ DAILY) (COUNT 14) (INTERVAL 1)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count daily long diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-short.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-short.diary-all new file mode 100644 index 00000000000..08051f0d015 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-daily-short.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ DAILY) (COUNT 1) (INTERVAL 1)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count daily short diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-month.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-month.diary-all new file mode 100644 index 00000000000..e5063cfed3b --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-month.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ MONTHLY) (INTERVAL 2) (COUNT 5)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count every second month diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-year.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-year.diary-all new file mode 100644 index 00000000000..74fbc93986c --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-every-second-year.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ YEARLY) (INTERVAL 2) (COUNT 5)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count every second year diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-monthly.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-monthly.diary-all new file mode 100644 index 00000000000..af145bbdee9 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-monthly.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ MONTHLY) (INTERVAL 1) (COUNT 5)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count monthly diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-yearly.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-yearly.diary-all new file mode 100644 index 00000000000..5b78f608f12 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-count-yearly.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ YEARLY) (INTERVAL 1) (COUNT 5)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule count yearly diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-two-day.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-two-day.diary-all new file mode 100644 index 00000000000..9017c06900b --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-two-day.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ DAILY) (INTERVAL 2)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule daily diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-with-exceptions.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-with-exceptions.diary-all new file mode 100644 index 00000000000..0407aa81b21 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily-with-exceptions.diary-all @@ -0,0 +1,4 @@ +&%%(diary-rrule :rule '((FREQ DAILY) (INTERVAL 2)) :exclude + '((9 21 2003) (9 25 2003)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule daily with exceptions diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily.diary-all new file mode 100644 index 00000000000..993d3b9bb5e --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-daily.diary-all @@ -0,0 +1,2 @@ +&%%(diary-rrule :rule '((FREQ DAILY)) :start '(0 0 9 19 9 2003 5 -1 nil) + :duration '(0 30 2 0 nil nil nil -1 nil)) rrule daily diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-no-end.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-no-end.diary-all new file mode 100644 index 00000000000..e69a6ec690c --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-no-end.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ MONTHLY)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule monthly no end diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-with-end.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-with-end.diary-all new file mode 100644 index 00000000000..a699498be77 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-monthly-with-end.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ MONTHLY) (UNTIL (8 19 2005))) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule monthly with end diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-weekly.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-weekly.diary-all new file mode 100644 index 00000000000..89ba3e96149 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-weekly.diary-all @@ -0,0 +1,2 @@ +&%%(diary-rrule :rule '((FREQ WEEKLY)) :start '(0 0 9 19 9 2003 5 -1 nil) + :duration '(0 30 2 0 nil nil nil -1 nil)) rrule weekly diff --git a/test/lisp/calendar/diary-icalendar-resources/import-rrule-yearly.diary-all b/test/lisp/calendar/diary-icalendar-resources/import-rrule-yearly.diary-all new file mode 100644 index 00000000000..81220aac0cd --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-rrule-yearly.diary-all @@ -0,0 +1,3 @@ +&%%(diary-rrule :rule '((FREQ YEARLY) (INTERVAL 2)) :start + '(0 0 9 19 9 2003 5 -1 nil) :duration + '(0 30 2 0 nil nil nil -1 nil)) rrule yearly diff --git a/test/lisp/calendar/diary-icalendar-resources/import-time-format-12hr-blank.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-time-format-12hr-blank.diary-iso new file mode 100644 index 00000000000..0945cfc0b60 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-time-format-12hr-blank.diary-iso @@ -0,0 +1 @@ +&2003/9/19 9.00h-11.30h 12hr blank-padded diff --git a/test/lisp/calendar/diary-icalendar-resources/import-with-attachment.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-with-attachment.diary-iso new file mode 100644 index 00000000000..b16022908d9 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-with-attachment.diary-iso @@ -0,0 +1,3 @@ +&2003/9/19 09:00 Has an attachment + Attachment: R3Jl.plain + UID: f9fee9a0-1231-4984-9078-f1357db352db diff --git a/test/lisp/calendar/diary-icalendar-resources/import-with-timezone.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-with-timezone.diary-iso new file mode 100644 index 00000000000..56f91066f73 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-with-timezone.diary-iso @@ -0,0 +1,3 @@ +&2012/1/15 15:00-15:30 standardtime + +&2012/12/15 11:00-11:30 daylightsavingtime diff --git a/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-american b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-american new file mode 100644 index 00000000000..9b2f06afc26 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-american @@ -0,0 +1,2 @@ +&9/19/2003 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-european b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-european new file mode 100644 index 00000000000..95db4d40151 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-european @@ -0,0 +1,2 @@ +&19/9/2003 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-iso b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-iso new file mode 100644 index 00000000000..d372e5a3d1f --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-resources/import-with-uid.diary-iso @@ -0,0 +1,2 @@ +&2003/9/19 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/diary-icalendar-tests.el b/test/lisp/calendar/diary-icalendar-tests.el new file mode 100644 index 00000000000..40d68f82d55 --- /dev/null +++ b/test/lisp/calendar/diary-icalendar-tests.el @@ -0,0 +1,1277 @@ +;;; diary-icalendar-tests.el --- Tests for diary-icalendar -*- lexical-binding: t; -*- +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'icalendar-macs)) +(require 'diary-icalendar) +(require 'icalendar-parser) +(require 'icalendar-utils) +(require 'icalendar) +(require 'ert) +(require 'ert-x) +(require 'seq) + + +;; Tests for diary import functions +(defconst icalendar-resources-directory + (expand-file-name "test/lisp/calendar/icalendar-resources" + source-directory)) + +(defconst diary-icalendar-resources-directory + (expand-file-name "test/lisp/calendar/diary-icalendar-resources" + source-directory)) + +(defun dit:icalendar-resource-file (filename) + ;; Return a filename from the ./icalendar-resources directory: + (file-name-concat icalendar-resources-directory filename)) + +(defun dit:resource-file (filename) + ;; Return a filename from the ./diary-icalendar-resources directory: + (file-name-concat diary-icalendar-resources-directory filename)) + +(defun dit:file-contents (filename) + "Return literal contents of FILENAME." + (with-temp-buffer + (let ((coding-system-for-read 'raw-text) + (inhibit-eol-conversion t)) + (insert-file-contents-literally filename) + (buffer-string)))) + +(defmacro dit:with-tz (tz &rest body) + "Evaluate BODY with time zone TZ in effect." + `(let ((old-tz (getenv "TZ"))) + (unwind-protect + (progn + (setenv "TZ" ,tz) + ,@body) + (setenv "TZ" old-tz)))) + +(defun dit:import-file (ics-file) + "Test diary import of ICS-FILE. + +ICS-FILE names a .ics file in icalendar-resources directory. The +calendar in ICS-FILE is parsed and imported in ISO, European, and +American date styles. The output of each import is compared against the +contents of any diary files with the same base name as ICS-FILE and +extensions \".diary-all\", \".diary-american\", \".diary-european\", or +\".diary-iso\"." + (let* ((basename (file-name-base ics-file)) + (ics-file (dit:icalendar-resource-file ics-file)) + (import-buffer (icalendar-unfolded-buffer-from-file ics-file)) + (all-file (dit:resource-file (concat basename ".diary-all"))) + (iso-file (dit:resource-file (concat basename ".diary-iso"))) + (european-file (dit:resource-file (concat basename ".diary-european"))) + (american-file (dit:resource-file (concat basename ".diary-american")))) + (with-current-buffer import-buffer + (when (file-exists-p all-file) + (calendar-set-date-style 'american) ; because it's the default + (dit:-do-test-import all-file)) + (when (file-exists-p iso-file) + (calendar-set-date-style 'iso) + (dit:-do-test-import iso-file)) + (when (file-exists-p european-file) + (calendar-set-date-style 'european) + (dit:-do-test-import european-file)) + (when (file-exists-p american-file) + (calendar-set-date-style 'american) + (dit:-do-test-import american-file)) + (set-buffer-modified-p nil)) ; so we can kill it without being asked + (kill-buffer import-buffer))) + +(defun dit:-do-test-import (diary-filename) + "Import iCalendar in current buffer and compare the result with DIARY-FILENAME." + (ert-with-temp-file temp-file + :suffix "icalendar-test-diary" + (dit:with-tz "Europe/Vienna" + ;; There's no way to make the test data independent of the system + ;; time zone unless diary gains time zone awareness/syntax, so we have + ;; to choose some time zone or other to standardize on for the import + ;; tests. "Europe/Vienna" is an arbitrary choice; it's simply the one + ;; I originally generated the test data files in. + ;; N.B. "Europe/Vienna" = "CET-1CEST,M3.5.0/02:00,M10.5.0/03:00" + (di:import-buffer temp-file t t)) + (save-excursion + (find-file temp-file) + (let ((result (buffer-substring-no-properties (point-min) (point-max))) + (expected (dit:file-contents diary-filename))) + ;; Trim the result so that whitespace produced by the importer + ;; need not be committed in the test data files: + (should (equal (string-trim result) + (string-trim expected))) + ;; This is useful for debugging differences when tests are failing: + ;; (unless (equal (string-trim result) + ;; (string-trim expected)) + ;; (let ((result-buf (current-buffer)) + ;; (diary-buf (find-file diary-filename))) + ;; (ediff-buffers result-buf ; actual output + ;; diary-buf) + ;; (switch-to-buffer-other-frame "*Ediff Control Panel*") + ;; (error "Unexpected result; see ediff"))) + )) + (kill-buffer (find-buffer-visiting temp-file)))) + +(ert-deftest dit:import-non-recurring () + "Import tests for standard, non-recurring events." + (dit:import-file "import-non-recurring-1.ics") + (dit:import-file "import-non-recurring-all-day.ics") + (dit:import-file "import-non-recurring-long-summary.ics") + (dit:import-file "import-non-recurring-block.ics") + (dit:import-file "import-non-recurring-folded-summary.ics") + (dit:import-file "import-non-recurring-another-example.ics")) + +(ert-deftest dit:import-w/legacy-vars () + "Import tests using legacy import variables" + (let ((icalendar-import-format "%s%c%d%l%o%t%u%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-class "\n CLASS=%s") + (icalendar-import-format-description "\n DESCRIPTION=%s") + (icalendar-import-format-location "\n LOCATION=%s") + (icalendar-import-format-organizer "\n ORGANIZER=%s") + (icalendar-import-format-status "\n STATUS=%s") + (icalendar-import-format-url "\n URL=%s") + (icalendar-import-format-uid "\n UID=%s")) + (dit:import-file "import-legacy-vars.ics"))) + +(defun dit:legacy-import-function (vevent) + "Example function value for `icalendar-import-format'" + (let ((props (nth 2 (car vevent)))) + (mapconcat + (lambda (prop) + (format " %s: %s\n" + (symbol-name (nth 0 prop)) + (nth 2 prop))) + props))) + +(ert-deftest dit:import-w/legacy-function () + "Import tests using legacy import variables" + (let ((icalendar-import-format 'dit:legacy-import-function)) + (dit:import-file "import-legacy-function.ics"))) + +(ert-deftest dit:import-w/time-format () + "Import tests for customized `diary-icalendar-time-format'" + (let ((diary-icalendar-time-format "%l.%Mh")) + (dit:import-file "import-time-format-12hr-blank.ics"))) + +(ert-deftest dit:import-rrule () + "Import tests for recurring events." + (dit:import-file "import-rrule-daily.ics") + (dit:import-file "import-rrule-daily-two-day.ics") + (dit:import-file "import-rrule-daily-with-exceptions.ics") + (dit:import-file "import-rrule-weekly.ics") + (dit:import-file "import-rrule-monthly-no-end.ics") + (dit:import-file "import-rrule-monthly-with-end.ics") + (dit:import-file "import-rrule-anniversary.ics") + (dit:import-file "import-rrule-yearly.ics") + (dit:import-file "import-rrule-count-bi-weekly.ics") + (dit:import-file "import-rrule-count-daily-short.ics") + (dit:import-file "import-rrule-count-daily-long.ics") + (dit:import-file "import-rrule-count-monthly.ics") + (dit:import-file "import-rrule-count-every-second-month.ics") + (dit:import-file "import-rrule-count-yearly.ics") + (dit:import-file "import-rrule-count-every-second-year.ics")) + +(ert-deftest dit:import-duration () + (dit:import-file "import-duration.ics") + ;; duration-2: this is actually an rrule test + (dit:import-file "import-duration-2.ics")) + +(ert-deftest dit:import-multiple-vcalendars () + (dit:import-file "import-multiple-vcalendars.ics")) + +(ert-deftest dit:import-with-uid () + "Perform import test with uid." + (dit:import-file "import-with-uid.ics")) + +(ert-deftest dit:import-with-attachment () + "Test importing an attached file to `icalendar-attachment-directory'" + (ert-with-temp-directory temp-dir + (let ((di:attachment-directory temp-dir) + (uid-dir (file-name-concat temp-dir + ;; Event's UID: + "f9fee9a0-1231-4984-9078-f1357db352db"))) + (dit:import-file "import-with-attachment.ics") + (should (file-directory-p uid-dir)) + (let ((files (directory-files uid-dir t + ;; First 4 chars of base64-string: + "R3Jl"))) + (should (length= files 1)) + (with-temp-buffer + (insert-file-contents (car files)) + (should (equal "Greetings! I am a base64-encoded file" + (buffer-string)))))))) + +(ert-deftest dit:import-with-timezone () + (dit:import-file "import-with-timezone.ics")) + +(ert-deftest dit:import-real-world () + "Import tests of other real world data" + ;; N.B. Not all data from these files is expected to be imported + ;; without any pre-parsing cleanup, since they are in some cases + ;; malformed. The test data matches what the importer should produce + ;; in its default configuration. + (dit:with-tz "Asia/Kolkata" + ;; Indian Standard Time, used in this file, does not adjust for + ;; daylight savings; so we use that time zone to keep this test + ;; from failing on systems in a time zone that does: + (dit:import-file "import-real-world-2003-05-29.ics")) + (dit:with-tz "Asia/Tehran" + ;; For the same reason, we use "Asia/Tehran" here: + (dit:import-file "import-real-world-no-dst.ics")) + (dit:import-file "import-real-world-2003-06-18a.ics") + ;; FIXME: this test seems to be failing due to an invisible unicode + ;; error of some sort. The import result and the expected output are + ;; visually identical and ediff shows no differences in the buffers, + ;; but the strings are apparently not `equal', and comparing them + ;; character-by-character shows that they somehow differ at the "ĂŒ" in + ;; "frĂŒher". But `describe-char' there shows no differences so far as + ;; I can see. + ;(dit:import-file "import-real-world-2003-06-18b.ics") + (dit:import-file "import-real-world-2004-11-19.ics") + (dit:import-file "import-real-world-2005-02-07.ics") + (dit:import-file "import-real-world-2005-03-01.ics")) + +(ert-deftest dit:import-bug-6766 () + ;;bug#6766 -- multiple byday values in a weekly rrule + (dit:import-file "import-bug-6766.ics")) + +(ert-deftest dit:import-bug-11473 () + ;; bug#11473 -- illegal tzid + (dit:import-file "import-bug-11473.ics")) + +(ert-deftest dit:import-bug-22092 () + ;; bug#22092 -- mixed line endings + (let ((ical:pre-unfolding-hook '(ical:fix-line-endings))) + (dit:import-file "import-bug-22092.ics"))) + +(ert-deftest dit:import-bug-24199 () + ;;bug#24199 -- monthly rule with byday-clause + (dit:import-file "import-bug-24199.ics")) + +(ert-deftest dit:import-bug-33277 () + ;;bug#33277 -- start time equals end time + (dit:import-file "import-bug-33277.ics")) + + + + +;; Tests for diary export functions +(cl-defmacro dit:parse-test (entry &key parser type number + bindings tests + source) + "Create a test which parses data from ENTRY. + +PARSER should be a zero-argument function which parses data of TYPE in a +buffer containing ENTRY. The defined test passes if PARSER returns a +list of NUMBER objects which satisfy TYPE. If NUMBER is nil, the return +value of parser must be a single value satisfying TYPE. + +BINDINGS, if given, will be evaluated and made available in the lexical +environment where PARSER is called; this can be used to temporarily set +variables that affect parsing. + +TESTS, if given, is an additional test form that will be evaluated after +the main tests. The variable `parsed' will be bound to the return value +of PARSER when TESTS are evaluated. + +SOURCE, if given, should be a symbol; it is used to name the test." + (let ((parser-form `(funcall (function ,parser)))) + `(ert-deftest + ,(intern (concat "diary-icalendar-test-" + (string-replace "diary-icalendar-" "" + (symbol-name parser)) + (if source (concat "/" (symbol-name source)) ""))) + () + ,(format "Does `%s' correctly parse `%s' in diary entries?" parser type) + (let* ((parse-buf (get-buffer-create "*iCalendar Parse Test*")) + (unparsed ,entry)) + (set-buffer parse-buf) + (erase-buffer) + (insert unparsed) + (goto-char (point-min)) + (let* (,@bindings + (parsed ,parser-form)) + (when ,number + (should (length= parsed ,number)) + (should (seq-every-p (lambda (val) (cl-typep val ,type)) + parsed))) + (unless ,number + (should (cl-typep parsed ,type))) + ,tests))))) + +(dit:parse-test + "2025-04-01 A basic entry + Other data" +:parser di:parse-entry-type +:type 'symbol +:source vevent +:tests (should (eq parsed 'ical:vevent))) + +(dit:parse-test + "&2025-04-01 A nonmarking journal entry + Other data" +:parser di:parse-entry-type +:bindings ((di:export-nonmarking-as-vjournal t)) +:type 'symbol +:source vjournal +:tests (should (eq parsed 'ical:vjournal))) + +(dit:parse-test + "2025-04-01 Due: some task + Other data" +:parser di:parse-entry-type +:bindings ((di:todo-regexp "Due: ")) +:type 'symbol +:source vtodo +:tests (should (eq parsed 'ical:vtodo))) + +(defun dit:parse-vevent-transparency () + "Call `di:parse-transparency' with \\='icalendar-vevent" + (di:parse-transparency 'ical:vevent)) + +(dit:parse-test + "&%%(diary-anniversary 7 28 1985) A transparent anniversary" + :parser dit:parse-vevent-transparency + :type 'ical:transp + :number 1 + :source nonmarking + :tests + (ical:with-property (car parsed) nil + (should (equal value "TRANSPARENT")))) + +(dit:parse-test + "2025-04-01 Team Meeting + Some data + Organizer: Mr. Foo + Attendees: Baz Bar + Alice Unternehmer (some other data) + Other data" +:parser di:parse-attendees-and-organizer +:number 3 +:type '(or ical:attendee ical:organizer) +:tests +(dolist (p parsed) + (ical:with-property p + ((ical:cnparam :value name)) + (cond ((equal value "mailto:foo@example.com") + (should (equal name "Mr. Foo")) + (should (ical:organizer-property-p p))) + ((equal value "mailto:baz@example.com") + (should (equal name "Baz Bar")) + (should (ical:attendee-property-p p))) + ((equal value "mailto:alice@example.com") + (should (equal name "Alice Unternehmer")) + (should (ical:attendee-property-p p))) + (t (error "Incorrectly parsed attendee address: %s" value)))))) + +(dit:parse-test + "2025-04-01 An event with a UID + Some data + UID: emacs174560213714413195191 + Other data" +:parser di:parse-uid +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:uid +:tests +(ical:with-property (car parsed) nil + (should (equal "emacs174560213714413195191" value)))) + +(dit:parse-test + "2025-04-01 An event with a different style of UID + Some data + UID: 197846d7-51be-4d8e-837f-7e132286e7cf + Other data" +:parser di:parse-uid +:source with-org-id-uuid +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:uid +:tests +(ical:with-property (car parsed) nil + (should (equal "197846d7-51be-4d8e-837f-7e132286e7cf" value)))) + +(dit:parse-test + "2025-04-01 An event with a status + Some data + Status: confirmed + Other data" +:parser di:parse-status +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:status +:tests +(ical:with-property (car parsed) nil + (should (equal "CONFIRMED" value)))) + +(dit:parse-test + "2025-04-01 An event with an access classification + Some data + Class: private + Other data" +:parser di:parse-class +:source private +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:class +:tests +(ical:with-property (car parsed) nil + (should (equal "PRIVATE" value)))) + +(dit:parse-test + "2025-04-01 An event with an access classification + Some data + Access: public + Other data" +:parser di:parse-class +:source public +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:class +:tests +(ical:with-property (car parsed) nil + (should (equal "PUBLIC" value)))) + +(dit:parse-test + "2025-04-01 An event with a location + Some data + Location: Sesamstraße 13 + Other data" +:parser di:parse-location +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:location +:tests +(ical:with-property (car parsed) nil + (should (equal "Sesamstraße 13" value)))) + +(dit:parse-test + "2025-04-01 An event with an URL + Some data + URL: http://example.com/foo/bar?q=baz + Other data" +:parser di:parse-url +:bindings ((diary-date-forms diary-iso-date-forms)) +:type 'ical:url +:tests +(ical:with-property (car parsed) nil + (should (equal "http://example.com/foo/bar?q=baz" value)))) + + +;; N.B. There is no date at the start of the entry in the following two +;; tests because di:parse-summary-and-description assumes that the date +;; parsing functions have already moved the start of the restriction +;; beyond it. +(dit:parse-test + "Event summary + Some data + Other data" +:parser di:parse-summary-and-description +:number 2 +:type '(or ical:summary ical:description) +:bindings ((diary-date-forms diary-iso-date-forms)) +:tests +(ical:with-property (car parsed) nil (should (equal "Event summary" value)))) + +(dit:parse-test + "Some data + Summary: Event summary + Other data" +:parser di:parse-summary-and-description +:number 2 +:bindings ((di:summary-regexp "^[[:space:]]+Summary: \\(.*\\)$")) +:type '(or ical:summary ical:description) +:bindings ((diary-date-forms diary-iso-date-forms)) +:source with-summary-regexp +:tests +(ical:with-property (car parsed) nil (should (equal "Event summary" value)))) + +(dit:parse-test + "2025/04/01 Some entry" + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-iso-date-forms)) + :source iso-date + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "2025-04-01 Some entry" + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-iso-date-forms)) + :source iso-date-dashes + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "1/4/2025 Some entry" + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-european-date-forms)) + :source european-date + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "4/1/2025 Some entry" + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-american-date-forms)) + :source american-date + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "4/1 April Fool's" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source generic-year-american + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "1/5 Tag der Arbeit" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-european-date-forms)) + :source generic-year-european + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 5 (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "1/*/2025 Rent due" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-european-date-forms)) + :source generic-month + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (eq t (calendar-extract-month parsed))) + (should (= 1 (calendar-extract-day parsed))))) + +(dit:parse-test + "*/2/2025 Every day in February: go running" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-european-date-forms)) + :source generic-day + :tests + (progn + (should (= 2025 (calendar-extract-year parsed))) + (should (= 2 (calendar-extract-month parsed))) + (should (eq t (calendar-extract-day parsed))))) + +(dit:parse-test + "Friday + Lab meeting + Backup data" + :parser di:parse-weekday-name + :type 'integer + :tests + (should (= 5 parsed))) + +;;; Examples from the Emacs manual: +(dit:parse-test + "12/22/2015 Twentieth wedding anniversary!" + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/1 + :tests + (progn + (should (= 2015 (calendar-extract-year parsed))) + (should (= 12 (calendar-extract-month parsed))) + (should (= 22 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Generic date via unspecified year: + "10/22 Ruth's birthday." + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/2 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 10 (calendar-extract-month parsed))) + (should (= 22 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Generic date via unspecified year: + "4/30 Results for April are due" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.3/3 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 30 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Generic date with asterisks: + "* 21, *: Payday" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/3 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (eq t (calendar-extract-month parsed))) + (should (= 21 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Generic date with asterisks: + "*/25 Monthly cycle finishes" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.3/4 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (eq t (calendar-extract-month parsed))) + (should (= 25 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Weekday name: + "Tuesday--weekly meeting with grad students at 10am + Supowit, Shen, Bitner, and Kapoor to attend." + :parser di:parse-weekday-name + :type 'integer + :source emacs-manual-sec33.10.1/4 + :tests + (should (= 2 parsed))) + +(dit:parse-test + ;; Weekday name: + "Friday Don't leave without backing up files" + :parser di:parse-weekday-name + :type 'integer + :source emacs-manual-sec33.10.3/5 + :tests + (should (= 5 parsed))) + +(dit:parse-test + ;; Date with two-digit year: + "1/13/89 Friday the thirteenth!!" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/5 + :tests + (progn + (should (= 1989 (calendar-extract-year parsed))) + (should (= 1 (calendar-extract-month parsed))) + (should (= 13 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Date with two-digit year: + "4/20/12 Switch-over to new tabulation system" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.3/1 + :tests + (progn + (should (= 2012 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 20 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Abbreviated weekday name: + "thu 4pm squash game with Lloyd." + :parser di:parse-weekday-name + :type 'integer + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/6 + :tests + (should (= 4 parsed))) + +(dit:parse-test + ;; Abbreviated month name: + "mar 16 Dad's birthday" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/7 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 3 (calendar-extract-month parsed))) + (should (= 16 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Abbreviated month name with following period: + "apr. 25 Start tabulating annual results" + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.3/2 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 25 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Long form date: + "April 15, 2016 Income tax due." + :parser di:parse-date-form + :type 'ical:date + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/8 + :tests + (progn + (should (= 2016 (calendar-extract-year parsed))) + (should (= 4 (calendar-extract-month parsed))) + (should (= 15 (calendar-extract-day parsed))))) + +(dit:parse-test + ;; Generic monthly date: + "* 15 time cards due." + :parser di:parse-date-form + :type 'list + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/9 + :tests + (progn + (should (eq t (calendar-extract-year parsed))) + (should (eq t (calendar-extract-month parsed))) + (should (= 15 (calendar-extract-day parsed))))) + +(dit:parse-test + "%%(diary-anniversary 5 28 1995) A birthday" + :parser di:parse-sexp + :type 'list + :tests (should (eq 'diary-anniversary (car parsed)))) + +(dit:parse-test + "%%(diary-time-block :start (0 0 13 2 4 2025 6 t 7200) + :end (0 0 11 4 4 2025 6 t 7200)) + A multiday event with different start and end times" + :parser di:parse-sexp + :type 'list + :source multiline-sexp + :tests (should (eq 'diary-time-block (car parsed)))) + +(defun dit:entry-parser () + "Call `di:parse-entry' on the full test buffer" + (let ((tz + (cond + ((eq 'local di:time-zone-export-strategy) + (di:current-tz-to-vtimezone)) + ((listp di:time-zone-export-strategy) + (di:current-tz-to-vtimezone di:time-zone-export-strategy))))) + + (di:parse-entry (point-min) (point-max) tz))) + +(dit:parse-test + ;; Weekly event, abbreviated weekday name: + "thu 4pm squash game with Lloyd." + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source emacs-manual-sec33.10.1/6 + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value rrule) + (ical:summary :value summary)) + (should (equal summary "squash game with Lloyd.")) + (should (equal (ical:date-time-to-date dtstart) + (calendar-nth-named-day 1 4 1 di:recurring-start-year))) + (should (= 16 (decoded-time-hour dtstart))) + (should (eq (ical:recur-freq rrule) 'WEEKLY)) + (should (equal (ical:recur-by* 'BYDAY rrule) (list 4))))) + +(dit:parse-test + ;; Multiline entry, parsed as one event: + "2025-05-03 + 9AM Lab meeting + Gunther to present on new assay + 12:30-1:30PM Lunch with Phil + 16:00 Experiment A finishes; move to freezer" + :parser dit:entry-parser + :source multiline-single + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-iso-date-forms))) + +(dit:parse-test + ;; Multiline entry, parsed linewise as three events: + "2025-05-03 + 9AM Lab meeting + Gunther to present on new assay + 12:30-1:30PM Lunch with Phil + 16:00 Experiment A finishes; move to freezer" + :parser dit:entry-parser + :source multiline-linewise + :type 'ical:vevent + :number 3 + :bindings ((diary-date-forms diary-iso-date-forms) + (diary-icalendar-export-linewise t)) + :tests + (progn + (dolist (event parsed) + (ical:with-component event + ((ical:dtstart :value-type start-type :value dtstart) + (ical:dtend :value-type end-type :value dtend) + (ical:summary :value summary)) + (should (eq start-type 'ical:date-time)) + (should (= 2025 (decoded-time-year dtstart))) + (should (= 5 (decoded-time-month dtstart))) + (should (= 3 (decoded-time-day dtstart))) + (when dtend + (should (eq end-type 'ical:date-time)) + (should (= 2025 (decoded-time-year dtend))) + (should (= 5 (decoded-time-month dtend))) + (should (= 3 (decoded-time-day dtend)))) + (cond ((equal summary "Lab meeting") + (should (= 9 (decoded-time-hour dtstart)))) + ((equal summary "Lunch with Phil") + (should (= 12 (decoded-time-hour dtstart))) + (should (= 30 (decoded-time-minute dtstart))) + (should (= 13 (decoded-time-hour dtend))) + (should (= 30 (decoded-time-minute dtend)))) + ((equal summary "Experiment A finishes; move to freezer") + (should (= 16 (decoded-time-hour dtstart)))) + (t (error "Unknown event: %s" summary))))))) + +(dit:parse-test + ;; Multiline entry from the manual, parsed linewise: + ;; TODO: I've left the times verbatim in the example + ;; and in the tests, even though "2:30", "5:30" and "8:00" + ;; would most naturally be understood as PM times. + ;; Should probably fix the manual, then revise here. + "02/11/2012 + Bill B. visits Princeton today + 2pm Cognitive Studies Committee meeting + 2:30-5:30 Liz at Lawrenceville + 4:00pm Dentist appt + 7:30pm Dinner at George's + 8:00-10:00pm concert" + :parser dit:entry-parser + :type 'ical:vevent + :number 6 + :bindings ((diary-date-forms diary-american-date-forms) + (diary-icalendar-export-linewise t)) + :source emacs-manual-sec33.10.1/10 + :tests + (progn + (dolist (event parsed) + (ical:with-component event + ((ical:dtstart :value-type start-type :value dtstart) + (ical:dtend :value-type end-type :value dtend) + (ical:summary :value summary)) + (when (eq start-type 'ical:date) + (should (= 2012 (calendar-extract-year dtstart))) + (should (= 2 (calendar-extract-month dtstart))) + (should (= 11 (calendar-extract-day dtstart)))) + (when (eq start-type 'ical:date-time) + (should (= 2012 (decoded-time-year dtstart))) + (should (= 2 (decoded-time-month dtstart))) + (should (= 11 (decoded-time-day dtstart)))) + (when dtend + (should (eq end-type 'ical:date-time)) + (should (= 2012 (decoded-time-year dtend))) + (should (= 2 (decoded-time-month dtend))) + (should (= 11 (decoded-time-day dtend)))) + (cond ((equal summary "Bill B. visits Princeton today") + (should (eq start-type 'ical:date))) + ((equal summary "Cognitive Studies Committee meeting") + (should (= 14 (decoded-time-hour dtstart))) + (should (= 0 (decoded-time-minute dtstart)))) + ((equal summary "Liz at Lawrenceville") + (should (= 2 (decoded-time-hour dtstart))) + (should (= 30 (decoded-time-minute dtstart))) + (should (= 5 (decoded-time-hour dtend))) + (should (= 30 (decoded-time-minute dtend)))) + ((equal summary "Dentist appt") + (should (= 16 (decoded-time-hour dtstart))) + (should (= 0 (decoded-time-minute dtstart)))) + ((equal summary "Dinner at George's") + (should (= 19 (decoded-time-hour dtstart))) + (should (= 30 (decoded-time-minute dtstart)))) + ((equal summary "concert") + (should (= 8 (decoded-time-hour dtstart))) + (should (= 0 (decoded-time-minute dtstart))) + (should (= 22 (decoded-time-hour dtend))) + (should (= 0 (decoded-time-minute dtend)))) + (t (error "Unknown event: %s" summary))))))) + +(dit:parse-test + ;; Same as the last, but with ignored data on the same line as the date + "02/11/2012 Ignored + 2pm Cognitive Studies Committee meeting + 2:30-5:30 Liz at Lawrenceville + 4:00pm Dentist appt + 7:30pm Dinner at George's + 8:00-10:00pm concert" + :parser dit:entry-parser + :type 'ical:vevent + :number 5 + :bindings ((diary-date-forms diary-american-date-forms) + (diary-icalendar-export-linewise t)) + :source emacs-manual-sec33.10.1/10-first-line) + +(dit:parse-test + "%%(diary-anniversary 5 28 1995) H's birthday" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms) + (calendar-date-style 'american)) + :source diary-anniversary-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart '(5 28 1995))) + (should (eq (ical:recur-freq recur-value) 'YEARLY)) + (should (equal summary "H's birthday")))) + +(dit:parse-test + "%%(diary-block 6 24 2012 7 10 2012) Vacation" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-block-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart '(6 24 2012))) + (should (equal (ical:recur-freq recur-value) 'DAILY)) + (should (equal (ical:recur-until recur-value) '(7 10 2012))) + (should (equal summary "Vacation")))) + +(dit:parse-test + "%%(diary-cyclic 50 3 1 2012) Renew medication" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-cyclic-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart '(3 1 2012))) + (should (eq (ical:recur-freq recur-value) 'DAILY)) + (should (eq (ical:recur-interval-size recur-value) 50)) + (should (equal summary "Renew medication")))) + +(dit:parse-test + "%%(diary-float 11 4 4) American Thanksgiving" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-float-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart + (calendar-nth-named-day 4 4 11 di:recurring-start-year))) + (should (eq (ical:recur-freq recur-value) 'MONTHLY)) + (should (equal (ical:recur-by* 'BYMONTH recur-value) (list 11))) + (should (equal (ical:recur-by* 'BYDAY recur-value) (list '(4 . 4)))) + (should (equal summary "American Thanksgiving")))) + +(dit:parse-test + "%%(diary-offset '(diary-float t 3 4) 2) Monthly committee meeting" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-offset-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart + (calendar-nth-named-day 4 5 1 di:recurring-start-year))) + (should (eq (ical:recur-freq recur-value) 'MONTHLY)) + ;; day 3 is Wednesday, so offset of 2 means Friday (=5): + (should (equal (ical:recur-by* 'BYDAY recur-value) (list '(5 . 4)))) + (should (equal summary "Monthly committee meeting")))) + +(dit:parse-test + "%%(diary-rrule :start '(11 11 2024) + :rule '((FREQ WEEKLY)) + :exclude '((12 23 2024) (12 30 2024)) + ) Reading group" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-rrule-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:exdate :values exdates) + (ical:summary :value summary)) + (should (equal dtstart '(11 11 2024))) + (should (eq (ical:recur-freq recur-value) 'WEEKLY)) + (should (equal exdates '((12 23 2024) (12 30 2024)))) + (should (equal summary "Reading group")))) + +(dit:parse-test + "%%(diary-date '(10 11 12) 22 t) Rake leaves" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms)) + :source diary-date-recurrence + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rrule :value recur-value) + (ical:summary :value summary)) + (should (equal dtstart (list 10 22 di:recurring-start-year))) + (should (eq (ical:recur-freq recur-value) 'YEARLY)) + (should (equal (ical:recur-by* 'BYMONTH recur-value) (list 10 11 12))) + (should (equal (ical:recur-by* 'BYMONTHDAY recur-value) (list 22))) + (should (equal summary "Rake leaves")))) + +(dit:parse-test + ;; From the manual: "Suppose you get paid on the 21st of the month if + ;; it is a weekday, and on the Friday before if the 21st is on a + ;; weekend..." + "%%(let ((dayname (calendar-day-of-week date)) + (day (cadr date))) + (or (and (= day 21) (memq dayname '(1 2 3 4 5))) + (and (memq day '(19 20)) (= dayname 5))) + ) Pay check deposited" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-date-forms diary-american-date-forms) + (di:export-sexp-enumeration-days 366)) + :source emacs-manual-sec33.13.10.7 + :tests + (ical:with-component (car parsed) + ((ical:dtstart :value dtstart) + (ical:rdate :values rdates) + (ical:summary :value summary)) + (should (equal summary "Pay check deposited")) + (mapc + (lambda (date) + (should (or (and (= 21 (calendar-extract-day date)) + (memq (calendar-day-of-week date) (list 1 2 3 4 5))) + (and (memq (calendar-extract-day date) (list 19 20)) + (= 5 (calendar-day-of-week date)))))) + (cons dtstart rdates)))) + +(dit:parse-test + "02/11/2012 4:00pm Exported with 'local strategy" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((tz (getenv "TZ")) + ;; Refresh output from `calendar-current-time-zone': + (calendar-current-time-zone-cache nil) + ;; Assume Eastern European Time (UTC+2, UTC+3 daylight saving) + (_ (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4")) + ;; ...and use this TZ when exporting: + (diary-icalendar-time-zone-export-strategy 'local) + (diary-date-forms diary-european-date-forms)) + :source tz-strategy-local + :tests + (unwind-protect + (let ((vtimezone (di:current-tz-to-vtimezone))) + (ical:with-component vtimezone + ((ical:standard :first std) + (ical:daylight :first dst)) + (should (= (* 2 60 60) (ical:with-property-of std 'ical:tzoffsetto))) + (should (= (* 3 60 60) (ical:with-property-of dst 'ical:tzoffsetto)))) + (ical:with-component (car parsed) + ((ical:dtstart :first start-node :value start)) + (should (= (* 2 60 60) (decoded-time-zone start))) + (should (= 16 (decoded-time-hour start))) + (should (ical:with-param-of start-node 'ical:tzidparam)))) + ;; restore time zone + (setenv "TZ" tz))) + +(dit:parse-test + "02/11/2012 4:00pm Exported with 'to-utc strategy" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((tz (getenv "TZ")) + ;; Assume Eastern European Time (UTC+2, UTC+3 daylight saving) + (_ (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4")) + ;; ...and convert times to UTC on export: + (diary-icalendar-time-zone-export-strategy 'to-utc) + (diary-date-forms diary-european-date-forms)) + :source tz-strategy-to-utc + :tests + (unwind-protect + (ical:with-component (car parsed) + ((ical:dtstart :first start-node :value start)) + (should (= 0 (decoded-time-zone start))) + (should (= (- 16 2) (decoded-time-hour start))) + (should-not (ical:with-param-of start-node 'ical:tzidparam))) + ;; restore time zone + (setenv "TZ" tz))) + +(dit:parse-test + "02/11/2012 4:00pm Exported with 'floating strategy" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((tz (getenv "TZ")) + ;; Assume Eastern European Time (UTC+2, UTC+3 daylight saving) + (_ (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4")) + ;; ...but use floating times: + (diary-icalendar-time-zone-export-strategy 'floating) + (diary-date-forms diary-european-date-forms)) + :source tz-strategy-floating + :tests + (unwind-protect + (ical:with-component (car parsed) + ((ical:dtstart :first start-node :value start)) + (should (null (decoded-time-zone start))) + (should (= 16 (decoded-time-hour start))) + (should-not (ical:with-param-of start-node 'ical:tzidparam))) + + ;; restore time zone + (setenv "TZ" tz))) + +(dit:parse-test + "02/11/2012 4:00pm Exported with tz info list" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings (;; Encode Eastern European Time (UTC+2, UTC+3 daylight saving) + ;; directly in the variable: + (diary-icalendar-time-zone-export-strategy + '(120 60 "EET" "EEST" + (calendar-nth-named-day -1 0 3 year) ; last Sunday of March + (calendar-nth-named-day -1 0 10 year) ; last Sunday of October + 240 180)) + (diary-date-forms diary-european-date-forms)) + :source tz-strategy-sexp + :tests + (let ((vtimezone (di:current-tz-to-vtimezone + diary-icalendar-time-zone-export-strategy + "EET"))) + (ical:with-component vtimezone + ((ical:standard :first std) + (ical:daylight :first dst)) + (should (= (* 2 60 60) (ical:with-property-of std 'ical:tzoffsetto))) + (should (= (* 3 60 60) (ical:with-property-of dst 'ical:tzoffsetto)))) + (ical:with-component (car parsed) + ((ical:dtstart :first start-node :value start)) + (should (= 7200 (decoded-time-zone start))) + (should (= 16 (decoded-time-hour start))) + (should (ical:with-param-of start-node 'ical:tzidparam))))) + +(defun dit:parse-@-location () + "Example user function for parsing additional properties. +Parses anything following \"@\" to end of line as the entry's LOCATION." + (goto-char (point-min)) + (when (re-search-forward "@\\([^\n]+\\)" nil t) + (list (ical:make-property ical:location + (string-trim (match-string 1)))))) + +(dit:parse-test + "2025/08/02 BBQ @ John's" + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-icalendar-other-properties-parser #'dit:parse-@-location) + (diary-date-forms diary-iso-date-forms)) + :source other-properties-parser + :tests + (ical:with-component (car parsed) + ((ical:location :value location)) + (should (equal location "John's")))) + +(dit:parse-test + "2025/05/15 11AM Department meeting + Attendee: " + :parser dit:entry-parser + :type 'ical:vevent + :number 1 + :bindings ((diary-icalendar-export-alarms + '((audio 10) + (display 20 "In %t minutes: %s") + (email 60 "In %t minutes: %s" ("myemail@example.com" from-entry)))) + (diary-date-forms diary-iso-date-forms)) + :source alarms-export + :tests + (ical:with-component (car parsed) + ((ical:valarm :all valarms)) + (should (length= valarms 3)) + (dolist (valarm valarms) + (ical:with-component valarm + ((ical:action :value action) + (ical:trigger :value trigger) + (ical:summary :value summary) + (ical:attendee :all attendee-nodes)) + (cond ((equal action "AUDIO") + (should (eql -10 (decoded-time-minute trigger)))) + ((equal action "DISPLAY") + (should (eql -20 (decoded-time-minute trigger))) + (should (equal summary "In 20 minutes: Department meeting"))) + ((equal action "EMAIL") + (should (eql -60 (decoded-time-minute trigger))) + (should (equal summary "In 60 minutes: Department meeting")) + (should (length= attendee-nodes 2)) + (let ((addrs (mapcar (lambda (n) (ical:with-node-value n)) + attendee-nodes))) + (should (member "mailto:myemail@example.com" addrs)) + (should (member "mailto:mydept@example.com" addrs)))) + (t (error "Unknown alarm action %s" action))))))) + + + +;; Local Variables: +;; read-symbol-shorthands: (("dit:" . "diary-icalendar-test-") ("di:" . "diary-icalendar-") ("ical:" . "icalendar-")) +;; byte-compile-warnings: (not obsolete) +;; End: +;;; diary-icalendar-tests.el ends here diff --git a/test/lisp/calendar/icalendar-parser-tests.el b/test/lisp/calendar/icalendar-parser-tests.el new file mode 100644 index 00000000000..f3c5de35c87 --- /dev/null +++ b/test/lisp/calendar/icalendar-parser-tests.el @@ -0,0 +1,2032 @@ +;;; tests/icalendar-parser.el --- Tests for icalendar-parser -*- lexical-binding: t; -*- +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'icalendar-macs)) +(require 'ert) +(require 'ert-x) +(require 'icalendar-parser) +(require 'icalendar-utils) + +(cl-defmacro ipt:parse/print-test (string &key expected parser type printer source) + "Create a test which parses STRING, prints the resulting parse +tree, and compares the printed version with STRING (or with +EXPECTED, if given). If they are the same, the test passes. +PARSER and PRINTER should be the parser and printer functions +appropriate to STRING. TYPE, if given, should be the type of +object PARSER is expected to parse; it will be passed as PARSER's +first argument. SOURCE should be a symbol; it is used to name the +test." + (let ((parser-form + (if type + `(funcall (function ,parser) (quote ,type) (point-max)) + `(funcall (function ,parser) (point-max))))) + `(ert-deftest ,(intern (concat "ipt:parse/print-" (symbol-name source))) () + ,(format "Parse and reprint example from `%s'; pass if they match" source) + (let* ((parse-buf (get-buffer-create "*iCalendar Parse Test*")) + (print-buf (get-buffer-create "*iCalendar Print Test*")) + (unparsed ,string) + (expected (or ,expected unparsed)) + (printed nil)) + (set-buffer parse-buf) + (erase-buffer) + (insert unparsed) + (goto-char (point-min)) + (let ((parsed ,parser-form)) + (should (icalendar-ast-node-valid-p parsed)) + (set-buffer print-buf) + (erase-buffer) + (insert (funcall (function ,printer) parsed)) + ;; this may need adjusting if printers become coding-system aware: + (decode-coding-region (point-min) (point-max) 'utf-8-dos) + (setq printed (buffer-substring-no-properties (point-min) (point-max))) + (should (equal expected printed))))))) + +(ipt:parse/print-test +"ATTENDEE;RSVP=TRUE;ROLE=REQ-PARTICIPANT:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.1.1/1) + +(ipt:parse/print-test +"RDATE;VALUE=DATE:19970304,19970504,19970704,19970904\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.1.1/2) + +(ipt:parse/print-test +"ATTACH:http://example.com/public/quarterly-report.doc\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.1.3/1) + +(ipt:parse/print-test +;; Corrected. The original contains invalid base64 data; it was +;; missing the final "=", as noted in errata ID 5602. +;; The decoded string should read: +;; The quick brown fox jumps over the lazy dog. +"ATTACH;FMTTYPE=text/plain;ENCODING=BASE64;VALUE=BINARY:VGhlIHF1aWNrIGJyb3duIGZveCBqdW1wcyBvdmVyIHRoZSBsYXp5IGRvZy4=\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.1.3/2) + +(ipt:parse/print-test +"DESCRIPTION;ALTREP=\"cid:part1.0001@example.org\":The Fall'98 Wild Wizards Conference - - Las Vegas\\, NV\\, USA\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2/1) + +(ipt:parse/print-test +"DESCRIPTION;ALTREP=\"CID:part3.msg.970415T083000@example.com\": Project XYZ Review Meeting will include the following agenda items: (a) Market Overview\\, (b) Finances\\, (c) Project Management\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.1/1) + +(ipt:parse/print-test +"ORGANIZER;CN=\"John Smith\":mailto:jsmith@example.com\n" +;; CN param value does not require quotes, so they're missing when +;; re-printed: +:expected "ORGANIZER;CN=John Smith:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.2/1) + +(ipt:parse/print-test +"ATTENDEE;CUTYPE=GROUP:mailto:ietf-calsch@example.org\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.3/1) + +(ipt:parse/print-test +"ATTENDEE;DELEGATED-FROM=\"mailto:jsmith@example.com\":mailto:jdoe@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.4/1) + +(ipt:parse/print-test +"ATTENDEE;DELEGATED-TO=\"mailto:jdoe@example.com\",\"mailto:jqpublic@example.com\":mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.5/1) + +(ipt:parse/print-test +"ORGANIZER;DIR=\"ldap://example.com:6666/o=ABC%20Industries,c=US???(cn=Jim%20Dolittle)\":mailto:jimdo@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.6/1) + +(ipt:parse/print-test +"ATTACH;FMTTYPE=text/plain;ENCODING=BASE64;VALUE=BINARY:TG9yZW0gaXBzdW0gZG9sb3Igc2l0IGFtZXQsIGNvbnNlY3RldHVyIGFkaXBpc2ljaW5nIGVsaXQsIHNlZCBkbyBlaXVzbW9kIHRlbXBvciBpbmNpZGlkdW50IHV0IGxhYm9yZSBldCBkb2xvcmUgbWFnbmEgYWxpcXVhLiBVdCBlbmltIGFkIG1pbmltIHZlbmlhbSwgcXVpcyBub3N0cnVkIGV4ZXJjaXRhdGlvbiB1bGxhbWNvIGxhYm9yaXMgbmlzaSB1dCBhbGlxdWlwIGV4IGVhIGNvbW1vZG8gY29uc2VxdWF0LiBEdWlzIGF1dGUgaXJ1cmUgZG9sb3IgaW4gcmVwcmVoZW5kZXJpdCBpbiB2b2x1cHRhdGUgdmVsaXQgZXNzZSBjaWxsdW0gZG9sb3JlIGV1IGZ1Z2lhdCBudWxsYSBwYXJpYXR1ci4gRXhjZXB0ZXVyIHNpbnQgb2NjYWVjYXQgY3VwaWRhdGF0IG5vbiBwcm9pZGVudCwgc3VudCBpbiBjdWxwYSBxdWkgb2ZmaWNpYSBkZXNlcnVudCBtb2xsaXQgYW5pbSBpZCBlc3QgbGFib3J1bS4=\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.7/1) + +(ipt:parse/print-test +"ATTACH;FMTTYPE=application/msword:ftp://example.com/pub/docs/agenda.doc\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.8/1) + +(ipt:parse/print-test +"FREEBUSY;FBTYPE=BUSY:19980415T133000Z/19980415T170000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.9/1) + +(ipt:parse/print-test +"SUMMARY;LANGUAGE=en-US:Company Holiday Party\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.10/1) + +(ipt:parse/print-test +"LOCATION;LANGUAGE=en:Germany\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.10/2) + +(ipt:parse/print-test +"LOCATION;LANGUAGE=no:Tyskland\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.10/3) + +(ipt:parse/print-test +"ATTENDEE;MEMBER=\"mailto:ietf-calsch@example.org\":mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.11/1) + +(ipt:parse/print-test +"ATTENDEE;MEMBER=\"mailto:projectA@example.com\",\"mailto:projectB@example.com\":mailto:janedoe@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.11/2) + +(ipt:parse/print-test +"ATTENDEE;PARTSTAT=DECLINED:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.12/1) + +(ipt:parse/print-test +"RECURRENCE-ID;RANGE=THISANDFUTURE:19980401T133000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.13/1) + +(ipt:parse/print-test +"TRIGGER;RELATED=END:PT5M\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.14/1) + +(ipt:parse/print-test +"RELATED-TO;RELTYPE=SIBLING:19960401-080045-4000F192713@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.15/1) + +(ipt:parse/print-test +"ATTENDEE;ROLE=CHAIR:mailto:mrbig@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.16/1) + +(ipt:parse/print-test +"ATTENDEE;RSVP=TRUE:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.17/1) + +(ipt:parse/print-test +"ORGANIZER;SENT-BY=\"mailto:sray@example.com\":mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.18/1) + +(ipt:parse/print-test +"DTSTART;TZID=America/New_York:19980119T020000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.19/1) + +(ipt:parse/print-test +"DTEND;TZID=America/New_York:19980119T030000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.2.19/2) + +(ipt:parse/print-test +"ATTACH;FMTTYPE=image/vnd.microsoft.icon;ENCODING=BASE64;VALUE=BINARY:AAABAAEAEBAQAAEABAAoAQAAFgAAACgAAAAQAAAAIAAAAAEABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACAAAAAgIAAAICAgADAwMAA////AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMwAAAAAAABNEMQAAAAAAAkQgAAAAAAJEREQgAAACECQ0QgEgAAQxQzM0E0AABERCRCREQAADRDJEJEQwAAAhA0QwEQAAAAAEREAAAAAAAAREQAAAAAAAAkQgAAAAAAAAMgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.3.1/1) + +(ipt:parse/print-test +"TRUE" +:type icalendar-boolean +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.2/1) + +(ipt:parse/print-test +"mailto:jane_doe@example.com" +:type icalendar-cal-address +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.3/1) + +(ipt:parse/print-test +"19970714" +:type icalendar-date +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.4/1) + +(ipt:parse/print-test +;; 'Floating' time: +"19980118T230000" +:type icalendar-date-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.5/1) + +(ipt:parse/print-test +;; UTC time: +"19980119T070000Z" +:type icalendar-date-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.5/2) + +(ipt:parse/print-test +;; Leap second (seconds = 60) +"19970630T235960Z" +:type icalendar-date-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.5/3) + +(ipt:parse/print-test +;; Local time: +"DTSTART:19970714T133000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.3.5/4) + +(ipt:parse/print-test +;; UTC time: +"DTSTART:19970714T173000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.3.5/5) + +(ipt:parse/print-test +;; Local time with TZ identifier: +"DTSTART;TZID=America/New_York:19970714T133000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.3.5/6) + +(ipt:parse/print-test +"P15DT5H0M20S" +:expected "P15DT5H20S" +:type icalendar-dur-value +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.6/1) + +(ipt:parse/print-test +"P7W" +:type icalendar-dur-value +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.6/2) + +(ipt:parse/print-test +"1000000.0000001" +:type icalendar-float +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.7/1) + +(ipt:parse/print-test +"1.333" +:type icalendar-float +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.7/2) + +(ipt:parse/print-test +"-3.14" +:type icalendar-float +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.7/3) + +(ipt:parse/print-test +"1234567890" +:type icalendar-integer +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.8/1) + +(ipt:parse/print-test +"-1234567890" +:type icalendar-integer +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.8/2) + +(ipt:parse/print-test +"+1234567890" +;; "+" sign isn't required, so it's not re-printed: +:expected "1234567890" +:type icalendar-integer +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.8/3) + +(ipt:parse/print-test +"432109876" +:type icalendar-integer +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.8/4) + +(ipt:parse/print-test +"19970101T180000Z/19970102T070000Z" +:type icalendar-period +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.9/1) + +(ipt:parse/print-test +"19970101T180000Z/PT5H30M" +:type icalendar-period +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.9/2) + +(ipt:parse/print-test +"FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-1" +:type icalendar-recur +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.10/1) + +(ipt:parse/print-test +"FREQ=YEARLY;INTERVAL=2;BYMONTH=1;BYDAY=SU;BYHOUR=8,9;BYMINUTE=30" +:type icalendar-recur +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.10/2) + +(ipt:parse/print-test +"FREQ=DAILY;COUNT=10;INTERVAL=2" +:type icalendar-recur +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.10/3) + +(ipt:parse/print-test +"Project XYZ Final Review\\nConference Room - 3B\\nCome Prepared." +:type icalendar-text +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.11/1) + +(ipt:parse/print-test +;; Local time: +"230000" +:type icalendar-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.12/1) + +(ipt:parse/print-test +;; UTC time: +"070000Z" +:type icalendar-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.12/2) + +(ipt:parse/print-test +;; Local time: +"083000" +:type icalendar-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.12/3) + +(ipt:parse/print-test +;; UTC time: +"133000Z" +:type icalendar-time +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.12/4) + +(ipt:parse/print-test +;; Local time with TZ identifier: +"SOMETIMEPROP;TZID=America/New_York;VALUE=TIME:083000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.3.12/5) + +(ipt:parse/print-test +"http://example.com/my-report.txt" +:type icalendar-uri +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.13/1) + +(ipt:parse/print-test +"-0500" +:type icalendar-utc-offset +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc5545-sec3.3.14/1) + +(ipt:parse/print-test +"+0100" +:type icalendar-utc-offset +:parser icalendar-parse-value-node +:printer icalendar-print-value-node +:source rfc55453.3.14/1) + +(ipt:parse/print-test +"BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//hacksw/handcal//NONSGML v1.0//EN +BEGIN:VEVENT +UID:19970610T172345Z-AF23B2@example.com +DTSTAMP:19970610T172345Z +DTSTART:19970714T170000Z +DTEND:19970715T040000Z +SUMMARY:Bastille Day Party +END:VEVENT +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec3.4/1) + +(ipt:parse/print-test +"DTSTART:19960415T133000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.5/1) + +(ipt:parse/print-test +"BEGIN:VEVENT +UID:19970901T130000Z-123401@example.com +DTSTAMP:19970901T130000Z +DTSTART:19970903T163000Z +DTEND:19970903T190000Z +SUMMARY:Annual Employee Review +CLASS:PRIVATE +CATEGORIES:BUSINESS,HUMAN RESOURCES +END:VEVENT +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.1/1) + +(ipt:parse/print-test +"BEGIN:VEVENT +UID:19970901T130000Z-123402@example.com +DTSTAMP:19970901T130000Z +DTSTART:19970401T163000Z +DTEND:19970402T010000Z +SUMMARY:Laurel is in sensitivity awareness class. +CLASS:PUBLIC +CATEGORIES:BUSINESS,HUMAN RESOURCES +TRANSP:TRANSPARENT +END:VEVENT +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.1/2) + +(ipt:parse/print-test +"BEGIN:VEVENT +UID:19970901T130000Z-123403@example.com +DTSTAMP:19970901T130000Z +DTSTART;VALUE=DATE:19971102 +SUMMARY:Our Blissful Anniversary +TRANSP:TRANSPARENT +CLASS:CONFIDENTIAL +CATEGORIES:ANNIVERSARY,PERSONAL,SPECIAL OCCASION +RRULE:FREQ=YEARLY +END:VEVENT +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.1/3) + +(ipt:parse/print-test +"BEGIN:VEVENT +UID:20070423T123432Z-541111@example.com +DTSTAMP:20070423T123432Z +DTSTART;VALUE=DATE:20070628 +DTEND;VALUE=DATE:20070709 +SUMMARY:Festival International de Jazz de Montreal +TRANSP:TRANSPARENT +END:VEVENT +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.1/4) + +(ipt:parse/print-test +"BEGIN:VTODO +UID:20070313T123432Z-456553@example.com +DTSTAMP:20070313T123432Z +DUE;VALUE=DATE:20070501 +SUMMARY:Submit Quebec Income Tax Return for 2006 +CLASS:CONFIDENTIAL +CATEGORIES:FAMILY,FINANCE +STATUS:NEEDS-ACTION +END:VTODO +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.2/1) + +(ipt:parse/print-test +"BEGIN:VTODO +UID:20070514T103211Z-123404@example.com +DTSTAMP:20070514T103211Z +DTSTART:20070514T110000Z +DUE:20070709T130000Z +COMPLETED:20070707T100000Z +SUMMARY:Submit Revised Internet-Draft +PRIORITY:1 +STATUS:NEEDS-ACTION +END:VTODO +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.2/2) + +(ipt:parse/print-test +"BEGIN:VJOURNAL +UID:19970901T130000Z-123405@example.com +DTSTAMP:19970901T130000Z +DTSTART;VALUE=DATE:19970317 +SUMMARY:Staff meeting minutes +DESCRIPTION:1. Staff meeting: Participants include Joe\\,Lisa\\, and Bob. Aurora project plans were reviewed. There is currently no budget reserves for this project. Lisa will escalate to management. Next meeting on Tuesday.\\n 2. Telephone Conference: ABC Corp. sales representative called to discuss new printer. Promised to get us a demo by Friday.\\n3. Henry Miller (Handsoff Insurance): Car was totaled by tree. Is looking into a loaner car. 555-2323 (tel). +END:VJOURNAL +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.3/1) + +(ipt:parse/print-test +"BEGIN:VFREEBUSY +UID:19970901T082949Z-FA43EF@example.com +ORGANIZER:mailto:jane_doe@example.com +ATTENDEE:mailto:john_public@example.com +DTSTART:19971015T050000Z +DTEND:19971016T050000Z +DTSTAMP:19970901T083000Z +END:VFREEBUSY +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.4/1) + +(ipt:parse/print-test +"BEGIN:VFREEBUSY +UID:19970901T095957Z-76A912@example.com +ORGANIZER:mailto:jane_doe@example.com +ATTENDEE:mailto:john_public@example.com +DTSTAMP:19970901T100000Z +FREEBUSY:19971015T050000Z/PT8H30M,19971015T160000Z/PT5H30M,19971015T223000Z/PT6H30M +URL:http://example.com/pub/busy/jpublic-01.ifb +COMMENT:This iCalendar file contains busy time information for the next three months. +END:VFREEBUSY +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.4/2) + +(ipt:parse/print-test +;; Corrected. Original has invalid value in ORGANIZER +"BEGIN:VFREEBUSY +UID:19970901T115957Z-76A912@example.com +DTSTAMP:19970901T120000Z +ORGANIZER:mailto:jsmith@example.com +DTSTART:19980313T141711Z +DTEND:19980410T141711Z +FREEBUSY:19980314T233000Z/19980315T003000Z +FREEBUSY:19980316T153000Z/19980316T163000Z +FREEBUSY:19980318T030000Z/19980318T040000Z +URL:http://www.example.com/calendar/busytime/jsmith.ifb +END:VFREEBUSY +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.4/3) + +(ipt:parse/print-test +"BEGIN:VTIMEZONE +TZID:America/New_York +LAST-MODIFIED:20050809T050000Z +BEGIN:DAYLIGHT +DTSTART:19670430T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=-1SU;UNTIL=19730429T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU;UNTIL=20061029T060000Z +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19740106T020000 +RDATE:19750223T020000 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:19760425T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=-1SU;UNTIL=19860427T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=1SU;UNTIL=20060402T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:20070311T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=2SU +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20071104T020000 +RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +END:VTIMEZONE +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.5/1) + +(ipt:parse/print-test +"BEGIN:VTIMEZONE +TZID:America/New_York +LAST-MODIFIED:20050809T050000Z +BEGIN:STANDARD +DTSTART:20071104T020000 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20070311T020000 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.5/2) + +(ipt:parse/print-test +"BEGIN:VTIMEZONE +TZID:America/New_York +LAST-MODIFIED:20050809T050000Z +TZURL:http://zones.example.com/tz/America-New_York.ics +BEGIN:STANDARD +DTSTART:20071104T020000 +RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20070311T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=2SU +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.5/3) + +(ipt:parse/print-test +"BEGIN:VTIMEZONE +TZID:Fictitious +LAST-MODIFIED:19870101T000000Z +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4;UNTIL=19980404T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.5/4) + +(ipt:parse/print-test +"BEGIN:VTIMEZONE +TZID:Fictitious +LAST-MODIFIED:19870101T000000Z +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4;UNTIL=19980404T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:19990424T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=4 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.5/5) + +(ipt:parse/print-test +"BEGIN:VALARM +TRIGGER;VALUE=DATE-TIME:19970317T133000Z +REPEAT:4 +DURATION:PT15M +ACTION:AUDIO +ATTACH;FMTTYPE=audio/basic:ftp://example.com/pub/sounds/bell-01.aud +END:VALARM +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.6/1) + +(ipt:parse/print-test +"BEGIN:VALARM +TRIGGER:-PT30M +REPEAT:2 +DURATION:PT15M +ACTION:DISPLAY +DESCRIPTION:Breakfast meeting with executive\\nteam at 8:30 AM EST. +END:VALARM +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.6/2) + +(ipt:parse/print-test +"BEGIN:VALARM +TRIGGER;RELATED=END:-P2D +ACTION:EMAIL +ATTENDEE:mailto:john_doe@example.com +SUMMARY:*** REMINDER: SEND AGENDA FOR WEEKLY STAFF MEETING *** +DESCRIPTION:A draft agenda needs to be sent out to the attendees to the weekly managers meeting (MGR-LIST). Attached is a pointer the document template for the agenda file. +ATTACH;FMTTYPE=application/msword:http://example.com/templates/agenda.doc +END:VALARM +" +:parser icalendar-parse-component +:printer icalendar-print-component-node +:source rfc5545-sec3.6.6/3) + +(ipt:parse/print-test +"CALSCALE:GREGORIAN\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.7.1/1) + +(ipt:parse/print-test +"METHOD:REQUEST\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.7.2/1) + +(ipt:parse/print-test +"PRODID:-//ABC Corporation//NONSGML My Product//EN\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.7.3/1) + +(ipt:parse/print-test +"VERSION:2.0\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.7./1) + +(ipt:parse/print-test +"ATTACH:CID:jsmith.part3.960817T083000.xyzMail@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.1/1) + +(ipt:parse/print-test +"ATTACH;FMTTYPE=application/postscript:ftp://example.com/pub/reports/r-960812.ps\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.1/2) + +(ipt:parse/print-test +"CATEGORIES:APPOINTMENT,EDUCATION\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.2/1) + +(ipt:parse/print-test +"CATEGORIES:MEETING\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.2/2) + +(ipt:parse/print-test +"CLASS:PUBLIC\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.3/1) + +(ipt:parse/print-test +"COMMENT:The meeting really needs to include both ourselves and the customer. We can't hold this meeting without them. As a matter of fact\\, the venue for the meeting ought to be at their site. - - John\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.4/1) + +(ipt:parse/print-test +"DESCRIPTION:Meeting to provide technical review for \"Phoenix\" design.\\nHappy Face Conference Room. Phoenix design team MUST attend this meeting.\\nRSVP to team leader.\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.5/1) + +(ipt:parse/print-test +"GEO:37.386013;-122.082932\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.6/1) + +(ipt:parse/print-test +"LOCATION:Conference Room - F123\\, Bldg. 002\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.7/1) + +(ipt:parse/print-test +"LOCATION;ALTREP=\"http://xyzcorp.com/conf-rooms/f123.vcf\":Conference Room - F123\\, Bldg. 002\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.7/2) + +(ipt:parse/print-test +"PERCENT-COMPLETE:39\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.8/1) + +(ipt:parse/print-test +"PRIORITY:1\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.9/1) + +(ipt:parse/print-test +"PRIORITY:2\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.9/2) + +(ipt:parse/print-test +"PRIORITY:0\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.9/3) + +(ipt:parse/print-test +"RESOURCES:EASEL,PROJECTOR,VCR\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.10/1) + +(ipt:parse/print-test +"RESOURCES;LANGUAGE=fr:Nettoyeur haute pression\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.10/2) + +(ipt:parse/print-test +"STATUS:TENTATIVE\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.11/1) + +(ipt:parse/print-test +"STATUS:NEEDS-ACTION\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.11/2) + +(ipt:parse/print-test +"STATUS:DRAFT\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.11/3) + +(ipt:parse/print-test +"SUMMARY:Department Party\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.1.12/1) + +(ipt:parse/print-test +"COMPLETED:19960401T150000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.1/1) + +(ipt:parse/print-test +"DTEND:19960401T150000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.2/1) + +(ipt:parse/print-test +"DTEND;VALUE=DATE:19980704\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.2/2) + +(ipt:parse/print-test +"DUE:19980430T000000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.3/1) + +(ipt:parse/print-test +"DTSTART:19980118T073000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.4/1) + +(ipt:parse/print-test +"DURATION:PT1H0M0S\n" +;; 0M and 0S are not re-printed because they don't contribute to the duration: +:expected "DURATION:PT1H\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.5/1) + +(ipt:parse/print-test +"DURATION:PT15M\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.5/2) + +(ipt:parse/print-test +"FREEBUSY;FBTYPE=BUSY-UNAVAILABLE:19970308T160000Z/PT8H30M\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.6/1) + +(ipt:parse/print-test +"FREEBUSY;FBTYPE=FREE:19970308T160000Z/PT3H,19970308T200000Z/PT1H\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.6/2) + +(ipt:parse/print-test +"FREEBUSY;FBTYPE=FREE:19970308T160000Z/PT3H,19970308T200000Z/PT1H,19970308T230000Z/19970309T000000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.6/3) + +(ipt:parse/print-test +"TRANSP:TRANSPARENT\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.7/1) + +(ipt:parse/print-test +"TRANSP:OPAQUE\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.2.7/2) + +(ipt:parse/print-test +"TZID:America/New_York\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.1/1) + +(ipt:parse/print-test +"TZID:America/New_York\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.1/2) + +(ipt:parse/print-test +"TZID:/example.org/America/New_York\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.1/3) + +(ipt:parse/print-test +"TZNAME:EST\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.2/1) + +(ipt:parse/print-test +"TZNAME;LANGUAGE=fr-CA:HNE\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.2/2) + +(ipt:parse/print-test +"TZOFFSETFROM:-0500\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.3/1) + +(ipt:parse/print-test +"TZOFFSETFROM:+1345\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.3/2) + +(ipt:parse/print-test +"TZOFFSETTO:-0400\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.4/1) + +(ipt:parse/print-test +"TZOFFSETTO:+1245\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.4/2) + +(ipt:parse/print-test +"TZURL:http://timezones.example.org/tz/America-Los_Angeles.ics\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.3.5/1) + +(ipt:parse/print-test +"ATTENDEE;MEMBER=\"mailto:DEV-GROUP@example.com\":mailto:joecool@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/1) + +(ipt:parse/print-test +"ATTENDEE;DELEGATED-FROM=\"mailto:immud@example.com\":mailto:ildoit@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/2) + +(ipt:parse/print-test +"ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=TENTATIVE;CN=Henry Cabot:mailto:hcabot@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/3) + +(ipt:parse/print-test +"ATTENDEE;ROLE=REQ-PARTICIPANT;DELEGATED-FROM=\"mailto:bob@example.com\";PARTSTAT=ACCEPTED;CN=Jane Doe:mailto:jdoe@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/4) + +(ipt:parse/print-test +"ATTENDEE;CN=John Smith;DIR=\"ldap://example.com:6666/o=ABC%20Industries,c=US???(cn=Jim%20Dolittle)\":mailto:jimdo@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/5) + +(ipt:parse/print-test +"ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=TENTATIVE;DELEGATED-FROM=\"mailto:iamboss@example.com\";CN=Henry Cabot:mailto:hcabot@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/6) + +(ipt:parse/print-test +"ATTENDEE;ROLE=NON-PARTICIPANT;PARTSTAT=DELEGATED;DELEGATED-TO=\"mailto:hcabot@example.com\";CN=The Big Cheese:mailto:iamboss@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/7) + +(ipt:parse/print-test +"ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;CN=Jane Doe:mailto:jdoe@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/8) + +(ipt:parse/print-test +;; Corrected. Original lacks quotes around SENT-BY address. +"ATTENDEE;SENT-BY=\"mailto:jan_doe@example.com\";CN=John Smith:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.1/9) + +(ipt:parse/print-test +"CONTACT:Jim Dolittle\\, ABC Industries\\, +1-919-555-1234\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.2/1) + +(ipt:parse/print-test +;; Corrected. Original contained unallowed backslash in ldap: URI +"CONTACT;ALTREP=\"ldap://example.com:6666/o=ABC%20Industries,c=US???(cn=Jim%20Dolittle)\":Jim Dolittle\\, ABC Industries\\,+1-919-555-1234\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.2/2) + +(ipt:parse/print-test +"CONTACT;ALTREP=\"CID:part3.msg970930T083000SILVER@example.com\":Jim Dolittle\\, ABC Industries\\, +1-919-555-1234\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.2/3) + +(ipt:parse/print-test +"CONTACT;ALTREP=\"http://example.com/pdi/jdoe.vcf\":Jim Dolittle\\, ABC Industries\\, +1-919-555-1234\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.2/4) + +(ipt:parse/print-test +"ORGANIZER;CN=John Smith:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.3/1) + +(ipt:parse/print-test +"ORGANIZER;CN=JohnSmith;DIR=\"ldap://example.com:6666/o=DC%20Associates,c=US???(cn=John%20Smith)\":mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.3/2) + +(ipt:parse/print-test +"ORGANIZER;SENT-BY=\"mailto:jane_doe@example.com\":mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.3/3) + +(ipt:parse/print-test +"RECURRENCE-ID;VALUE=DATE:19960401\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.4/1) + +(ipt:parse/print-test +"RECURRENCE-ID;RANGE=THISANDFUTURE:19960120T120000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.4/2) + +(ipt:parse/print-test +"RELATED-TO:jsmith.part7.19960817T083000.xyzMail@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.5/1) + +(ipt:parse/print-test +"RELATED-TO:19960401-080045-4000F192713-0052@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.5/2) + +(ipt:parse/print-test +"URL:http://example.com/pub/calendars/jsmith/mytime.ics\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.6/1) + +(ipt:parse/print-test +"UID:19960401T080045Z-4000F192713-0052@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.4.7/1) + +(ipt:parse/print-test +"EXDATE:19960402T010000Z,19960403T010000Z,19960404T010000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.1/1) + +(ipt:parse/print-test +"RDATE:19970714T123000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.2/1) + +(ipt:parse/print-test +"RDATE;TZID=America/New_York:19970714T083000\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.2/2) + +(ipt:parse/print-test +"RDATE;VALUE=PERIOD:19960403T020000Z/19960403T040000Z,19960404T010000Z/PT3H\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.2/3) + +(ipt:parse/print-test +"RDATE;VALUE=DATE:19970101,19970120,19970217,19970421,19970526,19970704,19970901,19971014,19971128,19971129,19971225\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.2/4) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;COUNT=10\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/1) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;UNTIL=19971224T000000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/2) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;INTERVAL=2\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/3) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;INTERVAL=10;COUNT=5\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/4) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/5) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/6) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;COUNT=10\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/7) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;UNTIL=19971224T000000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/8) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;INTERVAL=2;WKST=SU\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/9) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/10) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/11) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/12) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/13) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;COUNT=10;BYDAY=1FR\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/14) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/15) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/16) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;COUNT=6;BYDAY=-2MO\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/17) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;BYMONTHDAY=-3\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/18) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/19) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/20) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=10,11,12,13,14,15\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/21) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;INTERVAL=2;BYDAY=TU\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/22) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;COUNT=10;BYMONTH=6,7\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/23) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/24) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/25) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;BYDAY=20MO\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/26) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/27) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=TH\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/28) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/29) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/30) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=7,8,9,10,11,12,13\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/31) + +(ipt:parse/print-test +"RRULE:FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=2,3,4,5,6,7,8\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/32) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/33) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/34) + +(ipt:parse/print-test +"RRULE:FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T170000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/35) + +(ipt:parse/print-test +"RRULE:FREQ=MINUTELY;INTERVAL=15;COUNT=6\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/36) + +(ipt:parse/print-test +"RRULE:FREQ=MINUTELY;INTERVAL=90;COUNT=4\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/37) + +(ipt:parse/print-test +"RRULE:FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=0,20,40\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/38) + +(ipt:parse/print-test +"RRULE:FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/39) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/40) + +(ipt:parse/print-test +"RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/41) + +(ipt:parse/print-test +"RRULE:FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.5.3/42) + +(ipt:parse/print-test +"ACTION:AUDIO\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.1/1) + +(ipt:parse/print-test +"ACTION:DISPLAY\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.1/2) + +(ipt:parse/print-test +"REPEAT:4\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.2/1) + +(ipt:parse/print-test +"TRIGGER:-PT15M\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.3/1) + +(ipt:parse/print-test +"TRIGGER;RELATED=END:PT5M\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.3/2) + +(ipt:parse/print-test +"TRIGGER;VALUE=DATE-TIME:19980101T050000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.6.3/3) + +(ipt:parse/print-test +"CREATED:19960329T133000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.7.1/1) + +(ipt:parse/print-test +"DTSTAMP:19971210T080000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.7.2/1) + +(ipt:parse/print-test +"LAST-MODIFIED:19960817T133000Z\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.7.3/1) + +(ipt:parse/print-test +"SEQUENCE:0\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.7.4/1) + +(ipt:parse/print-test +"SEQUENCE:2\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.7.4/2) + +(ipt:parse/print-test +"DRESSCODE:CASUAL\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.1/1) + +(ipt:parse/print-test +"NON-SMOKING;VALUE=BOOLEAN:TRUE\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.1/2) + +(ipt:parse/print-test +"X-ABC-MMSUBJ;VALUE=URI;FMTTYPE=audio/basic:http://www.example.org/mysubj.au\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.2/1) + +(ipt:parse/print-test +"REQUEST-STATUS:2.0;Success\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.3/1) + +(ipt:parse/print-test +"REQUEST-STATUS:3.1;Invalid property value;DTSTART:96-Apr-01\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.3/2) + +(ipt:parse/print-test +"REQUEST-STATUS:2.8; Success\\, repeating event ignored. Scheduled as a single event.;RRULE:FREQ=WEEKLY\\;INTERVAL=2\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.3/3) + +(ipt:parse/print-test +"REQUEST-STATUS:4.1;Event conflict. Date-time is busy.\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.3/4) + +(ipt:parse/print-test +"REQUEST-STATUS:3.7;Invalid calendar user;ATTENDEE:mailto:jsmith@example.com\n" +:parser icalendar-parse-property +:printer icalendar-print-property-node +:source rfc5545-sec3.8.8.3/5) + +(ipt:parse/print-test +"BEGIN:VCALENDAR +PRODID:-//xyz Corp//NONSGML PDA Calendar Version 1.0//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTAMP:19960704T120000Z +UID:uid1@example.com +ORGANIZER:mailto:jsmith@example.com +DTSTART:19960918T143000Z +DTEND:19960920T220000Z +STATUS:CONFIRMED +CATEGORIES:CONFERENCE +SUMMARY:Networld+Interop Conference +DESCRIPTION:Networld+Interop Conference and Exhibit\\nAtlanta World Congress Center\\nAtlanta\\, Georgia +END:VEVENT +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/1) + +(ipt:parse/print-test +"BEGIN:VCALENDAR +PRODID:-//RDU Software//NONSGML HandCal//EN +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:America/New_York +BEGIN:STANDARD +DTSTART:19981025T020000 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19990404T020000 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:19980309T231000Z +UID:guid-1.example.com +ORGANIZER:mailto:mrbig@example.com +ATTENDEE;RSVP=TRUE;ROLE=REQ-PARTICIPANT;CUTYPE=GROUP:mailto:employee-A@example.com +DESCRIPTION:Project XYZ Review Meeting +CATEGORIES:MEETING +CLASS:PUBLIC +CREATED:19980309T130000Z +SUMMARY:XYZ Project Review +DTSTART;TZID=America/New_York:19980312T083000 +DTEND;TZID=America/New_York:19980312T093000 +LOCATION:1CP Conference Room 4350 +END:VEVENT +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/2) + +(ipt:parse/print-test +"BEGIN:VCALENDAR +METHOD:xyz +VERSION:2.0 +PRODID:-//ABC Corporation//NONSGML My Product//EN +BEGIN:VEVENT +DTSTAMP:19970324T120000Z +SEQUENCE:0 +UID:uid3@example.com +ORGANIZER:mailto:jdoe@example.com +ATTENDEE;RSVP=TRUE:mailto:jsmith@example.com +DTSTART:19970324T123000Z +DTEND:19970324T210000Z +CATEGORIES:MEETING,PROJECT +CLASS:PUBLIC +SUMMARY:Calendaring Interoperability Planning Meeting +DESCRIPTION:Discuss how we can test c&s interoperability\\nusing iCalendar and other IETF standards. +LOCATION:LDB Lobby +ATTACH;FMTTYPE=application/postscript:ftp://example.com/pub/conf/bkgrnd.ps +END:VEVENT +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/3) + +(ipt:parse/print-test +;; Corrected. The TRIGGER property originally did not specify +;; VALUE=DATE-TIME, which is required since it is not the default type. +;; See https://www.rfc-editor.org/errata/eid2039 +"BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//ABC Corporation//NONSGML My Product//EN +BEGIN:VTODO +DTSTAMP:19980130T134500Z +SEQUENCE:2 +UID:uid4@example.com +ORGANIZER:mailto:unclesam@example.com +ATTENDEE;PARTSTAT=ACCEPTED:mailto:jqpublic@example.com +DUE:19980415T000000 +STATUS:NEEDS-ACTION +SUMMARY:Submit Income Taxes +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;VALUE=DATE-TIME:19980403T120000Z +ATTACH;FMTTYPE=audio/basic:http://example.com/pub/audio-files/ssbanner.aud +REPEAT:4 +DURATION:PT1H +END:VALARM +END:VTODO +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/4) + +(ipt:parse/print-test +"BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//ABC Corporation//NONSGML My Product//EN +BEGIN:VJOURNAL +DTSTAMP:19970324T120000Z +UID:uid5@example.com +ORGANIZER:mailto:jsmith@example.com +STATUS:DRAFT +CLASS:PUBLIC +CATEGORIES:Project Report,XYZ,Weekly Meeting +DESCRIPTION:Project xyz Review Meeting Minutes\\nAgenda\\n1. Review of project version 1.0 requirements.\\n2.Definitionof project processes.\\n3. Review of project schedule.\\nParticipants: John Smith\\, Jane Doe\\, Jim Dandy\\n-It was decided that the requirements need to be signed off byproduct marketing.\\n-P roject processes were accepted.\\n-Project schedule needs to account for scheduled holidaysand employee vacation time. Check with HR for specificdates.\\n-New schedule will be distributed by Friday.\\n-Next weeks meeting is cancelled. No meeting until 3/23. +END:VJOURNAL +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/5) + +(ipt:parse/print-test +;; Corrected. Original text in the standard is missing UID and DTSTAMP. +;; See https://www.rfc-editor.org/errata/eid4149 +"BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//RDU Software//NONSGML HandCal//EN +BEGIN:VFREEBUSY +UID:19970901T115957Z-76A912@example.com +DTSTAMP:19970901T120000Z +ORGANIZER:mailto:jsmith@example.com +DTSTART:19980313T141711Z +DTEND:19980410T141711Z +FREEBUSY:19980314T233000Z/19980315T003000Z +FREEBUSY:19980316T153000Z/19980316T163000Z +FREEBUSY:19980318T030000Z/19980318T040000Z +URL:http://www.example.com/calendar/busytime/jsmith.ifb +END:VFREEBUSY +END:VCALENDAR +" +:parser icalendar-parse-calendar +:printer icalendar-print-calendar-node +:source rfc5545-sec4/6) + + +;; Tests from real world data: +(ert-deftest ipt:bad-organizer-params () + "Real example: bad ORGANIZER property with params introduced by colon" + (let ((bad "ORGANIZER:CN=ORGANIZER:mailto:anonymized@domain.example\n") + (ok "ORGANIZER;CN=ORGANIZER:mailto:anonymized@domain.example\n")) + (should-error (ical:parse-from-string 'ical:organizer bad)) + (should (ical:ast-node-p (ical:parse-from-string 'ical:organizer ok))))) + +(ert-deftest ipt:bad-attendee () + "Real example: bad ATTENDEE property missing mailto: prefix" + (let ((bad "ATTENDEE;ROLE=REQ-PARTICIPANT;CN=TRAVELLER:anonymized@domain.example\n") + (ok "ATTENDEE;ROLE=REQ-PARTICIPANT;CN=TRAVELLER:mailto:anonymized@domain.example\n")) + (should-error (ical:parse-from-string 'ical:attendee bad)) + (should (ical:ast-node-p (ical:parse-from-string 'ical:attendee ok))))) + +(ert-deftest ipt:bad-attach () + "Real example: bad ATTACH property containing broken URI" + (let ((bad "ATTACH;VALUE=URI:Glass\n") + (ok "ATTACH;VALUE=URI:https://example.com\n")) + (should-error (ical:parse-from-string 'ical:attach bad)) + (should (ical:ast-node-p (ical:parse-from-string 'ical:attach ok))))) + +(ert-deftest ipt:bad-cnparam () + "Real example: bad unquoted CN parameter containing a comma" + (let ((bad "ORGANIZER;CN=Hartlauer GeschĂ€ft Wien, Taborstr. 18:mailto:anonymized@domain.example\n") + (ok "ORGANIZER;CN=\"Hartlauer GeschĂ€ft Wien, Taborstr. 18\":mailto:anonymized@domain.example\n")) + ;; strict parser should reject bad but accept ok: + (let ((ical:parse-strictly t)) + (should (ical:ast-node-p (ical:parse-from-string 'ical:organizer ok))) + (should-error (ical:parse-from-string 'ical:organizer bad))) + ;; relaxed parser should accept bad: + (let ((ical:parse-strictly nil)) + (should (ical:ast-node-p (ical:parse-from-string 'ical:organizer bad)))))) + +(ert-deftest ipt:fix-bad-description () + "Real example: bad DESCRIPTION property containing blank lines, +fixed by `icalendar-fix-blank-lines'." + (let ((bad "BEGIN:VCALENDAR +VERSION:2.0 +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VEVENT +UID:45dd7698-5c53-47e3-9280-19c5dff62571 +PRIORITY:1 +DTSTART:20210721T175200 +DTEND:20210721T192400 +LOCATION:Verona Porta Nuova +DESCRIPTION:Verona Porta Nuova-Firenze S. M. Novella;Train: Frecciarossa 8527, departing from Verona Porta Nuova Hours: 17:52; arriving at Firenze S. M. Novella Hours: 19:24 Coach 8, Position 7A; pnr code CLS345 + + +SUMMARY:Trip Verona Porta Nuova-Firenze S. M. Novella, Train Frecciarossa 8527, Coach 8, Position 7A, PNR CLS345, +ORGANIZER;CN=ORGANIZER:mailto:anonymized@domain.example +ATTENDEE;ROLE=REQ-PARTICIPANT;CN=BUYER:mailto:anonymized@domain.example +ATTENDEE;ROLE=REQ-PARTICIPANT;CN=TRAVELLER:mailto:anonymized@domain.example +END:VEVENT +END:VCALENDAR +")) + ;; The default parser should produce an error on the blank lines in + ;; DESCRIPTION: + (let ((ical:pre-parsing-hook nil)) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (ical:parse) + ;; Parsing should produce error at the bad description property: + (should (ical:errors-p)))) + ;; cleaning up the blank lines before parsing should correct this: + (let ((ical:pre-parsing-hook '(ical:fix-blank-lines))) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (let ((vcal (ical:parse))) + (should (not (ical:errors-p))) + (ical:with-component vcal + ((ical:vevent vevent)) + (ical:with-component vevent + ((ical:description :value description)) + (let* ((expected "CLS345") + (end (length description)) + (start (- end (length expected)))) + (should (equal expected + (substring description start end))))))))))) + +(ert-deftest ipt:bad-hyphenated-dates () + "Real example: bad date values containing hyphens, fixed by +`icalendar-fix-hyphenated-dates'." + (let ((bad "BEGIN:VCALENDAR +X-LOTUS-CHARSET:UTF-8 +VERSION:2.0 +PRODID:http://www.bahn.de +METHOD:PUBLISH +BEGIN:VTIMEZONE +TZID:Europe/Berlin +X-LIC-LOCATION:Europe/Berlin +BEGIN:DAYLIGHT +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +TZNAME:CEST +DTSTART:19700329T020000 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +BEGIN:STANDARD +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +TZNAME:CET +DTSTART:19701025T030000 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +UID:bahn2023-08-29141400 +CLASS:PUBLIC +SUMMARY:Frankfurt(Main)Hbf -> Hamburg Hbf +DTSTART;TZID=Europe/Berlin:2023-08-29T141400 +DTEND;TZID=Europe/Berlin:2023-08-29T183600 +DTSTAMP:2023-07-30T194700Z +END:VEVENT +END:VCALENDAR +")) + ;; default parser should skip the invalid DTSTART, DTEND, and DTSTAMP values: + (let ((ical:pre-parsing-hook nil)) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (let ((vcal (ical:parse))) + ;; Parsing should produce errors as the bad properties are + ;; skipped: + (should (ical:errors-p)) + ;; The resulting calendar is invalid because the VEVENT + ;; contains no DTSTAMP: + (should-error (ical:ast-node-valid-p vcal t))))) + ;; cleaning up the hyphenated dates before parsing should correct + ;; these problems: + (let ((ical:pre-parsing-hook '(ical:fix-hyphenated-dates))) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (let ((vcal (ical:parse)) + (expected-dtstamp + (ical:make-date-time :year 2023 :month 7 :day 30 + :hour 19 :minute 47 :second 0 + :zone 0))) + (should (not (ical:errors-p))) + (should (ical:ast-node-valid-p vcal t)) + (ical:with-component vcal + ((ical:vevent vevent)) + (ical:with-component vevent + ((ical:dtstamp :value dtstamp)) + (should (equal dtstamp expected-dtstamp))))))))) + +(ert-deftest ipt:bad-user-addresses () + "Real example: bad calendar user addresses missing \"mailto:\", fixed by +`icalendar-fix-missing-mailtos'." + (let ((bad "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:missing +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VEVENT +UID:45dd7698-5c53-47e3-9280-19c5dff62571 +PRIORITY:1 +DTSTART:20210721T175200 +DTEND:20210721T192400 +LOCATION:Verona Porta Nuova +SUMMARY:Trip Verona Porta Nuova-Firenze S. M. Novella +ORGANIZER;SENT-BY=\"other@domain.example\":anonymized@domain.example +ATTENDEE;ROLE=REQ-PARTICIPANT;CN=TRAVELER:traveler@domain.example +END:VEVENT +END:VCALENDAR +")) + (let ((ical:pre-parsing-hook nil)) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (ical:parse) + ;; Parsing should produce errors as the bad properties are + ;; skipped: + (should (ical:errors-p)))) + ;; cleaning up the addresses before parsing should correct + ;; these problems: + (let ((ical:pre-parsing-hook '(ical:fix-missing-mailtos))) + (with-temp-buffer + (ical:init-error-buffer) + (insert bad) + (goto-char (point-min)) + (let ((vcal (ical:parse)) + (expected-attendee "mailto:traveler@domain.example") + (expected-organizer "mailto:anonymized@domain.example") + (expected-sender "mailto:other@domain.example")) + (should (not (ical:errors-p))) + (ical:with-component vcal + ((ical:vevent vevent)) + (ical:with-component vevent + ((ical:attendee :value attendee) + (ical:organizer :value organizer)) + (should (equal attendee expected-attendee)) + (should (equal organizer expected-organizer)) + (ical:with-property organizer + ((ical:sentbyparam :value sent-by)) + (should (equal sent-by expected-sender)))))))))) + + + + +;; Local Variables: +;; read-symbol-shorthands: (("ipt:" . "icalendar-parser-test-") ("ical:" . "icalendar-")) +;; End: +;;; icalendar-parser-tests.el ends here diff --git a/test/lisp/calendar/icalendar-recur-tests.el b/test/lisp/calendar/icalendar-recur-tests.el new file mode 100644 index 00000000000..ed844b23dee --- /dev/null +++ b/test/lisp/calendar/icalendar-recur-tests.el @@ -0,0 +1,2873 @@ +;;; icalendar-recur-tests.el --- Tests for icalendar-recur -*- lexical-binding: t; -*- +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'ert) +(eval-when-compile (require 'icalendar-macs)) +(require 'icalendar-recur) +(require 'icalendar-utils) +(require 'icalendar-parser) +(require 'icalendar-ast) + +;; Some constants for tests that use time zones: +(defconst ict:tz-eastern + (ical:parse-from-string 'ical:vtimezone +"BEGIN:VTIMEZONE +TZID:America/New_York +LAST-MODIFIED:20050809T050000Z +BEGIN:DAYLIGHT +DTSTART:19670430T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=-1SU;UNTIL=19730429T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU;UNTIL=20061029T060000Z +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19740106T020000 +RDATE:19750223T020000 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:19760425T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=-1SU;UNTIL=19860427T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=1SU;UNTIL=20060402T070000Z +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:DAYLIGHT +DTSTART:20070311T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=2SU +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20071104T020000 +RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +END:STANDARD +END:VTIMEZONE +") +"`icalendar-vtimezone' representing America/New_York (Eastern) time.") + +(defconst ict:est-latest + (ical:with-component ict:tz-eastern + ((ical:standard :all stds)) + (seq-find (lambda (obs) + (ical:date-time= + (ical:make-date-time :year 2007 :month 11 :day 4 + :hour 2 :minute 0 :second 0) + (ical:with-property-of obs 'ical:dtstart nil value))) + stds)) + "The observance of Eastern Standard Time which began 2007-11-04") + +(defconst ict:edt-latest + (ical:with-component ict:tz-eastern + ((ical:daylight :all dls)) + (seq-find (lambda (obs) + (ical:date-time= + (ical:make-date-time :year 2007 :month 3 :day 11 + :hour 2 :minute 0 :second 0) + (ical:with-property-of obs 'ical:dtstart nil value))) + dls)) + "The observance of Eastern Daylight Time which began 2007-03-11") + +(defconst ict:est -18000 ;; = -0500 + "UTC offset for Eastern Standard Time") + +(defconst ict:edt -14400 ;; = -0400 + "UTC offset for Eastern Daylight Time") + + +;; Tests for basic functions: + +(ert-deftest ict:recur-bysetpos-filter () + "Test that `icr:make-bysetpos-filter' filters correctly by position" + (let* ((t1 (list 1 1 2024)) + (t2 (list 2 1 2024)) + (t3 (list 12 30 2024)) + (dts (list t1 t2 t3)) + (filter (icr:make-bysetpos-filter (list 1 -1))) + (filtered (funcall filter dts))) + (should (member t1 filtered)) + (should (member t3 filtered)) + (should-not (member t2 filtered)))) + +(ert-deftest ict:recur-yearday-number () + "Test that `calendar-date-from-day-of-year' finds correct dates" + (let* ((year 2025) + (daynos (list '(1 . (1 1 2025)) + '(8 . (1 8 2025)) + '(-1 . (12 31 2025)) + '(363 . (12 29 2025))))) + (dolist (d daynos) + (let ((dayno (car d)) + (date (cdr d))) + (should + (equal date (calendar-date-from-day-of-year year dayno))))))) + +(ert-deftest ict:date-time-add () + "Does `ical:date-time-add' correctly handle time zone transitions?" + ;; A sum that does not use a time zone at all: + (let* ((dt (ical:make-date-time :year 2007 :month 1 :day 1 + :hour 12 :minute 0 :second 0)) + (delta (make-decoded-time :day 2)) + (expected (ical:date-time-variant dt :day 3))) + (should (equal expected (ical:date-time-add dt delta)))) + + ;; A sum that does not cross an observance boundary: + (let* ((dt (ical:make-date-time :year 2007 :month 2 :day 1 + :hour 12 :minute 0 :second 0 + :zone ict:est :dst nil)) + (delta (make-decoded-time :day 2)) + (expected (ical:date-time-variant dt :day 3 :tz 'preserve))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that crosses the Std->DST boundary and should preserve clock time: + (let* ((dt (ical:make-date-time :year 2007 :month 3 :day 10 + :hour 12 :minute 0 :second 0 + :zone ict:est :dst nil)) + (delta (make-decoded-time :day 2)) + (expected (ical:date-time-variant dt :day 12 :zone ict:edt :dst t))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that crosses the Std->DST boundary and should be exactly 48 hours later: + (let* ((dt (ical:make-date-time :year 2007 :month 3 :day 10 + :hour 12 :minute 0 :second 0 + :zone ict:est :dst nil)) + (delta (make-decoded-time :hour 48)) + (expected (ical:date-time-variant dt :day 12 :hour 13 + :zone ict:edt :dst t))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that crosses the DST->Std boundary and should preserve clock time: + (let* ((dt (ical:make-date-time :year 2007 :month 11 :day 3 + :hour 12 :minute 0 :second 0 + :zone ict:edt :dst t)) + (delta (make-decoded-time :day 2)) + (expected (ical:date-time-variant dt :day 5 :zone ict:est :dst nil))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that crosses the DST->Std boundary and should be exactly 48 hours later: + (let* ((dt (ical:make-date-time :year 2007 :month 11 :day 3 + :hour 12 :minute 0 :second 0 + :zone ict:edt :dst t)) + (delta (make-decoded-time :hour 48)) + (expected (ical:date-time-variant dt :day 5 :hour 11 + :zone ict:est :dst nil))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that lands exactly on the Std->DST boundary and should result + ;; in a clock time one hour later: + (let* ((dt (ical:make-date-time :year 2007 :month 3 :day 10 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (delta (make-decoded-time :hour 24)) + (expected (ical:date-time-variant dt :day 11 :hour 3 + :zone ict:edt :dst t))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern)))) + + ;; A sum that lands exactly on the DST->Std boundary and should result + ;; in a clock time one hour earlier: + (let* ((dt (ical:make-date-time :year 2007 :month 11 :day 3 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (delta (make-decoded-time :hour 24)) + (expected (ical:date-time-variant dt :day 4 :hour 1 + :zone ict:est :dst nil))) + (should (equal expected (ical:date-time-add dt delta ict:tz-eastern))))) + +(ert-deftest ict:recur-nonexistent-date-time-p () + "Does `icr:nonexistent-date-time-p' correctly identify nonexistent times?" + (let* ((dst-onset (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + ;; 2:30 AM falls into the gap when shifting from 2AM EST to 3AM EDT: + (nonexistent1 (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 2 :minute 30 :second 0 + :zone ict:est :dst nil)) + (nonexistent2 (ical:date-time-variant nonexistent1 + :zone ict:edt :dst t)) + (std-onset (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + ;; 1:30AM around the shift back to EST exists twice (once in + ;; EDT, once in EST) and should not be nonexistent: + (existent1 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 1 :minute 30 :second 0 + :zone ict:edt :dst t)) + (existent2 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 1 :minute 30 :second 0 + :zone ict:est :dst nil))) + (should (icr:nonexistent-date-time-p nonexistent1 dst-onset ict:edt-latest)) + (should (icr:nonexistent-date-time-p nonexistent2 dst-onset ict:edt-latest)) + (should-not + (icr:nonexistent-date-time-p existent1 std-onset ict:est-latest)) + (should-not + (icr:nonexistent-date-time-p existent2 std-onset ict:est-latest)))) + +(ert-deftest ict:recur-date-time-occurs-twice-p () + "Does `icr:date-time-occurs-twice-p' correctly identify times that occur twice?" + (let* ((std-onset (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + ;; 1:00, 1:30 AM occur twice when shifting from 2AM EDT to 1AM EST: + (twice1 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 1 :minute 0 :second 0)) + (twice2 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 1 :minute 30 :second 0)) + ;; 12:59 AM, 2AM should not occur twice: + (once1 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 0 :minute 59 :second 0 + :zone ict:edt :dst t)) + (once2 (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil))) + (should (icr:date-time-occurs-twice-p twice1 std-onset ict:est-latest)) + (should (icr:date-time-occurs-twice-p twice2 std-onset ict:est-latest)) + (should-not + (icr:date-time-occurs-twice-p once1 std-onset ict:est-latest)) + (should-not + (icr:date-time-occurs-twice-p once2 std-onset ict:est-latest)))) + +(ert-deftest ict:recur-find-secondly-interval () + "Does `icr:find-secondly-interval' find correct intervals?" + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0 + ;; Use UTC for the tests with no + ;; time zone, so that the results + ;; don't depend on system's local time + :zone 0)) + (dtstart/tz (ical:date-time-variant dtstart :zone ict:est :dst nil))) + + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; No timezone, just clock time, around a target that doesn't fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2026 :second 5 :zone 0)) + (expected-int + (list + (ical:date-time-variant target :second 0 :tz 'preserve) + (ical:date-time-variant target :second 1 :tz 'preserve) + (ical:date-time-variant target :second 10 :tz 'preserve)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart 10)))) + + ;; No timezone, just clock time, around a target that does fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2027 :second 10 :zone 0)) + (expected-int + (list + (ical:date-time-variant target :second 10 :tz 'preserve) + (ical:date-time-variant target :second 11 :tz 'preserve) + (ical:date-time-variant target :second 20 :tz 'preserve)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart 10)))) + + ;; With timezone, around a target that falls on an interval + ;; boundary, in the same observance: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2028 :month 2 :second 20 + :zone ict:est :dst nil)) + (expected-int + (list + (ical:date-time-variant target :second 20 :tz 'preserve) + (ical:date-time-variant target :second 21 :tz 'preserve) + (ical:date-time-variant target :second 30 :tz 'preserve)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart/tz 10 + ict:tz-eastern)))) + + ;; With timezone, around a target that does not fall on an interval + ;; boundary, and after the time zone observance shift: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2029 :month 5 :second 30 + :zone ict:edt :dst t)) + (expected-int + (list + (ical:date-time-variant target :second 30 :tz 'preserve) + (ical:date-time-variant target :second 31 :tz 'preserve) + (ical:date-time-variant target :second 40 :tz 'preserve)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart/tz 10 ict:tz-eastern)))) + + ;; With timezone, around a target that falls into the gap in local + ;; times and thus does not exist as a local time. In this case, what + ;; is supposed to happen is that the clock time value in the [observance] + ;; recurrences "is interpreted using the UTC offset before the gap + ;; in local times." So we should get the same absolute times back, + ;; but re-decoded into the new observance, i.e., one hour later. + (let* ((target (ical:date-time-variant dtstart/tz + :year 2030 :month 3 :day 10 + :hour 2 :minute 30 :second 0 + :zone ict:est :dst nil)) + (expected-int + (list + (ical:date-time-variant target :hour 3 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 3 :second 1 + :zone ict:edt :dst t) + (ical:date-time-variant target + :hour 3 :second 10 + :zone ict:edt :dst t)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart/tz 10 ict:tz-eastern)))) + + ;; With timezone, with a "pathological" interval size of 59 seconds. + ;; There should be no problem with this case, because the interval + ;; bounds calculation is done in absolute time, but it's annoying to + ;; calculate the expected interval by hand: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2031 :month 4 :day 15 + :hour 12 :minute 0 :second 0 + :zone ict:edt :dst t)) + (intsize 59) + (expected-int + (list + (ical:date-time-variant target :hour 11 :minute 59 :second 16 + :tz 'preserve) + (ical:date-time-variant target :hour 11 :minute 59 :second 17 + :tz 'preserve) + (ical:date-time-variant target :hour 12 :minute 0 :second 15 + :tz 'preserve)))) + (should + (equal expected-int + (icr:find-secondly-interval target dtstart/tz intsize + ict:tz-eastern)))))) + +(ert-deftest ict:recur-find-minutely-interval () + "Does `icr:find-minutely-interval' find correct intervals?" + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 + ;; make sure intervals are + ;; bounded on whole minutes: + :second 23)) + (dtstart/tz (ical:date-time-variant dtstart :zone ict:est :dst nil))) + + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; No timezone, just a fixed offset, around a target that doesn't fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2026 :minute 5)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :minute 0 :second 0) + (ical:date-time-variant target :minute 1 :second 0) + (ical:date-time-variant target :minute 10 :second 0)))) + (should + (equal expected-int + (icr:find-minutely-interval target dtstart intsize)))) + + ;; No timezone, just clock time, around a target that does fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2027 :minute 10)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :minute 10 :second 0) + (ical:date-time-variant target :minute 11 :second 0) + (ical:date-time-variant target :minute 20 :second 0)))) + (should + (equal expected-int + (icr:find-minutely-interval target dtstart intsize)))) + + ;; With timezone, around a target that falls on an interval + ;; boundary, in the same observance: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2028 :month 2 :minute 20 + :zone ict:est :dst nil)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :minute 20 :second 0 + :zone ict:est :dst nil) + (ical:date-time-variant target :minute 21 :second 0 + :zone ict:est :dst nil) + (ical:date-time-variant target :minute 30 :second 0 + :zone ict:est :dst nil)))) + (should + (equal expected-int + (icr:find-minutely-interval target dtstart/tz intsize + ict:tz-eastern)))) + + ;; With timezone, around a target that does not fall on an interval + ;; boundary, and after the time zone observance shift: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2029 :month 5 :minute 30 + :zone ict:edt :dst t)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :minute 30 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :minute 31 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :minute 40 :second 0 + :zone ict:edt :dst t)))) + (should + (equal expected-int + (icr:find-minutely-interval target dtstart/tz intsize + ict:tz-eastern)))) + + ;; With timezone, around a target that falls into the gap in local + ;; times and thus does not exist as a local time. In this case, what + ;; is supposed to happen is that the clock time value in the [observance] + ;; recurrences "is interpreted using the UTC offset before the gap + ;; in local times." So we should get the same absolute times back, + ;; but re-decoded into the new observance, i.e., one hour later. + (let* ((target (ical:date-time-variant dtstart/tz + :year 2030 :month 3 :day 10 + :hour 2 :minute 30 :second 0 + :zone ict:est :dst nil)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :hour 3 :minute 30 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 3 :minute 31 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target + :hour 3 :minute 40 :second 0 + :zone ict:edt :dst t)))) + (should + (equal expected-int + (icr:find-minutely-interval target dtstart/tz intsize + ict:tz-eastern)))))) + +(ert-deftest ict:recur-find-hourly-interval () + "Does `icr:find-hourly-interval' find correct intervals?" + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 + ;; make sure intervals are bounded on + ;; whole hours: + :minute 11 :second 23)) + (dtstart/tz (ical:date-time-variant dtstart :zone ict:est :dst nil))) + + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + ;; No timezone, just clock time, around a target that doesn't fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2026 :hour 5)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :hour 1 :minute 0 :second 0) + (ical:date-time-variant target :hour 10 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-hourly-interval target dtstart intsize)))) + + ;; No timezone, just clock time, around a target that does fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2027 :hour 10)) + (intsize 10) + (expected-int + (list + (ical:date-time-variant target :hour 10 :minute 0 :second 0) + (ical:date-time-variant target :hour 11 :minute 0 :second 0) + (ical:date-time-variant target :hour 20 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-hourly-interval target dtstart intsize)))) + + ;; With timezone, around a target that falls on an interval + ;; boundary, in the same observance: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2028 :month 2 :hour 10 + :zone ict:est :dst nil)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :hour 10 :minute 0 :second 0 + :zone ict:est :dst nil) + (ical:date-time-variant target :hour 11 :minute 0 :second 0 + :zone ict:est :dst nil) + (ical:date-time-variant target :hour 12 :minute 0 :second 0 + :zone ict:est :dst nil)))) + (should + (equal expected-int + (icr:find-hourly-interval target dtstart/tz intsize + ict:tz-eastern)))) + + ;; With time zone, around a target that does not fall on an interval + ;; boundary, and after the time zone observance shift. Note that + ;; because of our decision to calculate with absolute times in + ;; SECONDLY/MINUTELY/HOURLY rules (see `icr:find-secondly-recurrence-rule') + ;; the interval clock times shift an hour here: + (let* ((target (ical:date-time-variant dtstart/tz + :year 2029 :month 5 :hour 12 + :zone ict:edt :dst t)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :hour 11 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 12 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 13 :minute 0 :second 0 + :zone ict:edt :dst t)))) + (should + (equal expected-int + (icr:find-hourly-interval target dtstart/tz intsize + ict:tz-eastern)))) + + ;; With timezone, around a target that falls into the gap in local + ;; times and thus does not exist as a local time. In this case, what + ;; is supposed to happen is that the clock time value in the [observance] + ;; recurrences "is interpreted using the UTC offset before the gap + ;; in local times." So we should get the same absolute times back, + ;; but re-decoded into the new observance, i.e., one hour later. + (let* ((target (ical:make-date-time :year 2030 :month 3 :day 10 + :hour 2 :minute 30 :second 30 + :zone ict:est :dst nil)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :hour 3 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 4 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:date-time-variant target :hour 5 :minute 0 :second 0 + :zone ict:edt :dst t)))) + (should + (equal expected-int + (icr:find-hourly-interval target dtstart/tz intsize + ict:tz-eastern)))))) + +(ert-deftest ict:recur-find-daily-interval-w/date () + "Does `icr:find-daily-interval' find correct date intervals?" + (let* ((dtstart (list 1 8 2025))) + ;; Since all the results should be the same after the initial + ;; calculation of the absolute dates DTSTART and TARGET, we just + ;; test one simple case here and test with date-times more + ;; thoroughly below. + + ;; A target that doesn't fall on an interval boundary: + (let* ((target (list 1 9 2026)) + (intsize 7) + (expected-int + (list + (ical:make-date-time :year 2026 :month 1 :day 7 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 8 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 14 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-daily-interval target dtstart intsize)))))) + +(ert-deftest ict:recur-find-daily-interval-w/date-time () + "Does `icr:find-daily-interval' find correct date-time intervals?" + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 8 ; a Wednesday + ;; make sure intervals are bounded on + ;; whole days: + :hour 7 :minute 11 :second 23)) + (dtstart/tz (ical:date-time-variant dtstart :zone ict:est :dst nil))) + + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; No timezone, just clock time, around a target that doesn't fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart + :year 2026 :month 1 :day 9)) + (intsize 7) + (expected-int + (list + (ical:date-time-variant target :day 7 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 8 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 14 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-daily-interval target dtstart intsize)))) + + ;; No timezone, just clock time, around a target that does fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2027 :month 1 :day 6)) + (intsize 7) + (expected-int + (list + (ical:date-time-variant target :day 6 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 7 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 13 :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-daily-interval target dtstart intsize)))) + + ;; With timezone, around a target that falls on an interval + ;; boundary, in the same observance: + (let* ((target (ical:date-time-variant dtstart/tz :year 2028 :month 2 :day 2 + :zone ict:est :dst nil)) + (intsize 7) + (expected-int + (list + (ical:date-time-variant target :day 2 :hour 0 :minute 0 :second 0 + :tz 'preserve) + (ical:date-time-variant target :day 3 :hour 0 :minute 0 :second 0 + :tz 'preserve) + (ical:date-time-variant target :day 9 :hour 0 :minute 0 :second 0 + :tz 'preserve)))) + (should + (equal expected-int + (icr:find-daily-interval target dtstart/tz intsize ict:tz-eastern)))) + + ;; With time zone, around a target that does not fall on an interval + ;; boundary, and after the time zone observance shift. + (let* ((target (ical:date-time-variant dtstart/tz + :year 2029 :month 5 :day 28 + :zone ict:edt :dst t)) + (intsize 7) + (expected-int + (list + (ical:date-time-variant target :day 23 :hour 0 :minute 0 :second 0 + :tz 'preserve) + (ical:date-time-variant target :day 24 :hour 0 :minute 0 :second 0 + :tz 'preserve) + (ical:date-time-variant target :day 30 :hour 0 :minute 0 :second 0 + :tz 'preserve)))) + (should + (equal expected-int + (icr:find-daily-interval target dtstart/tz intsize + ict:tz-eastern)))))) + +(ert-deftest ict:recur-find-weekly-interval-w/date () + "Does `icr:find-weekly-interval' find correct date intervals?" + (let* ((dtstart '(1 8 2025))) + ;; Since all the results should be the same after the initial + ;; calculation of the absolute dates DTSTART and TARGET, we just + ;; test one simple case here and test with date-times more + ;; thoroughly below. + + ;; A target that doesn't fall on an interval boundary: + (let* ((target '(1 9 2026)) + (intsize 2) + (expected-int-mon + (list + (ical:make-date-time :year 2026 :month 1 :day 5 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 12 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 19 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int-mon + (icr:find-weekly-interval target dtstart intsize)))))) + +(ert-deftest ict:recur-find-weekly-interval-w/date-time () + "Does `icr:find-weekly-interval' find correct date-time intervals?" + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 8 ; a Wednesday + ;; make sure intervals are bounded on + ;; whole days: + :hour 7 :minute 11 :second 23))) + + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; No timezone, just clock time, around a target that doesn't fall on + ;; an interval boundary: + (let* ((target (ical:date-time-variant dtstart :year 2026 :month 1 :day 9)) + (intsize 2) + (weds 3) + ;; expected interval for Monday (default) week start: + (expected-int-mon + (list + (ical:date-time-variant target :day 5 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 12 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 19 :hour 0 :minute 0 :second 0))) + ;; expected interval for Wednesday week start: + (expected-int-wed + (list + (ical:date-time-variant target :day 7 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 14 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 21 :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int-mon + (icr:find-weekly-interval target dtstart intsize))) + (should + (equal expected-int-wed + (icr:find-weekly-interval target dtstart intsize weds)))) + + ;; Around a target that does fall on an interval boundary, Monday week start: + (let* ((target (ical:date-time-variant dtstart :year 2027 :month 1 :day 4)) + (intsize 3) + ;; expected interval for Monday (default) week start: + (expected-int-mon + (list + (ical:date-time-variant target :year 2026 :month 12 :day 21 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2026 :month 12 :day 28 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 11 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int-mon + (icr:find-weekly-interval target dtstart intsize)))) + + ;; Around a target that does fall on an interval boundary, Sunday week start: + (let* ((target (ical:date-time-variant dtstart :year 2028 :month 1 :day 2)) + (intsize 3) + (sun 0) + ;; expected interval for Sunday week start: + (expected-int-sun + (list + (ical:date-time-variant target :day 2 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 9 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :day 23 :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int-sun + (icr:find-weekly-interval target dtstart intsize sun)))))) + +(ert-deftest ict:recur-find-monthly-interval () + "Does `icr:find-monthly-interval' find correct intervals?" + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; One test with dates, to make sure that works: + (let* ((dtstart '(1 8 2025)) + (target '(10 9 2025)) + (intsize 5) + (expected-int + (list + (ical:make-date-time :year 2025 :month 6 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2025 :month 7 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2025 :month 11 :day 1 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-monthly-interval target dtstart intsize)))) + + ;; Around a target that doesn't fall on an interval boundary: + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 1 + ;; make sure intervals are bounded on + ;; whole days: + :hour 7 :minute 11 :second 23)) + (target (ical:date-time-variant dtstart :year 2026 :month 3 :day 9)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :day 1 :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :month 4 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :month 5 :day 1 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-monthly-interval target dtstart intsize)))) + + ;; Around a target that does fall on an interval boundary: + (let* ((dtstart (ical:make-date-time :year 2025 :month 1 :day 1 + ;; make sure intervals are bounded on + ;; whole days: + :hour 7 :minute 11 :second 23)) + (target (ical:date-time-variant dtstart :year 2027 :month 5 :day 1)) + (intsize 7) + (expected-int + (list + (ical:date-time-variant target :year 2027 :month 5 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2027 :month 6 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2027 :month 12 :day 1 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-monthly-interval target dtstart intsize)))) + + ;; Around a target that does not fall on an interval boundary, where + ;; start month > target month + (let* ((dtstart (ical:make-date-time :year 2028 :month 11 :day 11 + :hour 11 :minute 11 :second 11)) + (target (ical:date-time-variant dtstart + :year 2029 :month 4 :day 15)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :year 2029 :month 3 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2029 :month 4 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2029 :month 5 :day 1 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-monthly-interval target dtstart intsize)))) + + ;; Around a target that falls on an interval boundary, where + ;; start month > target month + (let* ((dtstart (ical:make-date-time :year 2029 :month 11 :day 11 + :hour 11 :minute 11 :second 11 )) + (target (ical:date-time-variant dtstart + :year 2030 :month 5 :day 1)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :year 2030 :month 5 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2030 :month 6 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2030 :month 7 :day 1 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-monthly-interval target dtstart intsize)))) + + ;; Around a target that falls on an interval boundary, where + ;; start month = target month + (let* ((dtstart (ical:make-date-time :year 2031 :month 11 :day 11 + :hour 11 :minute 11 :second 11 )) + (target (ical:date-time-variant dtstart :year 2032 :month 11 :day 11)) + (intsize 2) + (expected-int + (list + (ical:date-time-variant target :year 2032 :month 11 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2032 :month 12 :day 1 + :hour 0 :minute 0 :second 0) + (ical:date-time-variant target :year 2033 :month 1 :day 1 + :hour 0 :minute 0 :second 0)))) + (should + (equal expected-int + (icr:find-monthly-interval target dtstart intsize))))) + +(ert-deftest ict:recur-find-yearly-interval () + "Does `icr:find-yearly-interval' find correct date intervals?" + ;; Year numbers are monotonically increasing in the following test cases, + ;; to make it easy to tell which of them fails. + + ;; One test with dates, to make sure that works: + (let* ((dtstart '(1 8 2025)) + (target '(10 9 2025)) + (intsize 2) + (expected-int + (list + (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2027 :month 1 :day 1 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-yearly-interval target dtstart intsize)))) + + ;; A target not on an interval boundary: + (let* ((dtstart (ical:make-date-time :year 2026 :month 3 :day 1 + :hour 1 :minute 2 :second 3)) + (target (ical:make-date-time :year 2026 :month 7 :day 28 + :hour 11 :minute 58 :second 0)) + (intsize 3) + (expected-int + (list + (ical:make-date-time :year 2026 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2027 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2029 :month 1 :day 1 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-yearly-interval target dtstart intsize)))) + + ;; A target on an interval boundary: + (let* ((dtstart (ical:make-date-time :year 2027 :month 3 :day 1 + :hour 1 :minute 2 :second 3)) + (target (ical:make-date-time :year 2028 :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (intsize 4) + (expected-int + (list + (ical:make-date-time :year 2027 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2028 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2031 :month 1 :day 1 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-yearly-interval target dtstart intsize)))) + + ;; A target earlier than dtstart but in the same year; + ;; it's important that this works when looking up recurrences of + ;; time zone observance onsets + (let* ((dtstart (ical:make-date-time :year 2029 :month 5 :day 28 + :hour 1 :minute 2 :second 3)) + (target (ical:make-date-time :year 2029 :month 2 :day 14 + :hour 11 :minute 58 :second 0)) + (intsize 1) + (expected-int + (list + (ical:make-date-time :year 2029 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2030 :month 1 :day 1 + :hour 0 :minute 0 :second 0) + (ical:make-date-time :year 2030 :month 1 :day 1 + :hour 0 :minute 0 :second 0)))) + (should (equal expected-int + (icr:find-yearly-interval target dtstart intsize))))) + +;; Subintervals: + +(ert-deftest ict:recur-refine-byyearday () + "Does `icr:refine-byyearday' correctly refine by yeardays?" + (let* ((low (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :year 1)) + (interval (list low high high)) + (yeardays (list 2 -7)) + (sub1 (list (ical:date-time-variant low :day 2) + (ical:date-time-variant low :day 3))) + (sub2 (list (ical:date-time-variant low :month 12 :day 25) + (ical:date-time-variant low :month 12 :day 26))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byyearday interval yeardays))))) + +(ert-deftest ict:recur-refine-bymonth () + "Does `icr:refine-bymonth' correctly refine by months?" + (let* ((low (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :year 1)) + (interval (list low high high)) + (months (list 9 2)) + (sub1 (list (ical:date-time-variant low :month 2 :day 1) + (ical:date-time-variant low :month 3 :day 1))) + (sub2 (list (ical:date-time-variant low :month 9 :day 1) + (ical:date-time-variant low :month 10 :day 1))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-bymonth interval months))))) + +(ert-deftest ict:recur-refine-bymonthday () + "Does `icr:refine-bymonthday' correctly refine by days of the month?" + (let* ((low (ical:make-date-time :year 2025 :month 2 :day 1 + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :month 1)) + (interval (list low high high)) + (monthdays (list -1 2 29)) + ;; N.B. we should get no subinterval for Feb. 29, 2025 + (sub1 (list (ical:date-time-variant low :day 2) + (ical:date-time-variant low :day 3))) + (sub2 (list (ical:date-time-variant low :day 28) + (ical:date-time-variant low :month 3 :day 1))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-bymonthday interval monthdays))))) + +(ert-deftest ict:recur-refine-byday () + "Does `icr:refine-byday' correctly refine by days of the week?" + ;; The simple case: just day names + (let* ((low (ical:make-date-time :year 2025 :month 3 :day 3 ; a Monday + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :day 7)) + (interval (list low high high)) + (days (list 0 6)) ; just the weekend, please! + (sub1 (list (ical:date-time-variant low :day 8) + (ical:date-time-variant low :day 9))) + (sub2 (list (ical:date-time-variant low :day 9) + (ical:date-time-variant low :day 10))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byday interval days)))) + + ;; Day names with offsets within the month + (let* ((low (ical:make-date-time :year 2025 :month 3 :day 1 ; a Saturday + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :month 1)) + (interval (list low high high)) + (days (list '(1 . 2) '(1 . -1))) ; second and last Monday + (sub1 (list (ical:date-time-variant low :day 10) + (ical:date-time-variant low :day 11))) + (sub2 (list (ical:date-time-variant low :day 31) + (ical:date-time-variant low :month 4 :day 1))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byday interval days t)))) + + ;; Day names with offsets within the year + (let* ((low (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :year 1)) + (interval (list low high high)) + (days (list '(5 . 1) '(5 . -1))) ; first and last Friday + (sub1 (list (ical:date-time-variant low :day 3) + (ical:date-time-variant low :day 4))) + (sub2 (list (ical:date-time-variant low :month 12 :day 26) + (ical:date-time-variant low :month 12 :day 27))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byday interval days nil))))) + +(ert-deftest ict:recur-refine-byhour () + "Does `icr:refine-byhour' correctly refine by hours?" + ;; No time zone, just clock times: + (let* ((low (ical:make-date-time :year 2025 :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (high (ical:date/time-add low :day 1)) + (interval (list low high high)) + (hours (list 2 19)) + (sub1 (list (ical:date-time-variant low :hour 2) + (ical:date-time-variant low :hour 3))) + (sub2 (list (ical:date-time-variant low :hour 19) + (ical:date-time-variant low :hour 20))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byhour interval hours)))) + + ;; With time zone, but without crossing an observance boundary: + (let* ((low (ical:make-date-time :year 2025 :month 2 :day 1 + :hour 0 :minute 0 :second 0 + :zone ict:est :dst nil)) + (high (ical:date/time-add low :day 1 ict:tz-eastern)) + (interval (list low high high)) + (hours (list 2 19)) + (sub1 (list (ical:date-time-variant low :hour 2 :tz 'preserve) + (ical:date-time-variant low :hour 3 :tz 'preserve))) + (sub2 (list (ical:date-time-variant low :hour 19 :tz 'preserve) + (ical:date-time-variant low :hour 20 :tz 'preserve))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byhour interval hours ict:tz-eastern))))) + +(ert-deftest ict:recur-refine-byminute () + "Does `icr:refine-byminute' correctly refine by minutes?" + ;; No time zone, just clock times: + (let* ((low (ical:make-date-time :year 2025 :month 5 :day 1 + :hour 13 :minute 0 :second 0)) + (high (ical:date/time-add low :hour 1)) + (interval (list low high high)) + (minutes (list 7 59)) + (sub1 (list (ical:date-time-variant low :minute 7) + (ical:date-time-variant low :minute 8))) + (sub2 (list (ical:date-time-variant low :minute 59) + (ical:date-time-variant low :hour 14 :minute 0))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byminute interval minutes)))) + + ;; With time zone, but without crossing an observance boundary: + (let* ((low (ical:make-date-time :year 2025 :month 2 :day 1 + :hour 13 :minute 0 :second 0 + :zone ict:est :dst nil)) + (high (ical:date/time-add low :hour 1 ict:tz-eastern)) + (interval (list low high high)) + (minutes (list 7 59)) + (sub1 (list (ical:date-time-variant low :minute 7 :tz 'preserve) + (ical:date-time-variant low :minute 8 :tz 'preserve))) + (sub2 (list (ical:date-time-variant low :minute 59 :tz 'preserve) + (ical:date-time-variant low :hour 14 :minute 0 + :tz 'preserve))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-byminute interval minutes ict:tz-eastern))))) + +(ert-deftest ict:recur-refine-bysecond () + "Does `icr:refine-bysecond' correctly refine by seconds?" + ;; No time zone, just clock times: + (let* ((low (ical:make-date-time :year 2025 :month 5 :day 1 + :hour 13 :minute 59 :second 0)) + (high (ical:date/time-add low :minute 1)) + (interval (list low high high)) + (seconds (list 24 59)) + (sub1 (list (ical:date-time-variant low :second 24) + (ical:date-time-variant low :second 25))) + (sub2 (list (ical:date-time-variant low :second 59) + (ical:date-time-variant low :hour 14 :minute 0 :second 0))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-bysecond interval seconds)))) + + ;; With time zone, but without crossing an observance boundary: + (let* ((low (ical:make-date-time :year 2025 :month 2 :day 1 + :hour 13 :minute 19 :second 0 + :zone ict:est :dst nil)) + (high (ical:date/time-add low :minute 1 ict:tz-eastern)) + (interval (list low high high)) + (seconds (list 24 59)) + (sub1 (list (ical:date-time-variant low :second 24 :tz 'preserve) + (ical:date-time-variant low :second 25 :tz 'preserve))) + (sub2 (list (ical:date-time-variant low :second 59 :tz 'preserve) + (ical:date-time-variant low :minute 20 :second 0 + :tz 'preserve))) + (expected-subintervals (list sub1 sub2))) + (should (equal expected-subintervals + (icr:refine-bysecond interval seconds ict:tz-eastern))))) + +(ert-deftest ict:recur-subintervals-to-dates () + "Does `icr:subintervals-to-dates' correctly generate recurrences?" + ;; Two subintervals, the first three days long, the second less than a single day + (let* ((low1 (ical:make-date-time :year 2025 :month 5 :day 1 + :hour 13 :minute 59 :second 0)) + (high1 (ical:date/time-add low1 :day 3)) + (sub1 (list low1 high1)) + (low2 (ical:make-date-time :year 2025 :month 5 :day 31 + :hour 14 :minute 0 :second 0)) + (high2 (ical:date/time-add low2 :hour 3)) ; later but on the same day + (sub2 (list low2 high2)) + (low-date1 (ical:date-time-to-date low1)) + (low-date2 (ical:date-time-to-date low2)) + (expected-recs (list low-date1 + (ical:date/time-add low-date1 :day 1) + (ical:date/time-add low-date1 :day 2) + (ical:date/time-add low-date1 :day 3) + low-date2))) + (should (equal expected-recs + (icr:subintervals-to-dates (list sub1 sub2)))))) + +(ert-deftest ict:recur-subintervals-to-date-times () + "Does `icr:subintervals-to-date-times' correctly generate recurrences?" + ;; Two subintervals, each one second long, no time zone + (let* ((low1 (ical:make-date-time :year 2025 :month 5 :day 1 + :hour 13 :minute 59 :second 0)) + (high1 (ical:date/time-add low1 :second 1)) + (sub1 (list low1 high1)) + (low2 (ical:make-date-time :year 2025 :month 5 :day 2 + :hour 14 :minute 0 :second 0)) + (high2 (ical:date/time-add low2 :second 1)) + (sub2 (list low2 high2)) + (expected-recs (list low1 low2))) + (should (equal expected-recs + (icr:subintervals-to-date-times (list sub1 sub2))))) + + ;; A subinterval five seconds long, with time zone + (let* ((low1 (ical:make-date-time :year 2025 :month 6 :day 1 + :hour 13 :minute 59 :second 0 + :zone ict:edt :dst t)) + (high1 (ical:date/time-add low1 :second 5 ict:tz-eastern)) + (sub1 (list low1 high1)) + (expected-recs + (list low1 + (ical:date/time-add low1 :second 1 ict:tz-eastern) + (ical:date/time-add low1 :second 2 ict:tz-eastern) + (ical:date/time-add low1 :second 3 ict:tz-eastern) + (ical:date/time-add low1 :second 4 ict:tz-eastern)))) + (should (equal expected-recs + (icr:subintervals-to-date-times (list sub1) ict:tz-eastern)))) + + ;; A subinterval five seconds long, with time zone, which crosses an + ;; observance boundary where the final three seconds occur after + ;; clocks are set forward an hour; these seconds should therefore be in EDT: + (let* ((low1 (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 1 :minute 59 :second 58 + :zone ict:est :dst nil)) + (high1 (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 3 :minute 0 :second 3 + :zone ict:edt :dst t)) + (sub1 (list low1 high1)) + (expected-recs + (list low1 + (ical:date-time-variant low1 :second 59 :tz 'preserve) + (ical:date-time-variant high1 :second 0 :tz 'preserve) + (ical:date-time-variant high1 :second 1 :tz 'preserve) + (ical:date-time-variant high1 :second 2 :tz 'preserve)))) + (should (equal expected-recs + (icr:subintervals-to-date-times (list sub1) ict:tz-eastern)))) + + ;; A subinterval five seconds long, with time zone, which crosses an + ;; observance boundary where the final three seconds occur after + ;; clocks are set back an hour; these seconds should therefore be in + ;; EST: + (let* ((low1 (ical:make-date-time :year 2024 :month 11 :day 3 + :hour 1 :minute 59 :second 58 + :zone ict:edt :dst t)) + (high1 (ical:make-date-time :year 2024 :month 11 :day 3 + :hour 1 :minute 0 :second 2 + :zone ict:est :dst nil)) + (sub1 (list low1 high1)) + (expected-recs + (list low1 + (ical:date-time-variant low1 :second 59 :tz 'preserve) + (ical:date-time-variant high1 :second 0 :tz 'preserve) + (ical:date-time-variant high1 :second 1 :tz 'preserve)))) + (should (equal expected-recs + (icr:subintervals-to-date-times (list sub1) ict:tz-eastern))))) + +;; Tests for time zone functions: + +(ert-deftest ict:recur-tz-observance-on/nonexistent () + "Does `icr:tz-observance-on' correctly interpret nonexistent times?" + (let* ((onset-start (ical:make-date-time :year 2030 :month 3 :day 10 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (start-shifted (ical:date-time-variant onset-start :hour 3 + :zone ict:edt :dst t)) + ;; 2:30AM falls into the gap when the clock jumps from 2AM to 3AM: + (nonexistent (ical:date-time-variant onset-start :minute 30 + :zone ict:est :dst nil)) + (nonexistent-shifted (ical:date-time-variant nonexistent :hour 3 + :zone ict:edt :dst t))) + (icr:tz-observance-on onset-start ict:tz-eastern t) ;; updates the time to EDT + (icr:tz-observance-on nonexistent ict:tz-eastern t) ;; updates the time to EDT + (should (equal onset-start start-shifted)) + (should (equal nonexistent nonexistent-shifted)))) + +(ert-deftest ict:recur-tz-observance-on/occurs-twice () + "Does `icr:tz-observance-on' correctly interpret times that occur twice?" + (let* ((onset-start (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + ;; 1:30AM occurs twice when the clock is set back from 2AM to 1AM: + (no-zone (ical:date-time-variant onset-start :hour 1 :minute 30)) + (first (ical:date-time-variant onset-start :hour 1 :minute 30 + :zone ict:edt :dst t)) + (second (ical:date-time-variant first :zone ict:est :dst nil)) + (first+1h (ical:date/time-add first :hour 1 ict:tz-eastern))) + (icr:tz-observance-on no-zone ict:tz-eastern t) ;; sets zone + (should (equal first no-zone)) + (should (equal second first+1h)))) + +(ert-deftest ict:recur-tz-observance-on () + "Does `icr:tz-observance-on' correctly find observances?" + + ;; A date before the start of all observances in the timezone. + ;; In this case, there is no matching observance, so we should get nil. + (let* ((dt (ical:make-date-time :year 1900 :month 1 :day 1 + :hour 12 :minute 0 :second 0 + :zone ict:est :dst nil)) + (ts (encode-time dt))) + (should (null (icr:tz-observance-on dt ict:tz-eastern))) + (should (null (icr:tz-observance-on ts ict:tz-eastern)))) + + ;; A date matching the start of one of the STANDARD observances: + (let* ((dt (ical:make-date-time :year 1967 :month 10 :day 29 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching the start of a DAYLIGHT observance: + (let* ((dt (ical:make-date-time :year 1967 :month 4 :day 30 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching an RDATE of a DAYLIGHT observance: + (let* ((dt (ical:make-date-time :year 1975 :month 2 :day 23 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching the end of a STANDARD observance: + (let* ((ut (ical:make-date-time :year 2006 :month 10 :day 29 + :hour 6 :minute 0 :second 0 + :zone 0 :dst nil)) ; UNTIL is in UTC + (dt (ical:make-date-time :year 2006 :month 10 :day 29 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (ical:date-time-simultaneous-p ut dt)) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching the end of a DAYLIGHT observance: + (let* ((ut (ical:make-date-time :year 2006 :month 4 :day 2 + :hour 7 :minute 0 :second 0 + :zone 0 :dst nil)) ; UNTIL is in UTC + (dt (ical:make-date-time :year 2006 :month 4 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (ical:date-time-simultaneous-p ut dt)) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching an onset in the middle of a DAYLIGHT observance + ;; which has ended: + (let* ((dt (ical:make-date-time :year 1980 :month 4 :day 27 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (end (ical:make-date-time :year 1986 :month 4 :day 27 + :hour 7 :minute 0 :second 0 + :zone 0)) ; UNTIL is in UTC + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal end (ical:recur-until + (ical:with-property-of obs 'ical:rrule nil value)))) + (should (equal obs/onset ts-obs/onset))) + + ;; A date matching an onset of the DAYLIGHT observance which is + ;; ongoing: + (let* ((dt (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal dt onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date in the middle of the DAYLIGHT observance which is ongoing: + (let* ((start (ical:make-date-time :year 2025 :month 3 :day 9 + :hour 2 :minute 0 :second 0 + :zone ict:est :dst nil)) + (dt (ical:make-date-time :year 2025 :month 5 :day 28 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:daylight (ical:ast-node-type obs))) + (should (equal start onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; A date in the middle of the STANDARD observance which is ongoing: + (let* ((start (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (dt (ical:make-date-time :year 2026 :month 1 :day 28 + :hour 12 :minute 30 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal start onset)) + (should (equal obs/onset ts-obs/onset))) + + ;; The following two tests were useful in detecting a broken optimization: + (let* ((start (ical:make-date-time :year 2006 :month 10 :day 29 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (dt (ical:make-date-time :year 2006 :month 11 :day 1 + :hour 12 :minute 30 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal start onset)) + (should (equal obs/onset ts-obs/onset))) + + (let* ((start (ical:make-date-time :year 2007 :month 11 :day 4 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (dt (ical:make-date-time :year 2008 :month 2 :day 1 + :hour 12 :minute 30 :second 0 + :zone ict:est :dst nil)) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern)) + (obs (car obs/onset)) + (onset (cadr obs/onset)) + ;; make sure we get the same result with an absolute time: + (ts (encode-time dt)) + (ts-obs/onset (icr:tz-observance-on ts ict:tz-eastern))) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal start onset)) + (should (equal obs/onset ts-obs/onset))) + + + ;; A date in the middle of the STANDARD observance which is ongoing; + ;; test that the update flag correctly sets the zone information: + (let* ((start (ical:make-date-time :year 2025 :month 11 :day 2 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t)) + (dt (ical:make-date-time :year 2026 :month 1 :day 28 + :hour 12 :minute 30 :second 0 + ;; no zone information + )) + (obs/onset (icr:tz-observance-on dt ict:tz-eastern t)) + (obs (car obs/onset)) + (onset (cadr obs/onset))) + (should (eq 'ical:standard (ical:ast-node-type obs))) + (should (equal start onset)))) + + +;; Tests for recurrence rule interpretation: +(cl-defmacro ict:rrule-test (recur-string doc + &key dtstart + (low dtstart) + high + tz + rdates + exdates + members + nonmembers + size + source) + + "Create a test which parses RECUR-STRING to an `icalendar-recur', +creates an event with a recurrence set from this value, and checks +various properties of the recurrence set. + +DTSTART should be an `icalendar-date' or `icalendar-date-time' + value appropriate to the RECUR-STRING. The value will be + bound to the symbol `dtstart'; this symbol can thus be used inside + the expressions for MEMBERS and NONMEMBERS. +LOW and HIGH should be the bounds of the window in which to compute + recurrences. LOW defaults to DTSTART. +TZ, if present, should be an `icalendar-vtimezone'. + Date-times in the recurrence set will be calculated relative to this + time zone. +RDATES, if present, should be a list of additional + `icalendar-date' or `icalendar-date-time' values to be added to + the recurrence set *in addition to* those generated by the + recurrence rule (see `icalendar-rdate'). +EXDATES, if present, should be a list of `icalendar-date' or + `icalendar-date-time' values to be excluded from the recurrence + set, *even if* they are in RDATES or generated by the + recurrence rule (see `icalendar-exdate'). +MEMBERS, if present, should be a list of values that are expected + to be present in the recurrence set. +NONMEMBERS, if present, should be a list of values that are expected + to be excluded from the recurrence set. +SIZE, if present, should be a positive integer representing the + expected size of the recurrence set. Defaults to the value of the + COUNT clause in the recurrence rule, if any. +SOURCE should be a symbol; it is used to name the test." + `(ert-deftest ,(intern (concat "ict:rrule-test-" (symbol-name source))) () + ,(format "Parse and evaluate recur-value example from `%s':\n%s" + source doc) + (let* ((parsed (ical:parse-from-string 'ical:recur ,recur-string)) + (recvalue (ical:ast-node-value parsed)) + (until (ical:recur-until recvalue)) + (count (ical:recur-count recvalue)) + (dtstart ,dtstart) + (tzid + (when (cl-typep dtstart 'ical:date-time) + "America/New_York")) + (recset-size (or ,size count)) + (vevent + (ical:make-vevent + (ical:uid (concat "uid-test-" ,(symbol-name source))) + (ical:dtstart dtstart (ical:tzidparam tzid)) + (ical:rrule parsed) + (ical:rdate ,rdates) + (ical:exdate ,exdates))) + ;; default for HIGH: UNTIL or DTSTART+3*INTERVAL + (win-high + (or ,high + until + (cadr + (icr:nth-interval 2 ,dtstart recvalue)))) + (recs + (if count + (icr:recurrences-to-count vevent ,tz) + (icr:recurrences-in-window ,low win-high vevent ,tz)))) + (should (ical:ast-node-valid-p parsed)) + (when ,members + (dolist (dt ,members) + (should (member dt recs)))) + (when ,nonmembers + (dolist (dt ,nonmembers) + (should-not (member dt recs)))) + (when recset-size + (should (length= recs recset-size)))))) + +(ict:rrule-test + "FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-1" + "Last non-weekend day of the month" + :dtstart '(3 31 2025) + :high '(6 1 2025) + :members '((3 31 2025) (4 30 2025) (5 30 2025)) + :nonmembers '((5 31 2025)) ;; 5/31/2025 is a Saturday + :source rfc5545-sec3.3.10/1) + +(ict:rrule-test + "FREQ=YEARLY;INTERVAL=2;BYMONTH=1;BYDAY=SU;BYHOUR=8,9;BYMINUTE=30" + "Every Sunday in January at 8:30AM and 9:30AM, every other year" + :dtstart (ical:read-date-time "20250105T083000") + :high (ical:read-date-time "20271231T000000") + :members + (let ((jan3-27 (ical:make-date-time :year 2027 :month 1 :day 3 + :hour 8 :minute 30 :second 0))) + (list dtstart + ;; 2025: Jan 5, 12, 19, 26 + (ical:date-time-variant dtstart :hour 9) + (ical:date-time-variant dtstart :day 12) + (ical:date-time-variant dtstart :day 12 :hour 9) + (ical:date-time-variant dtstart :day 19) + (ical:date-time-variant dtstart :day 19 :hour 9) + (ical:date-time-variant dtstart :day 19) + (ical:date-time-variant dtstart :day 19 :hour 9) + (ical:date-time-variant dtstart :day 26) + (ical:date-time-variant dtstart :day 26 :hour 9) + ;; 2027: Jan 3, 10, 17, 24, 31 + (ical:date-time-variant jan3-27 :hour 9) + (ical:date-time-variant jan3-27 :day 10) + (ical:date-time-variant jan3-27 :day 10 :hour 9) + (ical:date-time-variant jan3-27 :day 17) + (ical:date-time-variant jan3-27 :day 17 :hour 9) + (ical:date-time-variant jan3-27 :day 24) + (ical:date-time-variant jan3-27 :day 24 :hour 9) + (ical:date-time-variant jan3-27 :day 31) + (ical:date-time-variant jan3-27 :day 31 :hour 9))) + :nonmembers + (list + (ical:make-date-time :year 2026 :month 1 :day 4 + :hour 8 :minute 30 :second 0) + (ical:make-date-time :year 2026 :month 1 :day 4 + :hour 9 :minute 30 :second 0)) + :source rfc5545-sec3.3.10/2) + +(ict:rrule-test + "FREQ=YEARLY;BYMONTH=2;BYMONTHDAY=-1" + "Every year on the last day in February" + :dtstart '(2 29 2024) + :high '(3 1 2028) + :members '((2 28 2025) (2 28 2026) (2 28 2027) (2 29 2028)) + :nonmembers '((2 28 2028)) + :source leap-day/1) + +(ict:rrule-test + "FREQ=YEARLY;INTERVAL=4;BYMONTH=2;BYMONTHDAY=29" + "Every four years on February 29" + :dtstart '(2 29 2024) + :high '(3 1 2028) + :members '((2 29 2028)) + :nonmembers '((2 28 2028)) + :source leap-day/2) + +(ict:rrule-test +"FREQ=DAILY;COUNT=10" +"Daily for 10 occurrences" +:dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0) +:members +;; (1997 9:00 AM EDT) September 2-11 +(mapcar + (lambda (day) (ical:date-time-variant dtstart :day day)) + (number-sequence 2 11)) +:source rfc5545-sec3.3.10/3) + +(ict:rrule-test + "RRULE:FREQ=YEARLY" + "Every year on a specific date, e.g. an anniversary" + :dtstart '(11 11 2024) + :high '(10 1 2030) + :members '((11 11 2024) + (11 11 2025) + (11 11 2026) + (11 11 2027) + (11 11 2028) + (11 11 2029)) + :nonmembers '((11 11 2030)) + :source rfc5545-sec3.6.1/3) + +;; Time zone tests + +(ict:rrule-test + "RRULE:FREQ=YEARLY;BYMONTH=4;BYDAY=-1SU;UNTIL=19730429T070000Z" + "Every year on the last Sunday of April (through 1973-04-29) at 2AM. +(Onset of US Eastern Daylight Time.)" + :tz ict:tz-eastern + ;; DTSTART and all the times below are at *3*AM EDT, because 2AM EST + ;; (the onset of the observance) does not exist as a local time: + :dtstart (ical:make-date-time :year 1967 :month 4 :day 30 + :hour 3 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:date-time-variant dtstart :year 1973 :month 4 :day 30 + :zone ict:edt :dst t) + :members + (list + (ical:date-time-variant dtstart :year 1968 :day 28 :tz 'preserve) + (ical:date-time-variant dtstart :year 1969 :day 27 :tz 'preserve) + (ical:date-time-variant dtstart :year 1970 :day 26 :tz 'preserve) + (ical:date-time-variant dtstart :year 1971 :day 25 :tz 'preserve) + (ical:date-time-variant dtstart :year 1972 :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :year 1973 :day 29 :tz 'preserve)) + :source rfc5545-sec3.6.5/1) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU" + "Every year on the first Sunday of November at 2AM. +(Onset of Eastern Standard Time)." + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 2007 :month 11 :day 4 + :hour 2 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:date-time-variant dtstart :year 2010 :month 11 :day 8 + :zone ict:est :dst nil) + :members + ;; all the times below are at *1*AM EST, because 2AM EDT (the onset of + ;; the observance) is when clocks get set back: + (list (ical:date-time-variant dtstart + :year 2008 :month 11 :day 2 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart + :year 2009 :month 11 :day 1 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart + :year 2010 :month 11 :day 7 + :zone ict:est :dst nil)) + :source rfc5545-sec3.6.5/3.1) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;INTERVAL=3;BYDAY=1SU" + "Every three months on the first Sunday of the month." + :dtstart '(1 5 2025) + :high '(1 1 2026) + :members (list '(4 6 2025) + '(7 6 2025) + '(10 5 2025)) + :nonmembers (list '(1 12 2025) ;; second Sun. + '(2 2 2025) ;; first Sun. in Feb. + '(4 5 2025)) ;; Sat. + :source monthly/interval) + +(ict:rrule-test + "RRULE:FREQ=DAILY;COUNT=10\n" + "Daily for 10 occurrences" + :dtstart (ical:read-date-time "19970902T090000") + :members + (mapcar + (lambda (day) (ical:date-time-variant dtstart :day day)) + (number-sequence 2 11)) + :nonmembers (list (ical:date-time-variant dtstart :day 12)) + :high (ical:read-date-time "19970912T090000") + :source rfc5545-sec3.8.5.3/1) + +(ict:rrule-test + "RRULE:FREQ=DAILY;UNTIL=19971224T000000Z\n" + "Daily at 9AM until December 24, 1997" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + ;; EDT: + (mapcar + (lambda (day) (ical:date-time-variant dtstart :day day :tz 'preserve)) + (number-sequence 2 30)) ;; Sept. 2--30 + (mapcar + (lambda (day) (ical:date-time-variant dtstart :month 10 :day day + :tz 'preserve)) + (number-sequence 1 25)) ;; Oct. 1--25 + ;; EST: + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :month 10 :day day :zone ict:est :dst nil)) + (number-sequence 26 31))) ;; Oct. 26--31 + :source rfc5545-sec3.8.5.3/2) + +(ict:rrule-test + "RRULE:FREQ=DAILY;INTERVAL=2\n" + "Every other day - forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1997 :month 12 :day 4 + :hour 0 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (append + ;; (1997 9:00 AM EDT) September 2,4,6,8...24,26,28,30; + ;; October 2,4,6...20,22,24 + (mapcar + (lambda (n) + (ical:date-time-variant dtstart :day (* 2 n) :tz 'preserve)) + (number-sequence 1 15)) + (mapcar + (lambda (n) + (ical:date-time-variant dtstart :month 10 :day (* 2 n) :tz 'preserve)) + (number-sequence 1 12)) + ;; (1997 9:00 AM EST) October 26,28,30; + ;; November 1,3,5,7...25,27,29; + ;; December 1,3,... + (mapcar + (lambda (n) + (ical:date-time-variant dtstart :month 10 :day (* 2 n) + :zone ict:est :dst nil)) + (number-sequence 13 15)) + (mapcar + (lambda (n) + (ical:date-time-variant dtstart :month 11 :day (1- (* 2 n)) + :zone ict:est :dst nil)) + (number-sequence 1 15)) + (mapcar + (lambda (n) + (ical:date-time-variant dtstart :month 12 :day (1- (* 2 n)) + :zone ict:est :dst nil)) + (number-sequence 1 2))) + + :nonmembers + (list + ;; e.g. + (ical:make-date-time :year 1997 :month 10 :day 27 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/3) + +(ict:rrule-test + "RRULE:FREQ=DAILY;INTERVAL=10;COUNT=5\n" + "Every ten days for five recurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + + :members ;; (1997 9:00 AM EDT) September 2,12,22; October 2,12 + (list + dtstart + (ical:make-date-time :year 1997 :month 9 :day 12 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:make-date-time :year 1997 :month 9 :day 22 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:make-date-time :year 1997 :month 10 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + (ical:make-date-time :year 1997 :month 10 :day 12 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t)) + :source rfc5545-sec3.8.5.3/4) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA\n" + "Every day in January, for three years (weekdays explicit)" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1998 :month 1 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :high (ical:make-date-time :year 2000 :month 2 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + ;; (1998 9:00 AM EST)January 1-31 + ;; (1999 9:00 AM EST)January 1-31 + ;; (2000 9:00 AM EST)January 1-31 + (append + (mapcar + (lambda (day) (ical:date-time-variant dtstart :day day :tz 'preserve)) + (number-sequence 1 31)) + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :year 1999 :day day :tz 'preserve)) + (number-sequence 1 31)) + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :year 2000 :day day :tz 'preserve)) + (number-sequence 1 31))) + :source rfc5545-sec3.8.5.3/5) + +(ict:rrule-test + "RRULE:FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1\n" + "Every day in January, for three years (weekdays implicit)" + ;; TODO: as things are currently implemented, this way of expressing + ;; the rule is quite expensive, since we end up computing intervals and + ;; recurrences for every day of the year, even though the only relevant + ;; days are in January and there are no recurrences on the other days. + ;; We could try to optimize e.g. icr:refine-from-clauses to deal with such + ;; cases. + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1998 :month 1 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :high (ical:make-date-time :year 2000 :month 2 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + ;; (1998 9:00 AM EST)January 1-31 + ;; (1999 9:00 AM EST)January 1-31 + ;; (2000 9:00 AM EST)January 1-31 + (append + (mapcar + (lambda (day) (ical:date-time-variant dtstart :day day :tz 'preserve)) + (number-sequence 1 31)) + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :year 1999 :day day :tz 'preserve)) + (number-sequence 1 31)) + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :year 2000 :day day :tz 'preserve)) + (number-sequence 1 31))) + :source rfc5545-sec3.8.5.3/6) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;COUNT=10\n" + "Weekly for ten occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + ;; (1997 9:00 AM EDT) September 2,9,16,23,30;October 7,14,21 + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :day day :tz 'preserve)) + (list 2 9 16 23 30)) + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :month 10 :day day :tz 'preserve)) + (list 7 14 21)) + ;; (1997 9:00 AM EST) October 28;November 4 + (list + (ical:make-date-time :year 1997 :month 10 :day 28 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + (ical:make-date-time :year 1997 :month 11 :day 4 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil))) + :source rfc5545-sec3.8.5.3/7) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;UNTIL=19971224T000000Z\n" + "Every week until December 24, 1997" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (let ((oct97 (ical:date-time-variant dtstart :month 10 + :zone ict:edt :dst t)) + (nov97 (ical:date-time-variant dtstart :month 11 + :zone ict:est :dst nil)) + (dec97 (ical:date-time-variant dtstart :month 12 + :zone ict:est :dst nil))) + (append + ;; (1997 9:00 AM EDT) September 2,9,16,23,30; + ;; October 7,14,21 + (mapcar + (lambda (day) + (ical:date-time-variant dtstart :day day :tz 'preserve)) + (list 2 9 16 23 30)) + (mapcar + (lambda (day) + (ical:date-time-variant oct97 :day day :tz 'preserve)) + (list 7 14 21)) + ;; (1997 9:00 AM EST) October 28; + ;; November 4,11,18,25; + ;; December 2,9,16,23 + (list (ical:date-time-variant oct97 :day 28 :zone ict:est :dst nil)) + (mapcar + (lambda (day) + (ical:date-time-variant nov97 :day day :tz 'preserve)) + (list 4 11 18 25)) + (mapcar + (lambda (day) + (ical:date-time-variant dec97 :day day :tz 'preserve)) + (list 2 9 16 23)))) + :source rfc5545-sec3.8.5.3/8) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;INTERVAL=2;WKST=SU\n" + "Every other week - forever; Weekstart on Sunday" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1998 :month 3 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 2,16,30; + ;; October 14 + dtstart + (ical:date-time-variant dtstart :day 16 :tz 'preserve) + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 14 :tz 'preserve) + ;; (1997 9:00 AM EST) October 28; + ;; November 11,25; + ;; December 9,23 + (ical:date-time-variant dtstart :month 10 :day 28 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 11 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 25 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 23 :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 6,20; + ;; February 3, 17 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 6 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 20 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 3 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 17 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/9) + +(ict:rrule-test +"RRULE:FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH\n" +"Weekly on Tuesday and Thursday for five weeks, using UNTIL" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1997 :month 10 :day 8 + :hour 0 :minute 0 :second 0 :zone 0) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 2,4,9,11,16,18,23,25,30; + ;; October 2 + dtstart + (ical:date-time-variant dtstart :day 4 :tz 'preserve) + (ical:date-time-variant dtstart :day 9 :tz 'preserve) + (ical:date-time-variant dtstart :day 11 :tz 'preserve) + (ical:date-time-variant dtstart :day 16 :tz 'preserve) + (ical:date-time-variant dtstart :day 18 :tz 'preserve) + (ical:date-time-variant dtstart :day 23 :tz 'preserve) + (ical:date-time-variant dtstart :day 25 :tz 'preserve) + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 2 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/10) + +(ict:rrule-test +"RRULE:FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH\n" +"Weekly on Tuesday and Thursday for five weeks, using COUNT" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1997 :month 10 :day 8 + :hour 0 :minute 0 :second 0 :zone 0) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 2,4,9,11,16,18,23,25,30; + ;; October 2 + dtstart + (ical:date-time-variant dtstart :day 4 :tz 'preserve) + (ical:date-time-variant dtstart :day 9 :tz 'preserve) + (ical:date-time-variant dtstart :day 11 :tz 'preserve) + (ical:date-time-variant dtstart :day 16 :tz 'preserve) + (ical:date-time-variant dtstart :day 18 :tz 'preserve) + (ical:date-time-variant dtstart :day 23 :tz 'preserve) + (ical:date-time-variant dtstart :day 25 :tz 'preserve) + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 2 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/11) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR\n" + "Every other week on Monday, Wednesday, and Friday until December 24, +1997, starting on Monday, September 1, 1997" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + dtstart + ;; ==> (1997 9:00 AM EDT) September 1,3,5,15,17,19,29; + ;; October 1,3,13,15,17 + (ical:date-time-variant dtstart :day 3 :tz 'preserve) + (ical:date-time-variant dtstart :day 5 :tz 'preserve) + (ical:date-time-variant dtstart :day 15 :tz 'preserve) + (ical:date-time-variant dtstart :day 17 :tz 'preserve) + (ical:date-time-variant dtstart :day 19 :tz 'preserve) + (ical:date-time-variant dtstart :day 29 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 1 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 3 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 13 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 15 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 17 :tz 'preserve) + ;; (1997 9:00 AM EST) October 27,29,31; + ;; November 10,12,14,24,26,28; + ;; December 8,10,12,22 + (ical:date-time-variant dtstart :month 10 :day 27 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 10 :day 29 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 10 :day 31 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 10 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 12 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 14 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 24 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 26 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 28 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 8 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 10 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 12 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 22 :zone ict:est :dst nil)) + :nonmembers + (list + ;; These match the rule, but are just past the UNTIL date: + (ical:date-time-variant dtstart :month 12 :day 24 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 26 :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/12) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH\n" + "Every other week on Tuesday and Thursday, for 8 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + ;; ==> (1997 9:00 AM EDT) September 2,4,16,18,30; + ;; October 2,14,16 + (list + dtstart + (ical:date-time-variant dtstart :day 4 :tz 'preserve) + (ical:date-time-variant dtstart :day 16 :tz 'preserve) + (ical:date-time-variant dtstart :day 18 :tz 'preserve) + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 2 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 14 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 16 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/13) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;COUNT=10;BYDAY=1FR\n" + "Monthly on the first Friday for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 5;October 3 + dtstart + (ical:date-time-variant dtstart :month 10 :day 3 :tz 'preserve) + ;; (1997 9:00 AM EST) November 7;December 5 + (ical:date-time-variant dtstart :month 11 :day 7 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 5 :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 2;February 6;March 6;April 3 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 2 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 6 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 6 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 4 :day 3 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EDT) May 1;June 5 + (ical:date-time-variant dtstart :year 1998 :month 5 :day 1 :tz 'preserve) + (ical:date-time-variant dtstart :year 1998 :month 6 :day 5 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/14) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR\n" + "Monthly on the first Friday until December 24, 1997" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 5; October 3 + dtstart + (ical:date-time-variant dtstart :month 10 :day 3 :tz 'preserve) + ;; (1997 9:00 AM EST) November 7;December 5 + (ical:date-time-variant dtstart :month 11 :day 7 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 5 :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/15) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU\n" + "Every other month on the first and last Sunday of the month for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 7 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 7,28 + dtstart + (ical:date-time-variant dtstart :day 28 :tz 'preserve) + ;; (1997 9:00 AM EST) November 2,30 + (ical:date-time-variant dtstart :month 11 :day 2 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 30 :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 4,25;March 1,29 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 4 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 25 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 1 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 29 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EDT) May 3,31 + (ical:date-time-variant dtstart :year 1998 :month 5 :day 3 :tz 'preserve) + (ical:date-time-variant dtstart :year 1998 :month 5 :day 31 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/16) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;COUNT=6;BYDAY=-2MO\n" + "Monthly on the second-to-last Monday of the month for 6 months" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 22 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 22;October 20 + dtstart + (ical:date-time-variant dtstart :month 10 :day 20 :tz 'preserve) + ;; (1997 9:00 AM EST) November 17;December 22 + (ical:date-time-variant dtstart :month 11 :day 17 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 22 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 19;February 16 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 19 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 16 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/17) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;BYMONTHDAY=-3\n" + "Monthly on the third-to-the-last day of the month, forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 28 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1998 :month 3 :day 1 + :hour 0 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 28 + dtstart + ;; (1997 9:00 AM EST) October 29;November 28;December 29 + (ical:date-time-variant dtstart :month 10 :day 29 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 28 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 29 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 29;February 26 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 29 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 26 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/18) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15\n" + "Monthly on the 2nd and 15th of the month for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 2,15;October 2,15 + dtstart + (ical:date-time-variant dtstart :day 15 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 2 :tz 'preserve) + (ical:date-time-variant dtstart :month 10 :day 15 :tz 'preserve) + ;; (1997 9:00 AM EST) November 2,15;December 2,15 + (ical:date-time-variant dtstart :month 11 :day 2 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 15 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 2 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 15 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 2,15 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 2 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 15 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/19) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1\n" + "Monthly on the first and last day of the month for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 30 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 30;October 1 + dtstart + (ical:date-time-variant dtstart :month 10 :day 1 :tz 'preserve) + ;; (1997 9:00 AM EST) October 31;November 1,30;December 1,31 + (ical:date-time-variant dtstart :month 10 :day 31 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 1 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 30 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 1 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 31 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 1,31;February 1 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 1 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 31 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 1 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/20) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=10,11,12,13,14,15\n" + "Every 18 months on the 10th thru 15th of the month for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 10 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + (list + ;; ==> (1997 9:00 AM EDT) September 10,11,12,13,14,15 + dtstart + (ical:date-time-variant dtstart :day 11 :tz 'preserve) + (ical:date-time-variant dtstart :day 12 :tz 'preserve) + (ical:date-time-variant dtstart :day 13 :tz 'preserve) + (ical:date-time-variant dtstart :day 14 :tz 'preserve) + (ical:date-time-variant dtstart :day 15 :tz 'preserve)) + + ;; (1999 9:00 AM EST) March 10,11,12,13 + (let ((mar99 (ical:make-date-time :year 1999 :month 3 :day 10 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil))) + (list + mar99 + (ical:date-time-variant mar99 :day 11 :tz 'preserve) + (ical:date-time-variant mar99 :day 12 :tz 'preserve) + (ical:date-time-variant mar99 :day 13 :tz 'preserve)))) + :nonmembers + (list + ;; These match the rule but are excluded by the COUNT clause: + (ical:make-date-time :year 1999 :month 3 :day 14 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + (ical:make-date-time :year 1999 :month 3 :day 15 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/21) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;INTERVAL=2;BYDAY=TU\n" + "Every Tuesday, every other month" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1998 :month 4 :day 1 + :hour 0 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 2,9,16,23,30 + dtstart + (ical:date-time-variant dtstart :day 9 :tz 'preserve) + (ical:date-time-variant dtstart :day 16 :tz 'preserve) + (ical:date-time-variant dtstart :day 23 :tz 'preserve) + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + ;; (1997 9:00 AM EST) November 4,11,18,25 + (ical:date-time-variant dtstart :month 11 :day 4 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 11 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 11 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 25 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 6,13,20,27;March 3,10,17,24,31 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 6 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 13 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 20 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 1 :day 27 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 3 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 10 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 17 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 24 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 31 + :zone ict:est :dst nil)) + :nonmembers + ;; e.g. Tuesdays in December 1997: + (list + (ical:date-time-variant dtstart :month 12 :day 2 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 9 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 16 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 23 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 30 :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/22) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;COUNT=10;BYMONTH=6,7\n" + "Yearly in June and July for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 6 :day 10 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + ;; Note: Since none of the BYDAY, BYMONTHDAY, or BYYEARDAY + ;; clauses are specified, the month day is gotten from "DTSTART" + :members + ;; ==> (1997 9:00 AM EDT) June 10;July 10 + ;; (1998 9:00 AM EDT) June 10;July 10 + ;; (1999 9:00 AM EDT) June 10;July 10 + ;; (2000 9:00 AM EDT) June 10;July 10 + ;; (2001 9:00 AM EDT) June 10;July 10 + (mapcan + (lambda (y) + (list + (ical:date-time-variant dtstart :year y :month 6 :tz 'preserve) + (ical:date-time-variant dtstart :year y :month 7 :tz 'preserve))) + (number-sequence 1997 2001)) + :source rfc5545-sec3.8.5.3/23) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3\n" + "Every other year on January, February, and March for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 3 :day 10 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + ;; ==> (1997 9:00 AM EST) March 10 + ;; (1999 9:00 AM EST) January 10;February 10;March 10 + ;; (2001 9:00 AM EST) January 10;February 10;March 10 + ;; (2003 9:00 AM EST) January 10;February 10;March 10 + (cons + dtstart + ;; FIXME: this mapcan appears to produce a spurious warning: + (with-suppressed-warnings ((ignored-return-value mapcan)) + (mapcan + (lambda (y) + (list + (ical:date-time-variant dtstart :year y :month 1 :tz 'preserve) + (ical:date-time-variant dtstart :year y :month 2 :tz 'preserve) + (ical:date-time-variant dtstart :year y :month 3 :tz 'preserve))) + (list 1999 2001 2003)))) + :source rfc5545-sec3.8.5.3/24) + +(ict:rrule-test +"RRULE:FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200\n" +"Every third year on the 1st, 100th, and 200th day for 10 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 1 :day 1 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + + :members + (list + ;; ==> (1997 9:00 AM EST) January 1 + dtstart + ;; (1997 9:00 AM EDT) April 10;July 19 + (ical:date-time-variant dtstart :month 4 :day 10 :zone ict:edt :dst t) + (ical:date-time-variant dtstart :month 7 :day 19 :zone ict:edt :dst t) + ;; (2000 9:00 AM EST) January 1 + (ical:date-time-variant dtstart :year 2000 :tz 'preserve) + ;; (2000 9:00 AM EDT) April 9;July 18 + (ical:date-time-variant dtstart :year 2000 :month 4 :day 9 :zone ict:edt :dst t) + (ical:date-time-variant dtstart :year 2000 :month 7 :day 18 :zone ict:edt :dst t) + ;; (2003 9:00 AM EST) January 1 + (ical:date-time-variant dtstart :year 2003 :tz 'preserve) + ;; (2003 9:00 AM EDT) April 10;July 19 + (ical:date-time-variant dtstart :year 2003 :month 4 :day 10 :zone ict:edt :dst t) + (ical:date-time-variant dtstart :year 2003 :month 7 :day 19 :zone ict:edt :dst t) + ;; (2006 9:00 AM EST) January 1 + (ical:date-time-variant dtstart :year 2006 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/25) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;BYDAY=20MO\n" + "Every 20th Monday of the year, forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 5 :day 19 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) May 19 + ;; (1998 9:00 AM EDT) May 18 + ;; (1999 9:00 AM EDT) May 17 + ;; ... + dtstart + (ical:date-time-variant dtstart :year 1998 :day 18 :tz 'preserve) + (ical:date-time-variant dtstart :year 1999 :day 17 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/26) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO\n" + "Every year on Monday in Week 20 (where the week starts Monday), forever" + :tz ict:tz-eastern + :dtstart + (ical:make-date-time :year 1997 :month 5 :day 12 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + (ical:date-time-variant dtstart :year 1998 :day 11 :tz 'preserve) + (ical:date-time-variant dtstart :year 1999 :day 17 :tz 'preserve)) + :nonmembers + (list + (ical:date-time-variant dtstart :year 1998 :day 12 :tz 'preserve) ; a Tuesday + (ical:date-time-variant dtstart :year 1998 :day 18 :tz 'preserve)) ; wrong weekno + :source rfc5545-sec3.8.5.3/27) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=TH\n" + "Every Thursday in March, forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 3 :day 13 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (append + ;; ==> (1997 9:00 AM EST) March 13,20,27 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :day d :tz 'preserve)) + (list 13 20 27)) + ;; (1998 9:00 AM EST) March 5,12,19,26 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1998 :day d :tz 'preserve)) + (list 5 12 19 26)) + ;; (1999 9:00 AM EST) March 4,11,18,25 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1999 :day d :tz 'preserve)) + (list 4 11 18 25))) + :source rfc5545-sec3.8.5.3/28) + +(ict:rrule-test +"RRULE:FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8\n" +"Every Thursday, but only during June, July, and August, forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 6 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + ;; ==> (1997 9:00 AM EDT) June 5,12,19,26;July 3,10,17,24,31; + ;; August 7,14,21,28 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :day d :tz 'preserve)) + (list 5 12 19 26)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :month 7 :day d :tz 'preserve)) + (list 3 10 17 24 31)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :month 8 :day d :tz 'preserve)) + (list 7 14 21 28)) + ;; (1998 9:00 AM EDT) June 4,11,18,25;July 2,9,16,23,30; + ;; August 6,13,20,27 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1998 :day d :tz 'preserve)) + (list 4 11 18 25)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1998 :month 7 :day d :tz 'preserve)) + (list 2 9 16 23 30)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1998 :month 8 :day d :tz 'preserve)) + (list 6 13 20 27)) + ;; (1999 9:00 AM EDT) June 3,10,17,24;July 1,8,15,22,29; + ;; August 5,12,19,26 + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1999 :day d :tz 'preserve)) + (list 3 10 17 24)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1999 :month 7 :day d :tz 'preserve)) + (list 1 8 15 22 29)) + (mapcar + (lambda (d) + (ical:date-time-variant dtstart :year 1999 :month 8 :day d :tz 'preserve)) + (list 5 12 19 26))) + :source rfc5545-sec3.8.5.3/29) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13\n" + "Every Friday the 13th, forever, *excluding* DTSTART " + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 2000 :month 10 :day 14 + :hour 0 :minute 0 :second 0 + :zone ict:edt :dst t) + :exdates (list dtstart) + :members + (list + ;; ==> (1998 9:00 AM EST) February 13;March 13;November 13 + ;; (1999 9:00 AM EDT) August 13 + ;; (2000 9:00 AM EDT) October 13 + ;; ... + (ical:date-time-variant dtstart :year 1998 :month 2 :day 13 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 13 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 11 :day 13 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1999 :month 8 :day 13 :tz 'preserve) + (ical:date-time-variant dtstart :year 2000 :month 10 :day 13 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/30) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=7,8,9,10,11,12,13\n" + "The first Saturday that follows the first Sunday of the month, forever" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 13 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1998 :month 6 :day 14 + :hour 0 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 13;October 11 + dtstart + (ical:date-time-variant dtstart :month 10 :day 11 :tz 'preserve) + ;; (1997 9:00 AM EST) November 8;December 13 + (ical:date-time-variant dtstart :month 11 :day 8 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 13 :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 10;February 7;March 7 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 10 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 7 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 7 + :zone ict:est :dst nil) + ;; (1998 9:00 AM EDT) April 11;May 9;June 13... + (ical:date-time-variant dtstart :year 1998 :month 4 :day 11 :tz 'preserve) + (ical:date-time-variant dtstart :year 1998 :month 5 :day 9 :tz 'preserve) + (ical:date-time-variant dtstart :year 1998 :month 6 :day 13 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/31) + +(ict:rrule-test + "RRULE:FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=2,3,4,5,6,7,8\n" + "Every 4 years, the first Tuesday after a Monday in November, forever +(U.S. Presidential Election day)" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1996 :month 11 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + + :members + (list + ;; ==> (1996 9:00 AM EST) November 5 + dtstart + ;; (2000 9:00 AM EST) November 7 + (ical:date-time-variant dtstart :year 2000 :day 7 :tz 'preserve) + ;; (2004 9:00 AM EST) November 2 + (ical:date-time-variant dtstart :year 2004 :day 2 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/32) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3\n" + "The third instance into the month of one of Tuesday, Wednesday, or +Thursday, for the next 3 months" + ;; TODO: Yikes, why is this so slow?? + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 4 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + + :members + (list + ;; ==> (1997 9:00 AM EDT) September 4;October 7 + ;; (1997 9:00 AM EST) November 6 + dtstart + (ical:date-time-variant dtstart :month 10 :day 7 :tz 'preserve) + (ical:date-time-variant dtstart :month 11 :day 6 :zone ict:est :dst nil)) +:source rfc5545-sec3.8.5.3/33) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2\n" + "The second-to-last weekday of the month" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 29 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1998 :month 4 :day 1 + :hour 0 :minute 0 :second 0 + :zone ict:est :dst nil) + :members + (list + ;; ==> (1997 9:00 AM EDT) September 29 + dtstart + ;; (1997 9:00 AM EST) October 30;November 27;December 30 + (ical:date-time-variant dtstart :month 10 :day 30 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 11 :day 27 :zone ict:est :dst nil) + (ical:date-time-variant dtstart :month 12 :day 30 :zone ict:est :dst nil) + ;; (1998 9:00 AM EST) January 29;February 26;March 30 + (ical:date-time-variant dtstart :year 1998 :month 1 :day 29 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 2 :day 26 + :zone ict:est :dst nil) + (ical:date-time-variant dtstart :year 1998 :month 3 :day 30 + :zone ict:est :dst nil)) + :source rfc5545-sec3.8.5.3/34) + +(ict:rrule-test + ;; corrected, see Errata ID 3883: https://www.rfc-editor.org/errata/eid3883 + "RRULE:FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T210000Z\n" + "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + + :members + (list + ;; ==> (September 2, 1997 EDT) 09:00,12:00,15:00 + dtstart + (ical:date-time-variant dtstart :hour 12 :tz 'preserve) + (ical:date-time-variant dtstart :hour 15 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/35) + +(ict:rrule-test + "RRULE:FREQ=MINUTELY;INTERVAL=15;COUNT=6\n" + "Every 15 minutes for 6 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + + :members + (list + ;; ==> (September 2, 1997 EDT) 09:00,09:15,09:30,09:45,10:00,10:15 + dtstart + (ical:date-time-variant dtstart :minute 15 :tz 'preserve) + (ical:date-time-variant dtstart :minute 30 :tz 'preserve) + (ical:date-time-variant dtstart :minute 45 :tz 'preserve) + (ical:date-time-variant dtstart :hour 10 :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour 10 :minute 15 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/36) + +(ict:rrule-test + "RRULE:FREQ=MINUTELY;INTERVAL=90;COUNT=4\n" + "Every hour and a half for 4 occurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (September 2, 1997 EDT) 09:00,10:30;12:00;13:30 + dtstart + (ical:date-time-variant dtstart :hour 10 :minute 30 :tz 'preserve) + (ical:date-time-variant dtstart :hour 12 :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour 13 :minute 30 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/37) + +(ict:rrule-test + "RRULE:FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=0,20,40\n" + "Every 20 minutes from 9:00 AM to 4:40 PM every day" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1997 :month 9 :day 4 + :hour 0 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + ;; ==> (September 2, 1997 EDT) 9:00,9:20,9:40,10:00,10:20, + ;; ... 16:00,16:20,16:40 + (mapcan + (lambda (h) + (list + (ical:date-time-variant dtstart :hour h :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :minute 20 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :minute 40 :tz 'preserve))) + (number-sequence 9 16)) + ;; (September 3, 1997 EDT) 9:00,9:20,9:40,10:00,10:20, + ;; ...16:00,16:20,16:40 + (mapcan + (lambda (h) + (list + (ical:date-time-variant dtstart :hour h :day 3 :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :day 3 :minute 20 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :day 3 :minute 40 :tz 'preserve))) + (number-sequence 9 16))) + :source rfc5545-sec3.8.5.3/38) + +(ict:rrule-test + "RRULE:FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16\n" + "Every 20 minutes from 9:00 AM to 4:40 PM every day +(Alternative rule for the previous example)" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :high (ical:make-date-time :year 1997 :month 9 :day 4 + :hour 0 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (append + ;; ==> (September 2, 1997 EDT) 9:00,9:20,9:40,10:00,10:20, + ;; ... 16:00,16:20,16:40 + (mapcan + (lambda (h) + (list + (ical:date-time-variant dtstart :hour h :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :minute 20 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :minute 40 :tz 'preserve))) + (number-sequence 9 16)) + ;; (September 3, 1997 EDT) 9:00,9:20,9:40,10:00,10:20, + ;; ...16:00,16:20,16:40 + (mapcan + (lambda (h) + (list + (ical:date-time-variant dtstart :hour h :day 3 :minute 0 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :day 3 :minute 20 :tz 'preserve) + (ical:date-time-variant dtstart :hour h :day 3 :minute 40 :tz 'preserve))) + (number-sequence 9 16))) +:source rfc5545-sec3.8.5.3/39) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO\n" + "An example where the days generated makes a difference because of WKST: +every other week on Tuesday and Sunday, week start Monday, for four recurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 8 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 EDT) August 5,10,19,24 + dtstart + (ical:date-time-variant dtstart :day 10 :tz 'preserve) + (ical:date-time-variant dtstart :day 19 :tz 'preserve) + (ical:date-time-variant dtstart :day 24 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/40) + +(ict:rrule-test + "RRULE:FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU\n" + "An example where the days generated makes a difference because of WKST: +every other week on Tuesday and Sunday, week start Sunday, for four recurrences" + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 1997 :month 8 :day 5 + :hour 9 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (1997 EDT) August 5,17,19,31 + dtstart + (ical:date-time-variant dtstart :day 17 :tz 'preserve) + (ical:date-time-variant dtstart :day 19 :tz 'preserve) + (ical:date-time-variant dtstart :day 31 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/41) + +(ict:rrule-test + "RRULE:FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5\n" + "An example where an invalid date (i.e., February 30) is ignored." + :tz ict:tz-eastern + :dtstart (ical:make-date-time :year 2007 :month 1 :day 15 + :hour 9 :minute 0 :second 0 + :zone ict:est :dst nil) + :high (ical:make-date-time :year 2007 :month 4 :day 1 + :hour 0 :minute 0 :second 0 + :zone ict:edt :dst t) + :members + (list + ;; ==> (2007 EST) January 15,30 + ;; (2007 EST) February 15 + ;; (2007 EDT) March 15,30 + dtstart + (ical:date-time-variant dtstart :day 30 :tz 'preserve) + (ical:date-time-variant dtstart :month 2 :day 15 :tz 'preserve) + (ical:date-time-variant dtstart :month 3 :day 15 :zone ict:edt :dst t) + (ical:date-time-variant dtstart :month 3 :day 30 :zone ict:edt :dst t)) + :nonmembers + (list + (ical:date-time-variant dtstart :month 2 :day 28 :tz 'preserve) + (ical:date-time-variant dtstart :month 2 :day 30 :tz 'preserve)) + :source rfc5545-sec3.8.5.3/42) + +;; Local Variables: +;; read-symbol-shorthands: (("ict:" . "icalendar-test-") ("icr:" . "icalendar-recur-") ("ical:" . "icalendar-")) +;; End: +;;; icalendar-recur-tests.el ends here diff --git a/test/lisp/calendar/icalendar-resources/import-legacy-function.ics b/test/lisp/calendar/icalendar-resources/import-legacy-function.ics new file mode 100644 index 00000000000..760131b8192 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-legacy-function.ics @@ -0,0 +1,16 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:Testing legacy `icalendar-import-format' function +DESCRIPTION:described +CLASS:private +LOCATION:somewhere +ORGANIZER;CN="Baz Foo":mailto:baz@example.com +STATUS:CONFIRMED +URL:http://example.com/foo/baz +UID:some-unique-id-here +DTSTART;VALUE=DATE-TIME:20250919T090000 +DTEND;VALUE=DATE-TIME:20250919T113000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-legacy-vars.ics b/test/lisp/calendar/icalendar-resources/import-legacy-vars.ics new file mode 100644 index 00000000000..8aa80277b09 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-legacy-vars.ics @@ -0,0 +1,16 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:Testing legacy `icalendar-import-format*' vars +DESCRIPTION:described +CLASS:private +LOCATION:somewhere +ORGANIZER;CN="Baz Foo":mailto:baz@example.com +STATUS:CONFIRMED +URL:http://example.com/foo/baz +UID:some-unique-id-here +DTSTART;VALUE=DATE-TIME:20250919T090000 +DTEND;VALUE=DATE-TIME:20250919T113000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics index 4efa8ffa133..53380b9734d 100644 --- a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics @@ -1,9 +1,8 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:non-recurring allday -DTSTART;VALUE=DATE-TIME:20030919 -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:non-recurring allday +DTSTART;VALUE=DATE:20030919 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics index 2996f494167..de402a29d26 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics @@ -1,11 +1,10 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -DTSTART;VALUE=DATE:20040815 -DTEND;VALUE=DATE:20040816 -SUMMARY:Maria Himmelfahrt -RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20040815 +SUMMARY:Maria Himmelfahrt +RRULE:FREQ=YEARLY +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics index 5284bf42d8b..350e1aa0f24 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics @@ -1,12 +1,11 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:rrule daily with exceptions -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY;INTERVAL=2 -EXDATE:20030921,20030925 -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule daily with exceptions +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +EXDATE;VALUE=DATE:20030921,20030925 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics b/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics index 6d013b0b4f6..93ed08065bc 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics @@ -1,11 +1,11 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:rrule daily -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY; -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics index b871658600a..9448ca058f8 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics @@ -1,11 +1,11 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:rrule monthly no end -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY; -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule monthly no end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics index d8a1fe2e5af..0434765d613 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics @@ -1,11 +1,10 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:rrule monthly with end -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY;UNTIL=20050819; -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule monthly with end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;UNTIL=20050819 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics index c3f0b8ae933..44b6f44e2e0 100644 --- a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics +++ b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics @@ -1,11 +1,11 @@ -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -SUMMARY:rrule weekly -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=WEEKLY; -END:VEVENT -END:VCALENDAR - +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule weekly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-time-format-12hr-blank.ics b/test/lisp/calendar/icalendar-resources/import-time-format-12hr-blank.ics new file mode 100644 index 00000000000..7f436df5391 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-time-format-12hr-blank.ics @@ -0,0 +1,9 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:12hr blank-padded +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-with-attachment.ics b/test/lisp/calendar/icalendar-resources/import-with-attachment.ics new file mode 100644 index 00000000000..0b1201714ef --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-attachment.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:f9fee9a0-1231-4984-9078-f1357db352db +SUMMARY:Has an attachment +ATTACH;VALUE=BINARY;FMTTYPE=text/plain;ENCODING=BASE64:R3JlZXRpbmdzISBJIGFt + IGEgYmFzZTY0LWVuY29kZWQgZmlsZQ== +DTSTART;VALUE=DATE-TIME:20030919T090000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-with-timezone.ics b/test/lisp/calendar/icalendar-resources/import-with-timezone.ics index 110a9835e41..0db619e4f0a 100644 --- a/test/lisp/calendar/icalendar-resources/import-with-timezone.ics +++ b/test/lisp/calendar/icalendar-resources/import-with-timezone.ics @@ -1,27 +1,27 @@ -BEGIN:VCALENDAR -BEGIN:VTIMEZONE -TZID:fictional, nonexistent, arbitrary -BEGIN:STANDARD -DTSTART:20100101T000000 -TZOFFSETFROM:+0200 -TZOFFSETTO:-0200 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 -END:STANDARD -BEGIN:DAYLIGHT -DTSTART:20101201T000000 -TZOFFSETFROM:-0200 -TZOFFSETTO:+0200 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 -END:DAYLIGHT -END:VTIMEZONE -BEGIN:VEVENT -SUMMARY:standardtime -DTSTART;TZID="fictional, nonexistent, arbitrary":20120115T120000 -DTEND;TZID="fictional, nonexistent, arbitrary":20120115T123000 -END:VEVENT -BEGIN:VEVENT -SUMMARY:daylightsavingtime -DTSTART;TZID="fictional, nonexistent, arbitrary":20121215T120000 -DTEND;TZID="fictional, nonexistent, arbitrary":20121215T123000 -END:VEVENT -END:VCALENDAR +BEGIN:VCALENDAR +BEGIN:VTIMEZONE +TZID:fictional +BEGIN:STANDARD +DTSTART:20100101T000000 +TZOFFSETFROM:+0200 +TZOFFSETTO:-0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20101201T000000 +TZOFFSETFROM:-0200 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +SUMMARY:standardtime +DTSTART;TZID=fictional:20120115T120000 +DTEND;TZID=fictional:20120115T123000 +END:VEVENT +BEGIN:VEVENT +SUMMARY:daylightsavingtime +DTSTART;TZID=fictional:20121215T120000 +DTEND;TZID=fictional:20121215T123000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 5e745c05d0a..05a999ec301 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -30,11 +30,34 @@ ;; Note: Watch the trailing blank that is added on import. ;;; Code: - (require 'ert) (require 'ert-x) (require 'icalendar) +;; Some variables in the icalendar-* namespace have now been aliased to +;; diary-icalendar-*: +(require 'diary-icalendar) + +(defmacro ical:deftest-obsolete (name _ &rest args-and-body) + "Define NAME as an obsolete icalendar.el test." + (let (args body) + (while (not body) + (cond ((stringp (car args-and-body)) + (push (pop args-and-body) args)) ; docstring + ((keywordp (car args-and-body)) + (push (pop args-and-body) args) ; keyword + (push (pop args-and-body) args)) ; value + (t + (setq body args-and-body) + (setq args (nreverse args))))) + `(ert-deftest ,name () ,@args + ;; These values were used by icalendar.el when tests were written: + (let ((icalendar-recurring-start-year 2005) + (icalendar-vcalendar-prodid "-//Emacs//NONSGML icalendar.el//EN") + (icalendar-uid-format "emacs%t%c") + (icalendar-export-hidden-diary-entries t)) + ,@body)))) + ;; ====================================================================== ;; Helpers ;; ====================================================================== @@ -75,7 +98,7 @@ ;; Tests of functions ;; ====================================================================== -(ert-deftest icalendar--create-uid () +(ical:deftest-obsolete icalendar--create-uid () "Test for `icalendar--create-uid'." (let* ((icalendar-uid-format "xxx-%c-%h-%u-%s") (icalendar--uid-count 77) @@ -92,7 +115,7 @@ (should (string= (concat "yyyDTSTARTyyy") (icalendar--create-uid entry-full contents))))) -(ert-deftest icalendar-convert-anniversary-to-ical () +(ical:deftest-obsolete icalendar-convert-anniversary-to-ical () "Test method for `icalendar--convert-anniversary-to-ical'." (let* ((calendar-date-style 'iso) result) @@ -106,7 +129,7 @@ (car result))) (should (string= "g" (cdr result))))) -(ert-deftest icalendar--convert-cyclic-to-ical () +(ical:deftest-obsolete icalendar--convert-cyclic-to-ical () "Test method for `icalendar--convert-cyclic-to-ical'." (let* ((calendar-date-style 'iso) result) @@ -119,7 +142,7 @@ (car result))) (should (string= "Sommerferien" (cdr result))))) -(ert-deftest icalendar--convert-block-to-ical () +(ical:deftest-obsolete icalendar--convert-block-to-ical () "Test method for `icalendar--convert-block-to-ical'." (let* ((calendar-date-style 'iso) result) @@ -132,7 +155,7 @@ (car result))) (should (string= "Sommerferien" (cdr result))))) -(ert-deftest icalendar--convert-float-to-ical () +(ical:deftest-obsolete icalendar--convert-float-to-ical () "Test method for `icalendar--convert-float-to-ical'." ;; See Bug#78085 (let* ((calendar-date-style 'iso) @@ -148,7 +171,7 @@ (car result))) (should (string= "1st Sat/month" (cdr result))))) -(ert-deftest icalendar--convert-yearly-to-ical () +(ical:deftest-obsolete icalendar--convert-yearly-to-ical () "Test method for `icalendar--convert-yearly-to-ical'." (let* ((calendar-date-style 'iso) result @@ -164,7 +187,7 @@ (car result))) (should (string= "Tag der Arbeit" (cdr result))))) -(ert-deftest icalendar--convert-weekly-to-ical () +(ical:deftest-obsolete icalendar--convert-weekly-to-ical () "Test method for `icalendar--convert-weekly-to-ical'." (let* ((calendar-date-style 'iso) result @@ -179,7 +202,7 @@ (car result))) (should (string= "subject" (cdr result))))) -(ert-deftest icalendar--convert-sexp-to-ical () +(ical:deftest-obsolete icalendar--convert-sexp-to-ical () "Test method for `icalendar--convert-sexp-to-ical'." (let* (result (icalendar-export-sexp-enumeration-days 3)) @@ -192,7 +215,7 @@ (should (string-match "Hebrew date (until sunset): .*" (cdr i)))) result))) -(ert-deftest icalendar--convert-to-ical () +(ical:deftest-obsolete icalendar--convert-to-ical () "Test method for `icalendar--convert-to-ical'." (let* (result (icalendar-export-sexp-enumerate-all t) @@ -216,7 +239,7 @@ (car (car result)))) (should (string-match "Newton's birthday" (cdr (car result)))))) -(ert-deftest icalendar--parse-vtimezone () +(ical:deftest-obsolete icalendar--parse-vtimezone () "Test method for `icalendar--parse-vtimezone'." (let (vtimezone result) ;; testcase: valid timezone with rrule @@ -290,7 +313,7 @@ END:VTIMEZONE ;; FIXME: add testcase that covers changes for fix of bug#34315 )) -(ert-deftest icalendar--convert-ordinary-to-ical () +(ical:deftest-obsolete icalendar--convert-ordinary-to-ical () "Test method for `icalendar--convert-ordinary-to-ical'." (let* ((calendar-date-style 'iso) result) @@ -328,7 +351,7 @@ END:VTIMEZONE (car result))) (should (string= "s" (cdr result))))) -(ert-deftest icalendar--diarytime-to-isotime () +(ical:deftest-obsolete icalendar--diarytime-to-isotime () "Test method for `icalendar--diarytime-to-isotime'." (should (string= "T011500" (icalendar--diarytime-to-isotime "01:15" ""))) @@ -361,7 +384,7 @@ END:VTIMEZONE (should (string= "T150000" (icalendar--diarytime-to-isotime "3" "pm")))) -(ert-deftest icalendar--datetime-to-diary-date () +(ical:deftest-obsolete icalendar--datetime-to-diary-date () "Test method for `icalendar--datetime-to-diary-date'." (let* ((datetime '(59 59 23 31 12 2008)) (calendar-date-style 'iso)) @@ -374,7 +397,7 @@ END:VTIMEZONE (should (string= "12 31 2008" (icalendar--datetime-to-diary-date datetime))))) -(ert-deftest icalendar--datestring-to-isodate () +(ical:deftest-obsolete icalendar--datestring-to-isodate () "Test method for `icalendar--datestring-to-isodate'." (let ((calendar-date-style 'iso)) ;; numeric iso @@ -427,7 +450,7 @@ END:VTIMEZONE (icalendar--datestring-to-isodate "2021 Feb 11" nil 80))) )) -(ert-deftest icalendar--first-weekday-of-year () +(ical:deftest-obsolete icalendar--first-weekday-of-year () "Test method for `icalendar-first-weekday-of-year'." (should (eq 1 (icalendar-first-weekday-of-year "TU" 2008))) (should (eq 3 (icalendar-first-weekday-of-year "WE" 2007))) @@ -439,7 +462,7 @@ END:VTIMEZONE (should (eq 3 (icalendar-first-weekday-of-year "MO" 2000))) (should (eq 1 (icalendar-first-weekday-of-year "TH" 1970)))) -(ert-deftest icalendar--import-format-sample () +(ical:deftest-obsolete icalendar--import-format-sample () "Test method for `icalendar-import-format-sample'." (should (string= (concat "SUMMARY='a' DESCRIPTION='b' LOCATION='c' " "ORGANIZER='d' STATUS='' URL='' CLASS=''") @@ -455,7 +478,7 @@ DESCRIPTION:b END:VEVENT "))))) -(ert-deftest icalendar--format-ical-event () +(ical:deftest-obsolete icalendar--format-ical-event () "Test `icalendar--format-ical-event'." (let ((icalendar-import-format "%s%d%l%o%t%u%c") (icalendar-import-format-summary "SUM %s") @@ -493,7 +516,7 @@ END:VEVENT (should (string= "-sum-des-loc-org-nil-nil-nil-" (icalendar--format-ical-event event))))) -(ert-deftest icalendar--parse-summary-and-rest () +(ical:deftest-obsolete icalendar--parse-summary-and-rest () "Test `icalendar--parse-summary-and-rest'." (let ((icalendar-import-format "%s%d%l%o%t%u%c") (icalendar-import-format-summary "SUM %s") @@ -521,7 +544,7 @@ END:VEVENT (should (not result)) )) -(ert-deftest icalendar--decode-isodatetime () +(ical:deftest-obsolete icalendar--decode-isodatetime () "Test `icalendar--decode-isodatetime'." (let ((tz (getenv "TZ"))) (unwind-protect @@ -571,7 +594,7 @@ END:VEVENT ;; restore time-zone even if something went terribly wrong (setenv "TZ" tz)))) -(ert-deftest icalendar--convert-tz-offset () +(ical:deftest-obsolete icalendar--convert-tz-offset () "Test `icalendar--convert-tz-offset'." (let ((tz (getenv "TZ"))) (unwind-protect @@ -634,7 +657,7 @@ END:VEVENT ;; restore time-zone even if something went terribly wrong (setenv "TZ" tz)))) -(ert-deftest icalendar--decode-isoduration () +(ical:deftest-obsolete icalendar--decode-isoduration () "Test `icalendar--decode-isoduration'." ;; testcase: 7 days @@ -764,7 +787,7 @@ END:VCALENDAR ;; cleanup!! (kill-buffer (find-buffer-visiting temp-file))))) -(ert-deftest icalendar-export-ordinary-no-time () +(ical:deftest-obsolete icalendar-export-ordinary-no-time () "Perform export test." (let ((icalendar-export-hidden-diary-entries nil)) @@ -783,7 +806,7 @@ DTEND;VALUE=DATE:20001004 SUMMARY:ordinary no time ")) -(ert-deftest icalendar-export-ordinary () +(ical:deftest-obsolete icalendar-export-ordinary () "Perform export test." (icalendar-tests--test-export @@ -812,7 +835,7 @@ DTEND;VALUE=DATE-TIME:20001003T173000 SUMMARY:ordinary with time 3 ")) -(ert-deftest icalendar-export-multiline () +(ical:deftest-obsolete icalendar-export-multiline () "Perform export test." ;; multiline -- FIXME!!! @@ -830,7 +853,7 @@ DESCRIPTION: 17:30 multiline continued FIXME ")) -(ert-deftest icalendar-export-weekly-by-day () +(ical:deftest-obsolete icalendar-export-weekly-by-day () "Perform export test." ;; weekly by day @@ -854,7 +877,7 @@ RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO SUMMARY:weekly by day with start and end time ")) -(ert-deftest icalendar-export-yearly () +(ical:deftest-obsolete icalendar-export-yearly () "Perform export test." ;; yearly (icalendar-tests--test-export @@ -867,7 +890,7 @@ RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1 SUMMARY:yearly no time ")) -(ert-deftest icalendar-export-anniversary () +(ical:deftest-obsolete icalendar-export-anniversary () "Perform export test." ;; anniversaries (icalendar-tests--test-export @@ -889,7 +912,7 @@ RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 SUMMARY:anniversary with time ")) -(ert-deftest icalendar-export-block () +(ical:deftest-obsolete icalendar-export-block () "Perform export test." ;; block (icalendar-tests--test-export @@ -919,7 +942,7 @@ RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 SUMMARY:block no end time ")) -(ert-deftest icalendar-export-alarms () +(ical:deftest-obsolete icalendar-export-alarms () "Perform export test with different settings for exporting alarms." ;; no alarm (icalendar-tests--test-export @@ -1016,7 +1039,7 @@ END:VALARM (defun icalendar-tests--diary-float (&rest args) (apply #'diary-float args)) -(ert-deftest icalendar-export-bug-56241-dotted-pair () +(ical:deftest-obsolete icalendar-export-bug-56241-dotted-pair () "See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=56241#5" ;; This test started failing early July 2023 without any apparent change ;; to the underlying code, so is probably sensitive to the current date. @@ -1029,7 +1052,7 @@ END:VALARM "%%(icalendar-tests--diary-float 7 0 1) First Sunday in July 2")))) -;; (ert-deftest icalendar-export-bug-56241-sexp-does-not-match () +;; (ical:deftest-obsolete icalendar-export-bug-56241-sexp-does-not-match () ;; "Reported in #bug56241 -- needs to be fixed!" ;; (let ((icalendar-export-sexp-enumeration-days 0)) ;; (mapc (lambda (diary-string) @@ -1038,7 +1061,7 @@ END:VALARM ;; '("%%(diary-float 7 0 1) First Sunday in July 1" ;; "%%(icalendar-tests--diary-float 7 0 1) First Sunday in July 2")))) -(ert-deftest icalendar-export-bug-56241-nested-sexps () +(ical:deftest-obsolete icalendar-export-bug-56241-nested-sexps () "Reported in #bug56241 -- needs to be fixed!" (let ((icalendar-export-sexp-enumeration-days 366)) (mapc (lambda (diary-string) @@ -1130,7 +1153,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." (should (string= expected-output result))) (kill-buffer (find-buffer-visiting temp-file))))) -(ert-deftest icalendar-import-non-recurring () +(ical:deftest-obsolete icalendar-import-non-recurring () "Perform standard import tests." (icalendar-tests--test-import "import-non-recurring-1.ics" "import-non-recurring-1.diary-iso" @@ -1158,7 +1181,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." "import-non-recurring-another-example.diary-american")) -(ert-deftest icalendar-import-rrule () +(ical:deftest-obsolete icalendar-import-rrule () (icalendar-tests--test-import "import-rrule-daily.ics" "import-rrule-daily.diary-iso" "import-rrule-daily.diary-european" @@ -1217,7 +1240,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." "import-rrule-count-every-second-year.diary-american") ) -(ert-deftest icalendar-import-duration () +(ical:deftest-obsolete icalendar-import-duration () (icalendar-tests--test-import "import-duration.ics" "import-duration.diary-iso" "import-duration.diary-european" @@ -1228,41 +1251,41 @@ Argument EXPECTED-OUTPUT file containing expected diary string." "import-duration-2.diary-european" "import-duration-2.diary-american")) -(ert-deftest icalendar-import-bug-6766 () +(ical:deftest-obsolete icalendar-import-bug-6766 () ;;bug#6766 -- multiple byday values in a weekly rrule (icalendar-tests--test-import "import-bug-6766.ics" "import-bug-6766.diary-iso" "import-bug-6766.diary-european" "import-bug-6766.diary-american")) -(ert-deftest icalendar-import-bug-24199 () +(ical:deftest-obsolete icalendar-import-bug-24199 () ;;bug#24199 -- monthly rule with byday-clause (icalendar-tests--test-import "import-bug-24199.ics" "import-bug-24199.diary-iso" "import-bug-24199.diary-european" "import-bug-24199.diary-american")) -(ert-deftest icalendar-import-bug-33277 () +(ical:deftest-obsolete icalendar-import-bug-33277 () ;;bug#33277 -- start time equals end time (icalendar-tests--test-import "import-bug-33277.ics" "import-bug-33277.diary-iso" "import-bug-33277.diary-european" "import-bug-33277.diary-american")) -(ert-deftest icalendar-import-multiple-vcalendars () +(ical:deftest-obsolete icalendar-import-multiple-vcalendars () (icalendar-tests--test-import "import-multiple-vcalendars.ics" "import-multiple-vcalendars.diary-iso" "import-multiple-vcalendars.diary-european" "import-multiple-vcalendars.diary-american")) -(ert-deftest icalendar-import-with-uid () +(ical:deftest-obsolete icalendar-import-with-uid () "Perform import test with uid." (icalendar-tests--test-import "import-with-uid.ics" "import-with-uid.diary-iso" "import-with-uid.diary-european" "import-with-uid.diary-american")) -(ert-deftest icalendar-import-with-timezone () +(ical:deftest-obsolete icalendar-import-with-timezone () ;; This is known to fail on MS-Windows, because the test assumes ;; Posix features of specifying DST rules. :expected-result (if (memq system-type '(windows-nt ms-dos)) @@ -1334,7 +1357,7 @@ Argument INPUT icalendar event string." (set-buffer-modified-p nil) (kill-buffer (current-buffer)))))))) -(ert-deftest icalendar-cycle () +(ical:deftest-obsolete icalendar-cycle () "Perform cycling tests. Take care to avoid auto-generated UIDs here." (icalendar-tests--test-cycle @@ -1363,7 +1386,7 @@ SUMMARY:and diary-anniversary ;; ====================================================================== ;; Real world ;; ====================================================================== -(ert-deftest icalendar-real-world () +(ical:deftest-obsolete icalendar-real-world () "Perform real-world tests, as gathered from problem reports." ;; This is known to fail on MS-Windows, since it doesn't support DST ;; specification with month and day. @@ -1506,7 +1529,7 @@ RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 SUMMARY:ff birthday (%d years old)") ;; FIXME: this testcase verifies that icalendar-export fails to - ;; export the nested sexp. After repairing bug56241 icalendar-export + ;; export the nested sexp. After repairing bug56241 icalendar-export ;; works correctly for this sexp but now the testcase fails. ;; Therefore this testcase is disabled for the time being. ;; (icalendar-tests--test-export @@ -1702,7 +1725,7 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(ert-deftest icalendar-tests--decode-isodatetime () +(ical:deftest-obsolete icalendar-tests--decode-isodatetime () "Test `icalendar--decode-isodatetime'." (should (equal (icalendar-test--format "20040917T050910-02:00") "2004-09-17T03:09:10+0000")) @@ -1728,4 +1751,8 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 "2004-09-17T06:09:10+0000"))) (provide 'icalendar-tests) +;; Local Variables: +;; read-symbol-shorthands: (("ical:" . "icalendar-")) +;; byte-compile-warnings: (not obsolete) +;; End: ;;; icalendar-tests.el ends here From 004479e05255478272087d2d7e210c793061fcec Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Mon, 22 Dec 2025 12:52:08 +0100 Subject: [PATCH 020/191] Allow CRLF line endings in iCalendar (.ics) test files Thanks to Jim Porter for feedback in Bug#74994. * .gitattributes: Allow CRLF endings in iCalendar test files. --- .gitattributes | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitattributes b/.gitattributes index 5c0a591385f..06d4e0400d3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -25,6 +25,7 @@ admin/charsets/mapfiles/PTCP154 whitespace=cr-at-eol test/manual/etags/c-src/dostorture.c whitespace=cr-at-eol test/manual/etags/cp-src/c.C whitespace=cr-at-eol test/manual/etags/html-src/algrthms.html whitespace=cr-at-eol +test/lisp/calendar/icalendar-resources/*.ics whitespace=cr-at-eol # The todo-mode file format includes trailing whitespace. *.tod[aorty] -whitespace=blank-at-eol From f37efe5e9438722058b6e1bc566931c007d1ead9 Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Sun, 21 Dec 2025 08:52:25 +0100 Subject: [PATCH 021/191] iCalendar code improvements Thanks to Stefan Monnier for the comments in Bug#74994 leading to most of these changes. Improvements in diary-icalendar.el and related changes: * lisp/calendar/diary-icalendar.el (icalendar-save-binary-atttachment): Rename to `diary-icalendar-save-binary-attachment'. Document internal require. (diary-icalendar-attendee-skeleton-command): Rename to `diary-icalendar-attendee-format-function'. (diary-icalendar-vevent-skeleton-command): Rename to `diary-icalendar-vevent-format-function'. (diary-icalendar-vjournal-skeleton-command): Rename to `diary-icalendar-vjournal-format-function'. (diary-icalendar-vtodo-skeleton-command): Rename to `diary-icalendar-vtodo-format-function'. * doc/emacs/calendar.texi (Diary iCalendar Import) * lisp/calendar/icalendar.el (icalendar-import-format) (icalendar-import-format-summary, icalendar-import-format-description) (icalendar-import-format-location, icalendar-import-format-organizer) (icalendar-import-format-url, icalendar-import-format-uid) (icalendar-import-format-status, icalendar-import-format-class): Update references to renamed functions. (diary-icalendar-attendee-format-function): Fix quoted function name. (diary-icalendar-attendee-format-function) (diary-icalendar-vevent-format-function) (diary-icalendar-vjournal-format-function) (diary-icalendar-vtodo-format-function) (diary-icalendar-after-mailcap-viewer-hook): Improve docstrings. (diary-icalendar-skip-addresses-regexp): Ensure default value is a regexp. (diary-icalendar-description-regexp): Fix :type declaration to agree with default. (diary-icalendar-format-date): Replace unnecessary `calendar-dlet' with `dlet'. (diary-icalendar-vevent-format-function) (diary-icalendar-vjournal-format-function) (diary-icalendar-vtodo-format-function) (diary-icalendar-format-entry) (diary-icalendar-import-buffer-to-buffer) (diary-icalendar--entry-import) (diary-icalendar-import-buffer) (diary-icalendar-import-file): Change "non-marking" to "nonmarking" in variable names for consistency (cf. `diary-nonmarking-symbol'). (diary-icalendar-attendee-skeleton): Remove unnecessary call to `skeleton-insert'. (diary-icalendar-vevent-skeleton) (diary-icalendar-vjournal-skeleton) (diary-icalendar-vtodo-skeleton): Don't insert return values of `let' forms. (diary-icalendar-parse-entry): Call `diary-icalendar-other-properties-parser' with type and properties as arguments, instead of dynamic binding. (diary-icalendar-other-properties-parser): Document the new calling convention. * test/lisp/calendar/diary-icalendar-tests.el (diary-icalendar-test-parse-@-location): Accept the new arguments. Clarify `declare-function' usage: * lisp/calendar/icalendar-parser.el (icalendar-read-time) (icalendar-period-end, icalendar-parse-calendar) (icalendar-index-insert, icalendar-index-get) * lisp/calendar/icalendar-ast.el (icalendar-printable-value-type-symbol-p) (icalendar-ast-node-valid-value-p) * lisp/calendar/icalendar-utils.el (icalendar-date-time-add) (icalendar-dates-until, icalendar-date-time-variant): Move `declare-function' forms to corresponding `require' forms. Improve debugging with icalendar-ast.el macros: * lisp/calendar/icalendar-ast.el (icalendar-make-value-node-of): Add explanatory comment to require. (icalendar--make-param--list, icalendar--make-param--nonlist) (icalendar--make-property--list, icalendar--make-property--nonlist): New functions. (icalendar-make-param, icalendar-make-property): Use them to reduce code generated by these macros. Add (declare (debug ...)) forms. (icalendar-make-component, icalendar-make-node-from-templates): Add (declare (debug ...)) forms. * test/lisp/calendar/icalendar-ast-tests.el: New file. Various other minor changes: * lisp/calendar/icalendar-macs.el (icalendar-define-type): Improve docstring. (icalendar-define-property): Fix deprecation warning: replace 'any' with 'not-newline' in rx definition. * test/lisp/calendar/icalendar-recur-tests.el (icalendar-test-rrule-test): Pass tags on to `ert-deftest' and mark several tests as expensive. * lisp/calendar/calendar.el (diary-date-insertion-form): Remove constants from :set-after list. * lisp/calendar/diary-lib.el (diary-time-regexp): Clarify FIXME comment. * lisp/calendar/icalendar-parser.el (icalendar-x-name): Fix indentation. (icalendar-cal-address): Improve docstring. --- doc/emacs/calendar.texi | 16 +- lisp/calendar/calendar.el | 4 +- lisp/calendar/diary-icalendar.el | 198 ++++++++++---------- lisp/calendar/diary-lib.el | 5 +- lisp/calendar/icalendar-ast.el | 125 +++++++----- lisp/calendar/icalendar-macs.el | 4 +- lisp/calendar/icalendar-parser.el | 44 +++-- lisp/calendar/icalendar-utils.el | 14 +- lisp/calendar/icalendar.el | 18 +- test/lisp/calendar/diary-icalendar-tests.el | 3 +- test/lisp/calendar/icalendar-ast-tests.el | 112 +++++++++++ test/lisp/calendar/icalendar-recur-tests.el | 7 + 12 files changed, 349 insertions(+), 201 deletions(-) create mode 100644 test/lisp/calendar/icalendar-ast-tests.el diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 74dada809a5..ff88f4e426e 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -1612,14 +1612,14 @@ they are imported by different functions, determined by the following variables: @vtable @code -@item diary-icalendar-vevent-skeleton-command +@item diary-icalendar-vevent-format-function Function to format VEVENT components for the diary. -@item diary-icalendar-vtodo-skeleton-command -Function to format VTODO components for the diary. - -@item diary-icalendar-vjournal-skeleton-command +@item diary-icalendar-vjournal-format-function Function to format VJOURNAL components for the diary. + +@item diary-icalendar-vtodo-format-function +Function to format VTODO components for the diary. @end vtable You can customize the format of the imported diary entries by writing @@ -1640,7 +1640,7 @@ like: @noindent Then you could write the import formatting function as a skeleton and -set it to the value of @code{diary-icalendar-vevent-skeleton-command} as +set it to the value of @code{diary-icalendar-vevent-format-function} as follows: @lisp @@ -1653,14 +1653,14 @@ follows: start-to-end & " " & summary & " " (when location "@@ ") & location "\n") -(setopt diary-icalendar-vevent-skeleton-command #'simple-vevent) +(setopt diary-icalendar-vevent-format-function #'simple-vevent) @end group @end lisp The variables @code{start-to-end}, @code{summary} and @code{location} in this example are dynamically bound to appropriate values when the skeleton is called. See the docstring of -@code{diary-icalendar-vevent-skeleton-command} for more information. +@code{diary-icalendar-vevent-format-function} for more information. Any errors encountered during import will be reported in a buffer named @file{*icalendar-errors*}. You can review these errors with the diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 858564999ce..b9fb0f562fd 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -944,9 +944,7 @@ including those inserted into the diary from the calendar with :version "31.1" :type 'sexp :risky t - :set-after '(calendar-date-style diary-american-date-insertion-form - diary-european-date-insertion-form - diary-iso-date-insertion-form) + :set-after '(calendar-date-style) :group 'diary) ;; Next three are provided to aid in setting calendar-date-display-form. diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index 08fff66fe58..7bb6f12ca42 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -73,10 +73,10 @@ asked to confirm." (defcustom di:after-mailcap-viewer-hook nil "Hook run after `diary-icalendar-mailcap-viewer'. -The functions in this hook will be run after formatting the contents of -iCalendar data as diary entries in a temporary buffer. You can add -functions to this hook if you want, for example, to copy these entries -somewhere else." +The functions in this hook will be run in a temporary buffer after +formatting the contents of iCalendar data as diary entries in that +buffer. You can add functions to this hook if you want, for example, to +copy these entries somewhere else." :version "31.1" :type '(hook)) @@ -108,12 +108,12 @@ start of the imported entry.) Examples: :version "31.1" :type '(string)) -(defcustom di:attendee-skeleton-command 'di:attendee-skeleton +(defcustom di:attendee-format-function #'di:attendee-skeleton "Function to format ATTENDEE properties during diary import. -This should be a symbol naming a function which inserts information -about an `icalendar-attendee' into the current buffer. It is convenient -to express such a function as a skeleton; see `define-skeleton' and +This should be a function which inserts information about an +`icalendar-attendee' into the current buffer. It is convenient to +express such a function as a skeleton; see `define-skeleton' and `skeleton-insert' for more information. The function will be called with no arguments and should insert @@ -150,7 +150,8 @@ sentby-full-address - like sentby-address, but nothing removed" :type '(radio (function-item di:attendee-skeleton) (function :tag "Other function"))) -(defcustom di:skip-addresses-regexp user-mail-address +(defcustom di:skip-addresses-regexp + (concat "\\<" (regexp-quote user-mail-address) "\\'") "Regular expression matching addresses to skip when importing. This regular expression should match calendar addresses (which are @@ -159,15 +160,15 @@ ATTENDEE, ORGANIZER, and other iCalendar properties that identify a contact. You can make this match your own email address(es) to prevent them from -being formatted by `diary-icalendar-attendee-skeleton-command' and +being formatted by `diary-icalendar-attendee-format-function' and listed in diary entries." :version "31.1" :type '(regexp)) -(defcustom di:vevent-skeleton-command #'di:vevent-skeleton +(defcustom di:vevent-format-function #'di:vevent-skeleton "Function to format VEVENT components for the diary. -This should be a symbol naming a function which inserts information +This function is called with no arguments and should insert information about an `icalendar-vevent' into the current buffer. It is convenient to express such a function as a skeleton; see `define-skeleton' and `skeleton-insert' for more information. @@ -179,10 +180,10 @@ alarms (list of `icalendar-valarm' nodes) - notifications in the event as-alarm (symbol) - non-nil when the event should be formatted for an alarm notification in advance of the event. The symbol indicates the type of alarm: `email' means to format the event as the body of an email. - (Currently only used for EMAIL alarms; see `icalendar-export-alarms'.) + (Currently only used for EMAIL alarms; see `diary-icalendar-export-alarms'.) attachments (list of strings) - URLs or filenames of attachments in the event attendees (list of strings) - the participants of the event, - formatted by `diary-icalendar-attendee-skeleton-command' + formatted by `diary-icalendar-attendee-format-function' categories (list of strings) - categories specified in the event access - the event's access classification comments (list of strings) - comments specified in the event @@ -219,9 +220,9 @@ last-modified-dt (an `icalendar-date-time' value) - the date and time the event was last modified last-modified - last-modified-dt, formatted as a local date and time string location - the event's location -non-marking (a boolean) - if non-nil, the diary entry should be non-marking +nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking organizer - the event's organizer, formatted by - `diary-icalendar-attendee-skeleton-command' + `diary-icalendar-attendee-format-function' priority (a number) - the event's priority (1 = highest priority, 9 = lowest; 0 = undefined) recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the @@ -246,12 +247,12 @@ url - a URL for the event" :type '(radio (function-item di:vevent-skeleton) (function :tag "Other function"))) -(defcustom di:vjournal-skeleton-command #'di:vjournal-skeleton +(defcustom di:vjournal-format-function #'di:vjournal-skeleton "Function to format VJOURNAL components for the diary. -This should be a symbol naming a function which inserts information about -an `icalendar-vjournal' into the current buffer. It is convenient to -express such a function as a skeleton; see `define-skeleton' and +This function is called with no arguments and should insert information +about an `icalendar-vjournal' into the current buffer. It is convenient +to express such a function as a skeleton; see `define-skeleton' and `skeleton-insert' for more information, and see `diary-icalendar-vjournal-skeleton' for an example. @@ -262,7 +263,7 @@ alarms (list of `icalendar-valarm' nodes) - notifications in the journal entry attachments (list of strings) - URLs or filenames of attachments in the journal entry attendees (list of strings) - the participants of the journal entry, - formatted by `diary-icalendar-attendee-skeleton-command' + formatted by `diary-icalendar-attendee-format-function' categories (list of strings) - categories specified in the journal entry access - the journal entry's access classification comments (list of strings) - comments specified in the journal entry @@ -285,9 +286,9 @@ importing (a boolean) - t if the journal entry should be formatted for import. last-modified-dt (an `icalendar-date-time' value) - the date and time the journal entry was last modified last-modified - last-modified-dt, formatted as a local date and time string -non-marking (a boolean) - if non-nil, the diary entry should be non-marking +nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking organizer - the journal entry's organizer, formatted by - `diary-icalendar-attendee-skeleton-command' + `diary-icalendar-attendee-format-function' recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the date or date-time of a particular recurrence of the journal entry recurrence-id - recurrence-id-dt, formatted as a local date and time string @@ -321,11 +322,11 @@ information." :type '(choice (const :tag "Import as nonmarking entries" t) (const :tag "Import as normal (marking) entries" nil))) -(defcustom di:vtodo-skeleton-command #'di:vtodo-skeleton +(defcustom di:vtodo-format-function #'di:vtodo-skeleton "Function to format VTODO components for the diary. -This should be a symbol naming a function which inserts information about -an `icalendar-vtodo' into the current buffer. It is convenient to +This function is called with no arguments and should insert information +about an `icalendar-vtodo' into the current buffer. It is convenient to express such a function as a skeleton; see `define-skeleton' and `skeleton-insert' for more information. @@ -336,10 +337,10 @@ alarms (list of `icalendar-valarm' nodes) - notifications in the task as-alarm (symbol) - non-nil when the task should be formatted for an alarm notification in advance of the task. The symbol indicates the type of alarm: `email' means to format the task as the body of an email. - (Currently only used for EMAIL alarms; see `icalendar-export-alarms'.) + (Currently only used for EMAIL alarms; see `diary-icalendar-export-alarms'.) attachments (list of strings) - URLs or filenames of attachments in the task attendees (list of strings) - the participants of the task, - formatted by `diary-icalendar-attendee-skeleton-command' + formatted by `diary-icalendar-attendee-format-function' categories (list of strings) - categories specified in the task access - the task's access classification comments (list of strings) - comments specified in the task @@ -383,9 +384,9 @@ last-modified-dt (an `icalendar-date-time' value) - the date and time the task was last modified last-modified - last-modified-dt, formatted as a local date and time string location - the task's location -non-marking (a boolean) - if non-nil, the diary entry should be non-marking +nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking organizer - the task's organizer, formatted by - `diary-icalendar-attendee-skeleton-command' + `diary-icalendar-attendee-format-function' percent-complete (a number between 0 and 100) - the percentage of the task which has already been completed priority (a number) - the task's priority (1 = highest priority, 9 = lowest; @@ -475,7 +476,9 @@ variable if you want to export diary entries where the text to be used as the description should not include the full entry body. In that case, the description should match group 1 of this regexp." :version "31.1" - :type '(regexp)) + :type '(radio + (const :tag "Use full entry body" nil) + (regexp :tag "Regexp"))) (defcustom di:organizer-regexp (rx line-start @@ -863,25 +866,25 @@ set this to a function which parses that format to iCalendar properties during iCalendar export, so that other calendar applications can use them. -The parsing function will be called with no arguments, with the current -restriction set to the boundaries of a diary entry. If -`diary-icalendar-export-linewise' is true, the restriction will -correspond to a single event in a multi-line diary entry. +The parsing function will be called with the current restriction set to +the boundaries of a diary entry. If `diary-icalendar-export-linewise' +is non-nil, the restriction will correspond to a single event in a +multi-line diary entry. + +The function should accept two arguments, TYPE and PROPERTIES. TYPE is +the iCalendar type symbol (one of \\='icalendar-vevent, +\\='icalendar-vjournal, or \\='icalendar-vtodo) for the component being +generated for the entry. PROPERTIES is the list of property nodes that +`diary-icalendar-parse-entry' has already parsed from the entry and will +be included in the exported component. The function should return a list of iCalendar property nodes, which -will be incorporated into the `icalendar-vevent', `icalendar-vjournal', -or `icalendar-vtodo' component node created from the current entry. See -the docstrings of those symbols for more information on the properties -they can contain, and the `icalendar-make-property' macro for a simple -way to create property nodes from values parsed from the entry. - -When the function is called, the variables `type' and `properties' will -be dynamically bound. `type' is bound to the iCalendar type symbol (one -of \\='icalendar-vevent, \\='icalendar-vjournal, or \\='icalendar-vtodo) -for the component being generated for the entry. `properties' is bound -to the list of property nodes that `diary-icalendar-parse-entry' has -already parsed from the entry and will be included in the exported -component." +(in addition to PROPERTIES) will be incorporated into the +`icalendar-vevent', `icalendar-vjournal', or `icalendar-vtodo' component +node created from the current entry. See the docstrings of those +symbols for more information on the properties they can contain, and the +`icalendar-make-property' macro for a simple way to create property +nodes from values parsed from the entry." :version "31.1" :type '(radio (const :tag "Do not parse additional properties" nil) (function :tag "Parsing function"))) @@ -1168,7 +1171,7 @@ Adds a message to current binding of `help-form' explaining how." ;; customize. There are default skeletons for each major type of ;; iCalendar component (`di:vevent-skeleton', `di:vtodo-skeleton', ;; `di:vjournal-skeleton'), and a corresponding defcustom pointing to -;; each of these skeletons (`di:vevent-skeleton-command', etc.). +;; each of these skeletons (`di:vevent-format-function', etc.). ;; `di:format-entry' calls these skeletons, or user-provided functions, ;; to format individual components as diary entries. Since properties ;; representing people (`icalendar-attendee', `icalendar-organizer') are @@ -1192,18 +1195,17 @@ or nil ;; skip non-human "attendees": (when (or (not cutype) (equal cutype "INDIVIDUAL") (equal cutype "GROUP")) - (skeleton-insert - '(nil - cn - (format " <%s>" address) - (when partstat (format " (%s)" (downcase partstat))))))) + '(nil + cn + (format " <%s>" address) + (when partstat (format " (%s)" (downcase partstat)))))) (defun di:format-attendee (attendee) "Format ATTENDEE for the diary. ATTENDEE should be an `icalendar-attendee' or `icalendar-organizer' property node. Returns a string representing an entry for the attendee, -formatted by `diary-icalendar-attendee-skeleton-command', unless the +formatted by `diary-icalendar-attendee-format-function', unless the attendee's address matches the regexp in `diary-icalendar-skip-addresses-regexp'; in that case, nil is returned." (ical:with-property attendee @@ -1243,7 +1245,7 @@ attendee's address matches the regexp in (unless (and di:skip-addresses-regexp (string-match-p di:skip-addresses-regexp full-address)) (with-temp-buffer - (funcall di:attendee-skeleton-command) + (funcall di:attendee-format-function) (buffer-string)))))) (define-skeleton di:vevent-skeleton @@ -1272,7 +1274,8 @@ attendee's address matches the regexp in (start (pop skeleton-positions))) ;; TODO: should diary define a customizable indentation level? ;; For now, we use 1 because that's what icalendar.el chose - (indent-code-rigidly start end 1)) + (indent-code-rigidly start end 1) + nil) ; Don't insert return value (when importing "\n")) (define-skeleton di:vjournal-skeleton @@ -1299,7 +1302,8 @@ attendee's address matches the regexp in @ ; end of body (let* ((end (pop skeleton-positions)) (start (pop skeleton-positions))) - (indent-code-rigidly start end 1)) + (indent-code-rigidly start end 1) + nil) ; Don't insert return value (when importing "\n")) (define-skeleton di:vtodo-skeleton @@ -1328,7 +1332,8 @@ attendee's address matches the regexp in @ ; end of body (let* ((end (pop skeleton-positions)) (start (pop skeleton-positions))) - (indent-code-rigidly start end 1)) + (indent-code-rigidly start end 1) + nil) ; Don't insert return value (when importing "\n")) ;;; Further utilities for formatting/importing special kinds of values: @@ -1338,14 +1343,14 @@ attendee's address matches the regexp in (abs (car geo)) (if (< 0 (car geo)) "N" "S") (abs (cdr geo)) (if (< 0 (cdr geo)) "E" "W"))) -(defun ical:save-binary-attachment (base64-data dir &optional mimetype) +(defun di:save-binary-attachment (base64-data dir &optional mimetype) "Decode and save BASE64-DATA to a new file in DIR. The file will be named based on a unique prefix of BASE64-DATA with an extension based on MIMETYPE. It will be saved in a subdirectory named DIR of `diary-icalendar-attachment-directory', which will be created if necessary. Returns the (non-directory part of) the saved filename." - (require 'mailcap) + (require 'mailcap) ; for `mailcap-mime-type-to-extension' ;; Create the subdirectory for the attachment if necessary: (unless (and (directory-name-p di:attachment-directory) (file-writable-p di:attachment-directory)) @@ -1391,7 +1396,7 @@ URLs or filenames." ((ical:fmttypeparam :value fmttype)) (when (and (eq 'ical:binary value-type) di:attachment-directory) - (let ((filename (ical:save-binary-attachment value uid fmttype))) + (let ((filename (di:save-binary-attachment value uid fmttype))) (push filename entry-attachments))) (when (eq 'ical:url value-type) (push value entry-attachments)))) @@ -1479,7 +1484,7 @@ the iCalendar data." If DT is a date-time, only the date part is considered. The date is formatted with `calendar-date-string' according to the pattern in `diary-date-insertion-form'." - (calendar-dlet ((calendar-date-display-form diary-date-insertion-form)) + (dlet ((calendar-date-display-form diary-date-insertion-form)) (cl-typecase dt (ical:date (calendar-date-string dt t t)) (ical:date-time (calendar-date-string (ical:date-time-to-date dt) t t))))) @@ -1633,7 +1638,7 @@ the event." ;; by the appropriate skeleton command for the component, or by ;; `di:-format-vevent-legacy' if the legacy format string variables from ;; icalendar.el are set. -(defun di:format-entry (component index &optional non-marking) +(defun di:format-entry (component index &optional nonmarking) "Format an iCalendar component for the diary. COMPONENT should be an `icalendar-vevent', `icalendar-vtodo', or @@ -1641,14 +1646,14 @@ COMPONENT should be an `icalendar-vevent', `icalendar-vtodo', or COMPONENT occurs, as returned by `icalendar-parse-and-index'. Depending on the type of COMPONENT, the body will be formatted by one of: -`diary-icalendar-vevent-skeleton-command' -`diary-icalendar-vtodo-skeleton-command' -`diary-icalendar-vjournal-skeleton-command' +`diary-icalendar-vevent-format-function' +`diary-icalendar-vtodo-format-function' +`diary-icalendar-vjournal-format-function' which see. -The variable `non-marking' will be bound to the value of NON-MARKING in +The variable `nonmarking' will be bound to the value of NONMARKING in the relevant skeleton command. If it is non-nil, the user requested the -entry to be non-marking. +entry to be nonmarking. Returns a string containing the diary entry." (ical:with-component component @@ -1853,7 +1858,7 @@ Returns a string containing the diary entry." (last-modified-dt last-modified-dt) (last-modified (di:format-date/time-as-local last-modified-dt)) (location (di:-nonempty location)) - (non-marking non-marking) + (nonmarking nonmarking) (organizer (di:format-attendee organizer-node)) (percent-complete percent-complete) (priority priority) @@ -1893,9 +1898,9 @@ Returns a string containing the diary entry." access description location organizer-addr summary status url uid)) - (funcall di:vevent-skeleton-command)))) - (ical:vtodo (funcall di:vtodo-skeleton-command)) - (ical:vjournal (funcall di:vjournal-skeleton-command))) + (funcall di:vevent-format-function)))) + (ical:vtodo (funcall di:vtodo-format-function)) + (ical:vjournal (funcall di:vjournal-format-function))) (buffer-string)))))) @@ -1951,7 +1956,7 @@ See the :lessp argument of `sort' for more information." :type '(radio (function-item di:sort-by-start-ascending) (function :tag "Other comparison function"))) -(defun di:import-buffer-to-buffer (&optional all-non-marking) +(defun di:import-buffer-to-buffer (&optional all-nonmarking) "Format iCalendar data in current buffer as diary entries. This function parses the first iCalendar VCALENDAR in the current buffer @@ -1959,7 +1964,7 @@ and formats its VEVENT, VJOURNAL, and VTODO components as diary entries. It returns a new buffer containing those diary entries. The caller should kill this buffer when it is no longer needed. -If ALL-NON-MARKING is non-nil, all diary entries will be non-marking. +If ALL-NONMARKING is non-nil, all diary entries will be non-marking. The list of components to import can be filtered by binding `diary-icalendar-import-predicate'. After each component is formatted as @@ -2005,7 +2010,7 @@ in the `diary-icalendar' group." (calendar-dlet ((importing t)) ; inform skeletons we're importing (dolist (component to-import) (setq entry-start (point)) - (insert (di:format-entry component index all-non-marking)) + (insert (di:format-entry component index all-nonmarking)) (with-restriction entry-start (point) (save-excursion (run-hooks 'di:post-entry-format-hook))) @@ -2046,7 +2051,7 @@ in the `diary-icalendar' group." ;; of the main diary file: (diary-make-entry entry - nil ; skeleton has already interpreted non-marking + nil ; skeleton has already interpreted nonmarking nil ; use dynamic value of `diary-file' t ; skeleton responsible for final spaces t)) ; no need to show diary file while importing @@ -2056,7 +2061,7 @@ in the `diary-icalendar' group." (cl-incf di:-entry-count))))) ;;;###autoload -(defun di:import-buffer (&optional diary-filename quietly all-non-marking) +(defun di:import-buffer (&optional diary-filename quietly all-nonmarking) "Import iCalendar events from current buffer into diary. This function parses the first iCalendar VCALENDAR in the current buffer @@ -2069,7 +2074,7 @@ if you want to save the diary file unless QUIETLY is non-nil. When called interactively, you are asked if you want to confirm each entry individually; answer No to make QUIETLY non-nil. -ALL-NON-MARKING determines whether all diary events are created as +ALL-NONMARKING determines whether all diary events are created as non-marking entries. When called interactively, you are asked whether you want to make all entries non-marking. @@ -2099,7 +2104,7 @@ as well as variables in the customization group `diary-icalendar-import'." (find-file-noselect diary-filename))) import-buffer) (unwind-protect - (setq import-buffer (di:import-buffer-to-buffer all-non-marking)) + (setq import-buffer (di:import-buffer-to-buffer all-nonmarking)) (when (bufferp import-buffer) (kill-buffer import-buffer))) (display-buffer diary-buffer) @@ -2111,7 +2116,7 @@ as well as variables in the customization group `diary-icalendar-import'." (save-buffer))))) ;;;###autoload -(defun di:import-file (filename &optional diary-filename quietly non-marking) +(defun di:import-file (filename &optional diary-filename quietly nonmarking) "Import iCalendar diary entries from FILENAME into DIARY-FILENAME. This function parses the first iCalendar VCALENDAR in FILENAME and @@ -2124,7 +2129,7 @@ if you want to save the diary file unless QUIETLY is non-nil. When called interactively, you are asked if you want to confirm each entry individually; answer No to make QUIETLY non-nil. -NON-MARKING determines whether all diary events are created as +NONMARKING determines whether all diary events are created as non-marking entries. When called interactively, you are asked whether you want to make all entries non-marking. @@ -2153,7 +2158,7 @@ as well as variables in the customization group `diary-icalendar-import'." ;; Hand off to `di:import-buffer' for the actual import: (if parse-buf (with-current-buffer parse-buf - (di:import-buffer diary-filename quietly non-marking)) + (di:import-buffer diary-filename quietly nonmarking)) ;; If we get here, we weren't able to open the file for parsing: (warn "Unable to open file %s; see %s" filename (buffer-name (ical:error-buffer)))))) @@ -3583,21 +3588,18 @@ recursive calls to this function made by ;; Allow users to add to the properties parsed: (when (functionp di:other-properties-parser) - (calendar-dlet - ((type type) - (properties all-props)) - (let ((others (funcall di:other-properties-parser))) - (dolist (p others) - (condition-case nil - (push (ical:ast-node-valid-p p) - all-props) - (ical:validation-error - (ical:warn - (format "`%s' returned invalid `%s' property; ignoring" - di:other-properties-parser - (ical:ast-node-type p)) - :buffer (current-buffer) - :position (point)))))))) + (let ((others (funcall di:other-properties-parser type all-props))) + (dolist (p others) + (condition-case nil + (push (ical:ast-node-valid-p p) + all-props) + (ical:validation-error + (ical:warn + (format "`%s' returned invalid `%s' property; ignoring" + di:other-properties-parser + (ical:ast-node-type p)) + :buffer (current-buffer) + :position (point))))))) ;; Construct, validate and return a component of the appropriate type: (let ((component diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 9fe3ca44336..3011b8383f8 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -2319,7 +2319,10 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." ;; Accepted formats: 10:00 10.00 10h00 10h 10am 10:00am 10.00am ;; Use of "." as a separator annoyingly matches numbers, eg "123.45". ;; Hence often prefix this with "\\(^\\|\\s-\\)." - ;; FIXME. + ;; FIXME: this regexp is too liberal to be used for parsing times from + ;; entries by `diary-icalendar-parse-time', hence the existence of + ;; `diary-icalendar-time-regexp'. Can we tighten it up so we don't + ;; need both? (concat "[0-9]?[0-9]\\([AaPp][mM]\\|\\(" "[Hh]\\([0-9][0-9]\\)?\\|[:.][0-9][0-9]" "\\)\\([AaPp][Mm]\\)?\\)") diff --git a/lisp/calendar/icalendar-ast.el b/lisp/calendar/icalendar-ast.el index 35c9e4b1f1f..795d9dde65a 100644 --- a/lisp/calendar/icalendar-ast.el +++ b/lisp/calendar/icalendar-ast.el @@ -298,15 +298,13 @@ PROPS should be a plist with any of the following keywords: ;; A high-level API for constructing iCalendar syntax nodes in Lisp code: - -(declare-function ical:list-of-p "icalendar-parser") - (defun ical:type-of (value &optional types) "Find the iCalendar type symbol for the type to which VALUE belongs. TYPES, if specified, should be a list of type symbols to check. TYPES defaults to all type symbols listed in `icalendar-value-types'." (require 'icalendar-parser) ; for ical:value-types, ical:list-of-p + (declare-function ical:list-of-p "icalendar-parser") (catch 'found (when (ical:ast-node-p value) (throw 'found (ical:ast-node-type value))) @@ -339,7 +337,7 @@ the list is nil, VALUE will be checked against all types in If VALUE is nil, and `icalendar-boolean' is not (in) TYPE, nil is returned. Otherwise, a \\='wrong-type-argument error is signaled if VALUE does not satisfy (any type in) TYPE." - (require 'icalendar-parser) + (require 'icalendar-parser) ; for `icalendar-list-of-p' (cond ((and (null value) (not (if (listp type) (memq 'ical:boolean type) @@ -372,6 +370,31 @@ VALUE does not satisfy (any type in) TYPE." value))))) (t (signal 'wrong-type-argument (list '(or symbolp listp) type))))) +(defun ical:-make-param--list (type value-type raw-values) + "Make a param node of TYPE with list of values RAW-VALUES of type VALUE-TYPE." + (let ((value (if (seq-every-p #'ical:ast-node-p raw-values) + raw-values + (mapcar + (lambda (c) + (ical:make-value-node-of value-type c)) + raw-values)))) + (when value + (ical:ast-node-valid-p + (ical:make-ast-node + type + (list :value value)))))) + +(defun ical:-make-param--nonlist (type value-type raw-value) + "Make a param node of TYPE with value RAW-VALUE of type VALUE-TYPE." + (let ((value (if (ical:ast-node-p raw-value) + raw-value + (ical:make-value-node-of value-type raw-value)))) + (when value + (ical:ast-node-valid-p + (ical:make-ast-node + type + (list :value value)))))) + (defmacro ical:make-param (type value) "Construct an iCalendar parameter node of TYPE with value VALUE. @@ -393,28 +416,46 @@ will return an `icalendar-deltoparam' node whose value is a list of The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." + (declare (debug (symbolp form form))) ;; TODO: support `ical:otherparam' (unless (ical:param-type-symbol-p type) (error "Not an iCalendar param type: %s" type)) - (let ((value-type (or (get type 'ical:value-type) 'plain-text)) - (needs-list (ical:expects-list-of-values-p type))) - `(let* ((raw-value ,value) - (value-type (quote ,value-type)) - (value - ,(if needs-list - '(if (seq-every-p #'ical:ast-node-p raw-value) - raw-value - (mapcar - (lambda (c) (ical:make-value-node-of value-type c)) - raw-value)) - '(if (ical:ast-node-p raw-value) - raw-value - (ical:make-value-node-of value-type raw-value))))) - (when value - (ical:ast-node-valid-p - (ical:make-ast-node - (quote ,type) - (list :value value))))))) + (let ((value-type (or (get type 'ical:value-type) 'plain-text))) + (if (ical:expects-list-of-values-p type) + `(ical:-make-param--list ',type ',value-type ,value) + `(ical:-make-param--nonlist ',type ',value-type ,value)))) + +(defun ical:-make-property--list (type value-types raw-values &optional params) + "Make a property node of TYPE with list of values RAW-VALUES. +VALUE-TYPES should be a list of value types that TYPE accepts. +PARAMS, if given, should be a list of parameter nodes." + (require 'icalendar-parser) ; for `ical:maybe-add-value-param' + (declare-function ical:maybe-add-value-param "icalendar-parser") + + (let ((value (if (seq-every-p #'ical:ast-node-p raw-values) + raw-values + (mapcar + (lambda (c) (ical:make-value-node-of value-types c)) + raw-values)))) + (when value + (ical:ast-node-valid-p + (ical:maybe-add-value-param + (ical:make-ast-node type (list :value value) params)))))) + +(defun ical:-make-property--nonlist (type value-types raw-value &optional params) + "Make a property node of TYPE with value RAW-VALUE. +VALUE-TYPES should be a list of value types that TYPE accepts. +PARAMS, if given, should be a list of parameter nodes." + (require 'icalendar-parser) ; for `ical:maybe-add-value-param' + (declare-function ical:maybe-add-value-param "icalendar-parser") + + (let ((value (if (ical:ast-node-p raw-value) + raw-value + (ical:make-value-node-of value-types raw-value)))) + (when value + (ical:ast-node-valid-p + (ical:maybe-add-value-param + (ical:make-ast-node type (list :value value) params)))))) (defmacro ical:make-property (type value &rest param-templates) "Construct an iCalendar property node of TYPE with value VALUE. @@ -422,15 +463,16 @@ The resulting syntax node is checked for validity by TYPE should be an iCalendar type symbol satisfying `icalendar-property-type-symbol-p'; it should not be quoted. -VALUE should evaluate to a value appropriate for TYPE. In particular, if -TYPE expects a list of values (see +VALUE should evaluate to a value appropriate for TYPE. In particular, +if TYPE expects a list of values (see `icalendar-expects-list-of-values-p'), VALUE should be such a list. If necessary, the value(s) in VALUE will be wrapped in syntax nodes indicating their type. If VALUE is not of the default value type for -TYPE, an `icalendar-valuetypeparam' will automatically be added to TEMPLATES. +TYPE, an `icalendar-valuetypeparam' will automatically be added to +PARAM-TEMPLATES. Each element of PARAM-TEMPLATES should represent a parameter node; see -`icalendar-make-node-from-templates' for the format of such TEMPLATES. +`icalendar-make-node-from-templates' for the format of such templates. A template can also have the form (@ L), where L evaluates to a list of parameter nodes to be added to the component. @@ -448,11 +490,11 @@ The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." ;; TODO: support `ical:other-property', maybe like ;; (ical:other-property "X-NAME" value ...) + (declare (debug (symbolp form form &rest form))) (unless (ical:property-type-symbol-p type) (error "Not an iCalendar property type: %s" type)) (let ((value-types (cons (get type 'ical:default-type) (get type 'ical:other-types))) - (needs-list (ical:expects-list-of-values-p type)) params-expr children lists-of-children) (dolist (c param-templates) (cond ((and (listp c) (ical:type-symbol-p (car c))) @@ -473,25 +515,9 @@ The resulting syntax node is checked for validity by `(seq-filter #'identity (append (list ,@children) ,@lists-of-children)))) - `(let* ((raw-value ,value) - (value-types (quote ,value-types)) - (value - ,(if needs-list - '(if (seq-every-p #'ical:ast-node-p raw-value) - raw-value - (mapcar - (lambda (c) (ical:make-value-node-of value-types c)) - raw-value)) - '(if (ical:ast-node-p raw-value) - raw-value - (ical:make-value-node-of value-types raw-value))))) - (when value - (ical:ast-node-valid-p - (ical:maybe-add-value-param - (ical:make-ast-node - (quote ,type) - (list :value value) - ,params-expr))))))) + (if (ical:expects-list-of-values-p type) + `(ical:-make-property--list ',type ',value-types ,value ,params-expr) + `(ical:-make-property--nonlist ',type ',value-types ,value ,params-expr)))) (defmacro ical:make-component (type &rest templates) "Construct an iCalendar component node of TYPE from TEMPLATES. @@ -527,6 +553,7 @@ properties. The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." + (declare (debug (symbolp form &rest form))) ;; TODO: support `ical:other-component', maybe like ;; (ical:other-component (:x-name "X-NAME") templates ...) (unless (ical:component-type-symbol-p type) @@ -633,6 +660,7 @@ For example, an iCalendar VEVENT could be written like this: Before the constructed node is returned, it is validated by `icalendar-ast-node-valid-p'." + (declare (debug (symbolp form &rest form))) (cond ((not (ical:type-symbol-p type)) (error "Not an iCalendar type symbol: %s" type)) @@ -745,13 +773,12 @@ See `icalendar-daylight' for the permissible child types." (or (memq child-type (plist-get child-spec :one)) (memq child-type (plist-get child-spec :one-or-more))))) -(declare-function ical:printable-value-type-symbol-p "icalendar-parser") - (defun ical:ast-node-valid-value-p (node) "Validate that NODE's value satisfies the requirements of its type. Signals an `icalendar-validation-error' if NODE's value is invalid, or returns NODE." (require 'icalendar-parser) ; for ical:printable-value-type-symbol-p + (declare-function ical:printable-value-type-symbol-p "icalendar-parser") (let* ((type (ical:ast-node-type node)) (value (ical:ast-node-value node)) (valtype-param (when (ical:property-type-symbol-p type) diff --git a/lisp/calendar/icalendar-macs.el b/lisp/calendar/icalendar-macs.el index 30b11ba2080..fe99cef14bc 100644 --- a/lisp/calendar/icalendar-macs.el +++ b/lisp/calendar/icalendar-macs.el @@ -108,7 +108,7 @@ The following keyword arguments are accepted: type to a string. Its name does not need to be quoted. (default: identity) -:link - a string containing an URL for further documentation of this type" +:link - a string containing a URL for further documentation of this type" (declare (doc-string 2)) (let* (;; Related functions: (type-dname (if print-name @@ -592,7 +592,7 @@ of type symbols: ;; Group 3: incorrect values up to end-of-line (for syntax warnings) (rx-define ,full-value-rx-name (or (group-n 2 ,(or values-rx value)) - (group-n 3 (zero-or-more any)))) + (group-n 3 (zero-or-more not-newline)))) ;; Full property regex which matches: ;; Group 1: the property name, diff --git a/lisp/calendar/icalendar-parser.el b/lisp/calendar/icalendar-parser.el index 186557ffeb1..bc213b413ad 100644 --- a/lisp/calendar/icalendar-parser.el +++ b/lisp/calendar/icalendar-parser.el @@ -676,8 +676,8 @@ other special requirements like quoting or escaping." (rx-define ical:x-name (seq "X-" - (zero-or-one (>= 3 (any "A-Za-z0-9")) "-") ; Vendor ID - (one-or-more (any "A-Za-z0-9" "-")))) ; Name + (zero-or-one (>= 3 (any "A-Za-z0-9")) "-") ; Vendor ID + (one-or-more (any "A-Za-z0-9" "-")))) ; Name (rx-define ical:name (or ical:iana-token ical:x-name)) @@ -883,12 +883,11 @@ for functions that work with this representation." (cl-deftype ical:numeric-minute () '(integer 0 59)) (cl-deftype ical:numeric-second () '(integer 0 60)) ; 60 represents a leap second -(declare-function ical:make-date-time "icalendar-utils") - (defun ical:read-time (s) "Read an `icalendar-time' from a string S. S should be a match against rx `icalendar-time'." (require 'icalendar-utils) ; for ical:make-date-time; avoids circular require + (declare-function ical:make-date-time "icalendar-utils") (let ((hour (string-to-number (substring s 0 2))) (minute (string-to-number (substring s 2 4))) (second (string-to-number (substring s 4 6))) @@ -1194,9 +1193,6 @@ When read, an Elisp integer value between -2147483648 and 2147483647." "Return the `icalendar-date-time' which marks the end of PERIOD, or nil." (cadr period)) - -(declare-function ical:date/time-add-duration "icalendar-utils") - (defsubst ical:period-dur-value (period) "Return the `icalendar-dur-value' which gives the length of PERIOD, or nil." (caddr period)) @@ -1207,6 +1203,7 @@ If the end is not explicitly specified, it will be computed from the period's start and duration. VTIMEZONE, if given, should be the `icalendar-vtimezone' in which to compute the end time." (require 'icalendar-utils) ; for date/time-add-duration; avoids circular import + (declare-function ical:date/time-add-duration "icalendar-utils") (or (ical:period--defined-end period) ;; compute end from duration and cache it: (setf (cadr period) @@ -1802,11 +1799,11 @@ The parsed and printed representations are the same: a URI string." "Type for Calendar User Address values. The parsed and printed representations are the same: a URI string. -Typically, this should be a mailto: URI. +Typically, this should be a \"mailto:\" URI. -RFC5545 says: '*When used to address an Internet email transport +RFC5545 says: \"*When used to address an Internet email transport address* for a calendar user, the value MUST be a mailto URI, - as defined by [RFC2368]' + as defined by [RFC2368]\" Since it is unclear whether there are Calendar User Address values which are not used to address email, this type does not enforce the use @@ -4288,8 +4285,6 @@ VCALENDAR nodes; it is not normally necessary to call it directly." ;; success: node)) -(declare-function icr:tz-set-zones-in "icalendar-recur") - (defun ical:contains-vcalendar-p (&optional buffer) "Determine whether BUFFER contains \"BEGIN:VCALENDAR\". @@ -4316,6 +4311,7 @@ of a line that looks like \"BEGIN:VCALENDAR\". After parsing, point is at the beginning of the next line following the calendar (or end of the buffer). Returns a syntax node representing the calendar." (require 'icalendar-recur) ; for icr:tz-set-zones-in; avoids circular require + (declare-function icr:tz-set-zones-in "icalendar-recur") (unless (looking-at-p "^BEGIN:VCALENDAR") (ical:signal-parse-error "Not at start of VCALENDAR")) (let ((cal-node (ical:parse-component limit))) @@ -4554,15 +4550,16 @@ which see." ;; Update and return the index: (plist-put index :bytzid tzid-index)))) -(declare-function icr:recurrences-to-count "icalendar-recur") -(declare-function ical:date/time-to-local "icalendar-utils") -(declare-function ical:date/time-to-date "icalendar-utils") -(declare-function ical:dates-until "icalendar-utils") (defun ical:index-insert (index component) "Insert COMPONENT into INDEX." (require 'icalendar-recur) ; avoid circular imports (require 'icalendar-utils) ; + (declare-function icr:recurrences-to-count "icalendar-recur") + (declare-function ical:date/time-to-local "icalendar-utils") + (declare-function ical:date/time-to-date "icalendar-utils") + (declare-function ical:dates-until "icalendar-utils") + (ical:with-component component ((ical:dtstart :first dtstart-node :value dtstart) (ical:dtend :first dtend-node :value dtend) @@ -4668,13 +4665,6 @@ which see." (setq index (ical:index-insert index component))) index)) -(declare-function icr:find-interval "icalendar-recur") -(declare-function icr:recurrences-in-interval "icalendar-recur") -(declare-function ical:date/time-in-period-p "icalendar-utils") -(declare-function ical:date/time<= "icalendar-utils") -(declare-function ical:date/time< "icalendar-utils") -(declare-function ical:date/time-add-duration "icalendar-utils") - (cl-defun ical:index-get (index &rest args &key date uid tzid) "Get an iCalendar component from INDEX by date, UID, or TZID. @@ -4693,6 +4683,14 @@ INDEX should be a reference to a parse tree index as returned by Only one keyword argument can be queried at a time." (require 'icalendar-recur) ; avoid circular imports (require 'icalendar-utils) ; + + (declare-function icr:find-interval "icalendar-recur") + (declare-function icr:recurrences-in-interval "icalendar-recur") + (declare-function ical:date/time-in-period-p "icalendar-utils") + (declare-function ical:date/time<= "icalendar-utils") + (declare-function ical:date/time< "icalendar-utils") + (declare-function ical:date/time-add-duration "icalendar-utils") + (when (length> args 2) (error "Only one keyword argument can be queried")) (cond (uid (gethash uid (plist-get index :byuid))) diff --git a/lisp/calendar/icalendar-utils.el b/lisp/calendar/icalendar-utils.el index f3fd1e73de4..28d98304d78 100644 --- a/lisp/calendar/icalendar-utils.el +++ b/lisp/calendar/icalendar-utils.el @@ -432,8 +432,6 @@ ignored. N may be a positive or negative integer." (new-dt (decoded-time-add dt delta))) (ical:date-time-to-date new-dt)))) -(declare-function icalendar-recur-tz-decode-time "icalendar-recur") - (defun ical:date-time-add (dt delta &optional vtimezone) "Like `decoded-time-add', but also updates weekday and time zone slots. @@ -452,6 +450,8 @@ standard time, even though this is not exactly 48 hours later. Adding a DELTA of 48 hours, on the other hand, will result in a time exactly 48 hours later, but at a different local time." (require 'icalendar-recur) ; for icr:tz-decode-time; avoids circular requires + (declare-function icalendar-recur-tz-decode-time "icalendar-recur") + (if (not vtimezone) ;; the simple case: we have no time zone info, so just use ;; `decoded-time-add': @@ -543,8 +543,6 @@ local time. If DT is an `icalendar-date', return it unchanged." (ical:date-time-variant ; ensure weekday is present too (decode-time (encode-time dt)))))) -(declare-function icalendar-recur-subintervals-to-dates "icalendar-recur") - (defun ical:dates-until (start end &optional locally) "Return a list of `icalendar-date' values between START and END. @@ -556,7 +554,9 @@ after midnight, then its date will be included in the returned list.) If LOCALLY is non-nil and START and END are date-times, these will be interpreted into Emacs local time, so that the dates returned are valid for the local time zone." - (require 'icalendar-recur) + (require 'icalendar-recur) ; avoid circular requires + (declare-function icalendar-recur-subintervals-to-dates "icalendar-recur") + (when locally (when (cl-typep start 'ical:date-time) (setq start (ical:date/time-to-local start))) @@ -603,8 +603,6 @@ for the local time represented by the remaining arguments." ,@(when given-dst (list :dst dst)) ,@(when zone (list :zone zone))))) -(declare-function icalendar-recur-tz-set-zone "icalendar-recur") - (cl-defun ical:date-time-variant (dt &key second minute hour day month year (dst -1 given-dst) @@ -629,6 +627,8 @@ this value, but its dst slot will not be adjusted. If it is the symbol \\='preserve, then both the zone and dst fields are copied from DT into the variant." (require 'icalendar-recur) ; for icr:tz-set-zone; avoids circular requires + (declare-function icalendar-recur-tz-set-zone "icalendar-recur") + (let ((variant (make-decoded-time :second (or second (decoded-time-second dt)) :minute (or minute (decoded-time-minute dt)) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 3d8d31dffcb..d617e1eb8c5 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -117,7 +117,7 @@ argument. It must return a string. See (make-obsolete-variable 'icalendar-import-format - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -131,7 +131,7 @@ by the summary." (make-obsolete-variable 'icalendar-import-format-summary - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -145,7 +145,7 @@ replaced by the description." (make-obsolete-variable 'icalendar-import-format-description - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -159,7 +159,7 @@ by the location." (make-obsolete-variable 'icalendar-import-format-location - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -173,7 +173,7 @@ replaced by the organizer." (make-obsolete-variable 'icalendar-import-format-organizer - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -187,7 +187,7 @@ the URL." (make-obsolete-variable 'icalendar-import-format-url - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -202,7 +202,7 @@ the UID." (make-obsolete-variable 'icalendar-import-format-uid - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -216,7 +216,7 @@ the status." (make-obsolete-variable 'icalendar-import-format-status - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") @@ -230,7 +230,7 @@ the class." (make-obsolete-variable 'icalendar-import-format-class - "please use `diary-icalendar-vevent-skeleton-command' for import + "please use `diary-icalendar-vevent-format-function' for import formatting instead." "31.1") diff --git a/test/lisp/calendar/diary-icalendar-tests.el b/test/lisp/calendar/diary-icalendar-tests.el index 40d68f82d55..b502dc72059 100644 --- a/test/lisp/calendar/diary-icalendar-tests.el +++ b/test/lisp/calendar/diary-icalendar-tests.el @@ -1210,9 +1210,10 @@ SOURCE, if given, should be a symbol; it is used to name the test." (should (= 16 (decoded-time-hour start))) (should (ical:with-param-of start-node 'ical:tzidparam))))) -(defun dit:parse-@-location () +(defun dit:parse-@-location (type properties) "Example user function for parsing additional properties. Parses anything following \"@\" to end of line as the entry's LOCATION." + (ignore type properties) (goto-char (point-min)) (when (re-search-forward "@\\([^\n]+\\)" nil t) (list (ical:make-property ical:location diff --git a/test/lisp/calendar/icalendar-ast-tests.el b/test/lisp/calendar/icalendar-ast-tests.el new file mode 100644 index 00000000000..b4107b139a5 --- /dev/null +++ b/test/lisp/calendar/icalendar-ast-tests.el @@ -0,0 +1,112 @@ +;;; tests/icalendar-ast.el --- Tests for icalendar-ast -*- lexical-binding: t; -*- +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: +(require 'icalendar-ast) +(require 'icalendar-parser) +(require 'cl-lib) +(eval-when-compile (require 'icalendar-macs)) + + +;; Tests for the high-level construction macros: +(ert-deftest iat:make-param/nonlist () + "Test that `icalendar-make-param' works as documented with a single value." + (let ((cnparam-node (ical:make-param ical:cnparam "John Doe"))) + (should (ical:param-node-p cnparam-node)) + (should (eq 'ical:cnparam (ical:ast-node-type cnparam-node))) + (ical:with-param cnparam-node + (should (cl-typep value 'ical:text)) + (should (equal value "John Doe"))))) + +(ert-deftest iat:make-param/list () + "Test that `icalendar-make-param' works as documented with a list of values." + (let ((deltoparam-node (ical:make-param ical:deltoparam + (list "mailto:minionA@example.com" + "mailto:minionB@example.com")))) + (should (ical:param-node-p deltoparam-node)) + (should (eq 'ical:deltoparam (ical:ast-node-type deltoparam-node))) + (ical:with-param deltoparam-node + (should (and (listp value-nodes) (length= value-nodes 2))) + (should (seq-every-p + (lambda (n) (eq 'ical:cal-address (ical:ast-node-type n))) + value-nodes)) + (should (equal "mailto:minionA@example.com" (car values))) + (should (equal "mailto:minionB@example.com" (cadr values)))))) + +(ert-deftest iat:make-property/nonlist () + "Test that `icalendar-make-property' works as documented with a single value." + (let ((attendee-node + (ical:make-property ical:attendee "mailto:hermes@planetexpress.com" + (ical:cnparam "H. Conrad")))) + (should (ical:property-node-p attendee-node)) + (should (eq 'ical:attendee (ical:ast-node-type attendee-node))) + (ical:with-property attendee-node + ((ical:cnparam :first cnparam-node :value cn)) + (should (eq value-type 'ical:cal-address)) + (should (equal value "mailto:hermes@planetexpress.com")) + (should (eq 'ical:cnparam (ical:ast-node-type cnparam-node))) + (should (equal cn "H. Conrad"))))) + +(ert-deftest iat:make-property/list () + "Test that `icalendar-make-property' works as documented with a list of values." + (let ((rdate-node (icalendar-make-property icalendar-rdate + (list '(2 1 2025) '(3 1 2025))))) + (should (ical:property-node-p rdate-node)) + (should (eq 'ical:rdate (ical:ast-node-type rdate-node))) + (ical:with-property rdate-node + ((ical:valuetypeparam :first valtype-node :value valtype)) + (should (and (listp value-nodes) (length= value-nodes 2))) + (should (seq-every-p + (lambda (n) (eq 'ical:date (ical:ast-node-type n))) + value-nodes)) + (should (equal '(2 1 2025) (car values))) + (should (equal '(3 1 2025) (cadr values))) + (should (ical:ast-node-p valtype-node)) + (should (eq 'ical:valuetypeparam (ical:ast-node-type valtype-node))) + (should (eq 'ical:date valtype))))) + +(ert-deftest iat:make-component () + "Test that `icalendar-make-component' works as documented." + (let* ((others (list (icalendar-make-property ical:dtstart '(9 6 3003)) + (icalendar-make-property ical:rrule '((FREQ DAILY))))) + (vevent-node (icalendar-make-component ical:vevent + (ical:summary "Party") + (ical:location "Robot House") + (@ others)))) + (should (ical:component-node-p vevent-node)) + (should (eq 'ical:vevent (ical:ast-node-type vevent-node))) + (ical:with-component vevent-node + ((ical:uid :first uid-node) + (ical:dtstamp :first dtstamp-node) + (ical:summary :value summary) + (ical:location :value location) + (ical:dtstart :first dtstart-node :value dtstart) + (ical:rrule :first rrule-node :value rrule)) + (should (and (ical:ast-node-p uid-node) + (ical:ast-node-p dtstamp-node))) + (should (equal summary "Party")) + (should (equal location "Robot House")) + (should (equal dtstart '(9 6 3003))) + (should (equal rrule '((FREQ DAILY))))))) + +;; TODO: properties, components too + +;; Local Variables: +;; read-symbol-shorthands: (("iat:" . "icalendar-ast-test-") ("ical:" . "icalendar-")) +;; End: +;;; icalendar-ast-tests.el ends here diff --git a/test/lisp/calendar/icalendar-recur-tests.el b/test/lisp/calendar/icalendar-recur-tests.el index ed844b23dee..1df2c5b17e5 100644 --- a/test/lisp/calendar/icalendar-recur-tests.el +++ b/test/lisp/calendar/icalendar-recur-tests.el @@ -1477,6 +1477,7 @@ END:VTIMEZONE members nonmembers size + (tags nil) source) "Create a test which parses RECUR-STRING to an `icalendar-recur', @@ -1507,10 +1508,12 @@ NONMEMBERS, if present, should be a list of values that are expected SIZE, if present, should be a positive integer representing the expected size of the recurrence set. Defaults to the value of the COUNT clause in the recurrence rule, if any. +TAGS is passed on to `ert-deftest'. SOURCE should be a symbol; it is used to name the test." `(ert-deftest ,(intern (concat "ict:rrule-test-" (symbol-name source))) () ,(format "Parse and evaluate recur-value example from `%s':\n%s" source doc) + :tags ,tags (let* ((parsed (ical:parse-from-string 'ical:recur ,recur-string)) (recvalue (ical:ast-node-value parsed)) (until (ical:recur-until recvalue)) @@ -1713,6 +1716,7 @@ SOURCE should be a symbol; it is used to name the test." (ict:rrule-test "RRULE:FREQ=DAILY;UNTIL=19971224T000000Z\n" "Daily at 9AM until December 24, 1997" + :tags '(:expensive-test) :tz ict:tz-eastern :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 :hour 9 :minute 0 :second 0 @@ -1811,6 +1815,7 @@ SOURCE should be a symbol; it is used to name the test." (ict:rrule-test "RRULE:FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA\n" "Every day in January, for three years (weekdays explicit)" + :tags '(:expensive-test) :tz ict:tz-eastern :dtstart (ical:make-date-time :year 1998 :month 1 :day 1 :hour 9 :minute 0 :second 0 @@ -1839,6 +1844,7 @@ SOURCE should be a symbol; it is used to name the test." (ict:rrule-test "RRULE:FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1\n" "Every day in January, for three years (weekdays implicit)" + :tags '(:expensive-test) ;; TODO: as things are currently implemented, this way of expressing ;; the rule is quite expensive, since we end up computing intervals and ;; recurrences for every day of the year, even though the only relevant @@ -2778,6 +2784,7 @@ Thursday, for the next 3 months" "RRULE:FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16\n" "Every 20 minutes from 9:00 AM to 4:40 PM every day (Alternative rule for the previous example)" + :tags '(:expensive-test) :tz ict:tz-eastern :dtstart (ical:make-date-time :year 1997 :month 9 :day 2 :hour 9 :minute 0 :second 0 From cf20565e636893004c9403be8234f42afb655796 Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Sat, 27 Dec 2025 18:55:49 +0100 Subject: [PATCH 022/191] Change the format function calling conventions in diary-icalendar.el This avoids `calendar-dlet' and unprefixed dynamic variable bindings when calling user format functions, as discussed in Bug#74994. * lisp/calendar/diary-icalendar.el (diary-icalendar-time-format): Fix whitespace. (diary-icalendar-format-attendee) (diary-icalendar-format-entry): Use fewer dynamic variables, prefix them, replace `calendar-dlet' with `dlet', and call user format functions with the node to be formatted. (diary-icalendar-attendee-format-function) (diary-icalendar-vevent-format-function) (diary-icalendar-vjournal-format-function) (diary-icalendar-vtodo-format-function): Document these changes. (diary-icalendar-attendee-skeleton) (diary-icalendar-vevent-skeleton) (diary-icalendar-vjournal-skeleton) (diary-icalendar-vtodo-skeleton): Use `defun' with `skeleton-insert' instead of `define-skeleton'. Update variable references. (diary-icalendar-import-buffer-to-buffer) (diary-icalendar-add-valarms): Replace `calendar-dlet' with `dlet'. * doc/emacs/calendar.texi (Diary iCalendar Import): Update example in manual. --- doc/emacs/calendar.texi | 9 +- lisp/calendar/diary-icalendar.el | 720 +++++++++++++------------------ 2 files changed, 307 insertions(+), 422 deletions(-) diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index ff88f4e426e..4bfe3f65422 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -1647,11 +1647,12 @@ follows: @group (require 'skeleton) -(define-skeleton simple-vevent +(defun simple-vevent (_) "Format a VEVENT summary and location on a single line" - nil - start-to-end & " " & summary & " " - (when location "@@ ") & location "\n") + (skeleton-insert + '(nil + ical-start-to-end & " " & ical-summary & " " + (when ical-location "@@ ") & ical-location "\n"))) (setopt diary-icalendar-vevent-format-function #'simple-vevent) @end group diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index 7bb6f12ca42..640e063268a 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -99,7 +99,7 @@ The value must be a valid format string for `format-time-string'; see its docstring for more information. The value only needs to format clock times, and should format them in a way that will be recognized by `diary-time-regexp'. (Date information is formatted separately at the -start of the imported entry.) Examples: +start of the imported entry.) Examples: \"%H:%M\" - 24-hour, 0-padded: 09:00 or 21:00 \"%k.%Mh\" - 24-hour, blank-padded: 9.00h or 21.00h @@ -116,36 +116,21 @@ This should be a function which inserts information about an express such a function as a skeleton; see `define-skeleton' and `skeleton-insert' for more information. -The function will be called with no arguments and should insert -information about the attendee into the current buffer. +The function will be called with one argument, ATTENDEE, which will be +an `icalendar-attendee' syntax node. It should insert information about +the attendee into the current buffer. See `icalendar-with-property' for +a convenient way to bind the data in ATTENDEE. -The following variables will be (dynamically) bound when the function is -called. All values will be strings (unless another type is noted), or -nil: +For convenience when writing this function as a skeleton, the following +variables will also be (dynamically) bound when the function is called. +All values will be strings (unless another type is noted), or nil: -address - the attendee's calendar address, with \"mailto:\" removed -full-address - the attendee's calendar address, with nothing removed -cn - the attendee's common name (`icalendar-cnparam') -dir - URL of attendee's directory entry (`icalendar-directoryparam') -cutype - the attendee's user type (`icalendar-cutypeparam') -language - a language abbreviation (`icalendar-languageparam') -role - the attendee's role in the event (`icalendar-roleparam') -partstat - the attendee's participation status (`icalendar-partstatparam') -rsvp - whether an RSVP is requested (`icalendar-rsvpparam') -member-addresses (list of strings) - any groups/lists where the attendee - is a member (`icalendar-memberparam'), with \"mailto:\" removed -member-full-addresses - like member-addresses, but nothing removed -delfrom-addresses (list of strings) - addresses of users who delegated - their participation to the attendee (`icalendar-delfromparam'), with - \"mailto:\" removed -delfrom-full-addresses - like delfrom-addresses, but nothing removed -delto-addresses (list of strings) - addresses of users to whom the - attendee delegated participation (`icalendar-deltoparam'), with - \"mailto:\" removed -delto-full-addresses - like delto-addresses, but nothing removed -sentby-address - address of user who sent the invitation on someone - else's behalf (`icalendar-sentbyparam'), with \"mailto:\" removed -sentby-full-address - like sentby-address, but nothing removed" +`attendee-address' - address, with \"mailto:\" removed +`attendee-cn' - common name (`icalendar-cnparam') +`attendee-cutype' - calendar user type (`icalendar-cutypeparam') +`attendee-role' - role in the event (`icalendar-roleparam') +`attendee-partstat' - participation status (`icalendar-partstatparam') +`attendee-rsvp' - whether an RSVP is requested (`icalendar-rsvpparam')" :version "31.1" :type '(radio (function-item di:attendee-skeleton) (function :tag "Other function"))) @@ -168,81 +153,60 @@ listed in diary entries." (defcustom di:vevent-format-function #'di:vevent-skeleton "Function to format VEVENT components for the diary. -This function is called with no arguments and should insert information -about an `icalendar-vevent' into the current buffer. It is convenient -to express such a function as a skeleton; see `define-skeleton' and -`skeleton-insert' for more information. +This function is called with one argument VEVENT, an `icalendar-vevent'. +It should insert formatted data from this event into the current buffer. +It is convenient to express such a function as a skeleton; see +`define-skeleton' and `skeleton-insert' for more information. See +`icalendar-with-component' for a convenient way to bind the data in +VEVENT. -The following variables will be bound when the function is called. -All values will be strings unless another type is noted, or nil: +For convenience when writing this function as a skeleton, the following +variables will be (dynamically) bound when the function is called. All +values will be strings unless another type is noted, or nil: -alarms (list of `icalendar-valarm' nodes) - notifications in the event -as-alarm (symbol) - non-nil when the event should be formatted for an +`ical-as-alarm' (symbol) - non-nil when the event should be formatted for an alarm notification in advance of the event. The symbol indicates the type of alarm: `email' means to format the event as the body of an email. (Currently only used for EMAIL alarms; see `diary-icalendar-export-alarms'.) -attachments (list of strings) - URLs or filenames of attachments in the event -attendees (list of strings) - the participants of the event, +`ical-attachments' (list of strings) - URLs or filenames of attachments + in the event +`ical-attendees' (list of strings) - the participants of the event, formatted by `diary-icalendar-attendee-format-function' -categories (list of strings) - categories specified in the event -access - the event's access classification -comments (list of strings) - comments specified in the event -created-dt (an `icalendar-date-time' value) - when the event was created -created - created-dt, formatted as a local date-time string -description - the event's description -dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the event - starts -dtend (an `icalendar-date' or `icalendar-date-time' value) - when the - event ends; this is either the value of the `icalendar-dtend' - property, or the end time calculated by adding the event's - `icalendar-duration' to its `icalendar-dtstart' properties -start - start date and time in a single string. When importing, +`ical-categories' (list of strings) - categories specified in the event +`ical-access' - the event's access classification +`ical-comments' (list of strings) - comments specified in the event +`ical-description' - the event's description +`ical-start' - start date and time in a single string. When importing, includes the date, otherwise just the (local) time. -end - end date and time in a single string. When importing, +`ical-end' - end date and time in a single string. When importing, includes the date, otherwise just the (local) time. -start-to-end - a single string containing both start and end date and +`ical-start-to-end' - a single string containing both start and end date and (local) time. If the event starts and ends on the same day, the date is not repeated. When importing, dates are included, and the string may contain a diary s-exp; when displaying, the string contains only - the times for the displayed date. If there is no end date, same as start. -dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the event - was last revised -duration (an `icalendar-dur-value') - the event's duration -coordinates (an `icalendar-geo-coordinates' value) - the event's geographical - coordinates -geo-location - coordinates, formatted as a string with degrees N/S and E/W -importing (a boolean) - t if the event should be formatted for import. + the times for the displayed date. If there is no end date, same as + `ical-start'. +`ical-importing' (a boolean) - t if the event should be formatted for import. When nil, the event should be formatted for display rather than import. When importing it is important to include all information from the event that you want to be saved in the diary; when displaying, information like the date (or date-related S-expressions) and UID can be left out. -last-modified-dt (an `icalendar-date-time' value) - the date and time the event - was last modified -last-modified - last-modified-dt, formatted as a local date and time string -location - the event's location -nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking -organizer - the event's organizer, formatted by +`ical-location' - the event's location, or geographical coordinates +`ical-nonmarking' (a boolean) - if non-nil, the diary entry should be nonmarking +`ical-organizer' - the event's organizer, formatted by `diary-icalendar-attendee-format-function' -priority (a number) - the event's priority (1 = highest priority, 9 = lowest; - 0 = undefined) -recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the - date or date-time of a particular recurrence of the event -recurrence-id - recurrence-id-dt, formatted as a local date and time string -related-tos (a list of `icalendar-related-to' property nodes) - - these contain the UIDs of related events and their relationship type -request-statuses (a list of `icalendar-request-status' property nodes) - - these contain status information about requests made -resources (a list of strings) - resources used or needed for the event -rrule-sexp - a string containing a diary S-expression for a recurring event. - If this is non-nil, you should normally use it instead of the start-* and - end-* variables to form the date of the entry. -revision (a number) - the revision number of the event; see - `icalendar-sequence' -status - overall status specified by the organizer (e.g. \"confirmed\") -summary - a summary of the event -transparency - the event's time transparency status; see `icalendar-transp' -uid - the unique identifier of the event -url - a URL for the event" +`ical-priority' (a number) - the event's priority (1 = highest priority, + 9 = lowest; 0 = undefined) +`ical-rrule-sexp' - a string containing a diary S-expression for a + recurring event. If this is non-nil, you should normally use it + instead of the start-* and end-* variables to form the date of the + entry. +`ical-status' - overall status specified by the organizer (e.g. \"confirmed\") +`ical-summary' - a summary of the event +`ical-transparency' - the event's time transparency status, either + \"OPAQUE\" (busy) or \"TRANSPARENT\" (free); see `icalendar-transp' +`ical-uid' - the unique identifier of the event +`ical-url' - a URL for the event" :version "31.1" :type '(radio (function-item di:vevent-skeleton) (function :tag "Other function"))) @@ -250,61 +214,46 @@ url - a URL for the event" (defcustom di:vjournal-format-function #'di:vjournal-skeleton "Function to format VJOURNAL components for the diary. -This function is called with no arguments and should insert information -about an `icalendar-vjournal' into the current buffer. It is convenient -to express such a function as a skeleton; see `define-skeleton' and -`skeleton-insert' for more information, and see -`diary-icalendar-vjournal-skeleton' for an example. +This function is called with one argument VJOURNAL, an +`icalendar-vjournal'. It should insert formatted data from this journal +entry into the current buffer. It is convenient to express such a +function as a skeleton; see `define-skeleton' and `skeleton-insert' for +more information, and see `diary-icalendar-vjournal-skeleton' for an +example. See `icalendar-with-component' for a convenient way to bind +the data in VJOURNAL. -The following variables will be bound when the function is called. -All values will be strings unless another type is noted, or nil: +For convenience when writing this function as a skeleton, the following +variables will be (dynamically) bound when the function is called. All +values will be strings unless another type is noted, or nil: -alarms (list of `icalendar-valarm' nodes) - notifications in the journal entry -attachments (list of strings) - URLs or filenames of attachments in the journal - entry -attendees (list of strings) - the participants of the journal entry, +`ical-attachments' (list of strings) - URLs or filenames of attachments + in the journal entry +`ical-attendees' (list of strings) - the participants of the journal entry, formatted by `diary-icalendar-attendee-format-function' -categories (list of strings) - categories specified in the journal entry -access - the journal entry's access classification -comments (list of strings) - comments specified in the journal entry -created-dt (an `icalendar-date-time' value) - the date and time the - journal entry was created -created - created-dt, formatted as a local date-time string -descriptions (list of strings) - the journal entry's descriptions - (more than one description is allowed in iCalendar VJOURNAL components) -dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the - journal entry was last revised -dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the journal - entry starts -start - start date and time in a single string. When importing, +`ical-categories' (list of strings) - categories specified in the journal entry +`ical-access' - the journal entry's access classification +`ical-comments' (list of strings) - comments specified in the journal entry +`ical-description' - the journal entry's description(s) as a single + string, separated by newlines (more than one description is allowed in + VJOURNAL components) +`ical-start' - start date and time in a single string. When importing, includes the date, otherwise just the (local) time. -importing (a boolean) - t if the journal entry should be formatted for import. - When nil, the entry should be formatted for display rather than import. - When importing it is important to include all information from the entry - that you want to be saved in the diary; when displaying, information like - the date (or date-related S-expressions) and UID can be left out. -last-modified-dt (an `icalendar-date-time' value) - the date and time - the journal entry was last modified -last-modified - last-modified-dt, formatted as a local date and time string -nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking -organizer - the journal entry's organizer, formatted by +`ical-importing' (a boolean) - t if the journal entry should be + formatted for import. When nil, the entry should be formatted for + display rather than import. When importing it is important to include + all information from the entry that you want to be saved in the diary; + when displaying, information like the date (or date-related + S-expressions) and UID can be left out. +`ical-nonmarking' (a boolean) - if non-nil, the diary entry should be nonmarking +`ical-organizer' - the journal entry's organizer, formatted by `diary-icalendar-attendee-format-function' -recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the - date or date-time of a particular recurrence of the journal entry -recurrence-id - recurrence-id-dt, formatted as a local date and time string -related-tos (a list of `icalendar-related-to' property nodes) - - these contain the UIDs of related journal entrys and their relationship type -request-statuses (a list of `icalendar-request-status' property nodes) - - these contain status information about requests made -rrule-sexp - a string containing a diary S-expression for a recurring +`ical-rrule-sexp' - a string containing a diary S-expression for a recurring journal entry. If this is non-nil, you should normally use it instead of the start-* variables to form the date of the entry. -revision (a number) - the revision number of the journal entry; see - `icalendar-sequence' -status - overall status specified by the organizer (e.g. \"draft\") -summary - a summary of the journal entry -uid - the unique identifier of the journal entry -url - a URL for the journal entry" +`ical-status' - overall status specified by the organizer (e.g. \"draft\") +`ical-summary' - a summary of the journal entry +`ical-uid' - the unique identifier of the journal entry +`ical-url' - a URL for the journal entry" :version "31.1" :type '(radio (function-item di:vjournal-skeleton) (function :tag "Other function"))) @@ -325,90 +274,69 @@ information." (defcustom di:vtodo-format-function #'di:vtodo-skeleton "Function to format VTODO components for the diary. -This function is called with no arguments and should insert information -about an `icalendar-vtodo' into the current buffer. It is convenient to -express such a function as a skeleton; see `define-skeleton' and -`skeleton-insert' for more information. +This function is called with one argument VTODO, an `icalendar-vtodo'. +It should insert formatted data from this task into the current buffer. +It is convenient to express such a function as a skeleton; see +`define-skeleton' and `skeleton-insert' for more information. See +`icalendar-with-component' for a convenient way to bind the data in +VTODO. -The following variables will be bound when the function is called. -All values will be strings unless another type is noted, or nil: +For convenience when writing this function as a skeleton, the following +variables will be (dynamically) bound when the function is called. All +values will be strings unless another type is noted, or nil: -alarms (list of `icalendar-valarm' nodes) - notifications in the task -as-alarm (symbol) - non-nil when the task should be formatted for an - alarm notification in advance of the task. The symbol indicates the - type of alarm: `email' means to format the task as the body of an email. - (Currently only used for EMAIL alarms; see `diary-icalendar-export-alarms'.) -attachments (list of strings) - URLs or filenames of attachments in the task -attendees (list of strings) - the participants of the task, +`ical-as-alarm' (symbol) - non-nil when the task should be formatted for + an alarm notification in advance of the task. The symbol indicates + the type of alarm: `email' means to format the task as the body of an + email. (Currently only used for EMAIL alarms; see + `diary-icalendar-export-alarms'.) +`ical-attachments' (list of strings) - URLs or filenames of attachments + in the task +`ical-attendees' (list of strings) - the participants of the task, formatted by `diary-icalendar-attendee-format-function' -categories (list of strings) - categories specified in the task -access - the task's access classification -comments (list of strings) - comments specified in the task -completed-dt (an `icalendar-date-time' value) - when the task was completed -completed - completed-dt, formatted as a local date-time string -created-dt (an `icalendar-date-time' value) - when the task was created -created - created-dt, formatted as a local date-time string -description - the task's description -dtstamp (an `icalendar-date' or `icalendar-date-time' value) - when the task - was last revised -dtstart (an `icalendar-date' or `icalendar-date-time' value) - when the task - starts -start - start-date and time in a single string. When importing, +`ical-categories' (list of strings) - categories specified in the task +`ical-access' - the task's access classification +`ical-comments' (list of strings) - comments specified in the task +`ical-completed' - when the task was completed, formatted as a local + date-time string +`ical-description' - the task's description +`ical-start' - start-date and time in a single string. When importing, includes the date, otherwise just the (local) time -start-to-end - a single string containing both start and due date and - time. If the task starts and ends on the same day, the date is not - repeated. When importing, dates are included, and the string may +`ical-start-to-end' - a single string containing both start and due date + and time. If the task starts and ends on the same day, the date is + not repeated. When importing, dates are included, and the string may contain a diary s-exp; when displaying, the string contains only the - times for the displayed date. If there is no end date, same as start. -duration (an `icalendar-dur-value') - the task's duration -due-dt (an `icalendar-date' or `icalendar-date-time' value) - when the - task is due -dtend - same as `due-dt' -due - due date and time in a single string -end - same as `due' -work-time-sexp - when the task has both a start date and a due date, + times for the displayed date. If there is no end date, same as + `ical-start'. +`ical-due' - due date and time in a single string +`ical-end' - same as `ical-due' +`ical-work-time-sexp' - when the task has both a start date and a due date, this is a %%(diary-time-block ...) diary S-expression representing the time from the start date to the due date (only non-nil when importing). You can use this e.g. to make a separate entry for the task's work time, so that it shows up every day in the diary until it is due. -coordinates (an `icalendar-geo-coordinates' value) - the task's geographical - coordinates -geo-location - coordinates, formatted as a string with degrees N/S and E/W -importing (a boolean) - t if the task should be formatted for import. +`ical-importing' (a boolean) - t if the task should be formatted for import. When nil, the task should be formatted for display rather than import. When importing it is important to include all information from the task that you want to be saved in the diary; when displaying, information like the date (or date-related S-expressions) and UID can be left out. -last-modified-dt (an `icalendar-date-time' value) - the date and time the task - was last modified -last-modified - last-modified-dt, formatted as a local date and time string -location - the task's location -nonmarking (a boolean) - if non-nil, the diary entry should be nonmarking -organizer - the task's organizer, formatted by +`ical-location' - the task's location, or geographical coordinates +`ical-nonmarking' (a boolean) - if non-nil, the diary entry should be nonmarking +`ical-organizer' - the task's organizer, formatted by `diary-icalendar-attendee-format-function' -percent-complete (a number between 0 and 100) - the percentage of the task which - has already been completed -priority (a number) - the task's priority (1 = highest priority, 9 = lowest; - 0 = undefined) -recurrence-id-dt (an `icalendar-date' or `icalendar-date-time' value) - the - date or date-time of a particular recurrence of the task -recurrence-id - recurrence-id-dt, formatted as a local date and time string -related-tos (a list of `icalendar-related-to' property nodes) - - these contain the UIDs of related tasks and their relationship type -request-statuses (a list of `icalendar-request-status' property nodes) - - these contain status information about requests made -resources (a list of strings) - resources used or needed for the task -rrule-sexp - a string containing a diary S-expression for a recurring task - (only non-nil when importing). When this is non-nil, you should - normally use it instead of the start and end variables to form the - date of the entry. -revision (a number) - the revision number of the task; see - `icalendar-sequence' -status - overall status specified by the organizer (e.g. \"confirmed\") -summary - a summary of the task -uid - the unique identifier of the task -url - a URL for the task" +`ical-percent-complete' (a number between 0 and 100) - the percentage of + the task which has already been completed +`ical-priority' (a number) - the task's priority (1 = highest priority, + 9 = lowest; 0 = undefined) +`ical-rrule-sexp' - a string containing a diary S-expression for a + recurring task (only non-nil when importing). When this is non-nil, + you should normally use it instead of the start and end variables to + form the date of the entry. +`ical-status' - overall status specified by the organizer (e.g. \"confirmed\") +`ical-summary' - a summary of the task +`ical-uid' - the unique identifier of the task +`ical-url' - a URL for the task" :version "31.1" :type '(radio (function-item di:vjournal-skeleton) (function :tag "Other function"))) @@ -1178,7 +1106,7 @@ Adds a message to current binding of `help-form' explaining how." ;; important and relatively complex, another skeleton ;; (`di:attendee-skeleton') takes care of formatting these for the ;; top-level component skeletons. -(define-skeleton di:attendee-skeleton +(defun di:attendee-skeleton (attendee) "Default skeleton to format an `icalendar-attendee' for the diary. Includes any data from the attendee's `icalendar-cnparam' and @@ -1192,13 +1120,18 @@ or Baz Foo or Baz Foo (declined)" - nil - ;; skip non-human "attendees": - (when (or (not cutype) (equal cutype "INDIVIDUAL") (equal cutype "GROUP")) - '(nil - cn - (format " <%s>" address) - (when partstat (format " (%s)" (downcase partstat)))))) + (ignore attendee) ; we only need the `attendee-' vars below + (with-suppressed-warnings ((free-vars attendee-cutype)) + ;; skip non-human "attendees": + (when (or (not attendee-cutype) + (equal attendee-cutype "INDIVIDUAL") + (equal attendee-cutype "GROUP")) + (skeleton-insert + '(nil + attendee-cn + (format " <%s>" attendee-address) + (when attendee-partstat + (format " (%s)" (downcase attendee-partstat)))))))) (defun di:format-attendee (attendee) "Format ATTENDEE for the diary. @@ -1211,130 +1144,115 @@ attendee's address matches the regexp in (ical:with-property attendee ((ical:cutypeparam :value cutype) (ical:cnparam :value cn) - (ical:memberparam :values member) (ical:roleparam :value role) (ical:partstatparam :value partstat) - (ical:rsvpparam :value rsvp) - (ical:deltoparam :values delto) - (ical:delfromparam :values delfrom) - (ical:sentbyparam :value sentby) - (ical:dirparam :value dir) - (ical:languageparam :value language)) - (calendar-dlet - ((full-address value) - (address (ical:strip-mailto value)) - (cn (when cn (string-trim cn))) - (cutype cutype) - (dir dir) - (role role) - (partstat partstat) - (rsvp rsvp) - (delfrom-full-addresses delfrom) - (delfrom-addresses - (mapcar #'ical:strip-mailto delfrom)) - (delto-full-addresses delto) - (delto-addresses - (mapcar #'ical:strip-mailto delto)) - (member-full-addresses member) - (member-addresses - (mapcar #'ical:strip-mailto member)) - (sentby-full-address sentby) - (sentby-address - (when sentby (ical:strip-mailto sentby))) - (language language)) - (unless (and di:skip-addresses-regexp - (string-match-p di:skip-addresses-regexp full-address)) + (ical:rsvpparam :value rsvp)) + (unless (and di:skip-addresses-regexp + (string-match-p di:skip-addresses-regexp value)) + (dlet ((attendee-address (ical:strip-mailto value)) + (attendee-cn (when cn (string-trim cn))) + (attendee-cutype cutype) + (attende-role role) + (attendee-partstat partstat) + (attendee-rsvp rsvp)) (with-temp-buffer - (funcall di:attendee-format-function) + (funcall di:attendee-format-function attendee) (buffer-string)))))) -(define-skeleton di:vevent-skeleton +(defun di:vevent-skeleton (vevent) "Default skeleton to format an `icalendar-vevent' for the diary." - nil - (when (or non-marking (equal transparency "TRANSPARENT")) - diary-nonmarking-symbol) - (or rrule-sexp start-to-end start) & " " - summary "\n" - @ ; start of body (for indentation) - (when (or location geo-location) "Location: ") (or location geo-location) - & "\n" (when url "URL: ") & url - & "\n" (when status "Status: ") & status - & "\n" (when organizer "Organizer: ") & organizer - & "\n" (di:format-list attendees "Attendee") - & "\n" (di:format-list categories "Category" "Categories") - & "\n" (di:format-list comments "Comment") - & "\n" (di:format-list contacts "Contact") - & "\n" (di:format-list attachments "Attachment") - & "\n" (when (and importing access) "Access: ") & access - & "\n" (when (and importing uid) "UID: ") & uid - & "\n" (when description "Description: ") & description - & "\n" - @ ; end of body - (let* ((end (pop skeleton-positions)) - (start (pop skeleton-positions))) - ;; TODO: should diary define a customizable indentation level? - ;; For now, we use 1 because that's what icalendar.el chose - (indent-code-rigidly start end 1) - nil) ; Don't insert return value - (when importing "\n")) + (ignore vevent) ; we only need the dynamic `ical-*' variables here + (skeleton-insert + '(nil + (when (or ical-nonmarking (equal ical-transparency "TRANSPARENT")) + diary-nonmarking-symbol) + (or ical-rrule-sexp ical-start-to-end ical-start) & " " + ical-summary "\n" + @ ; start of body (for indentation) + (when ical-location "Location: ") ical-location + & "\n" (when ical-url "URL: ") & ical-url + & "\n" (when ical-status "Status: ") & ical-status + & "\n" (when ical-organizer "Organizer: ") & ical-organizer + & "\n" (di:format-list ical-attendees "Attendee") + & "\n" (di:format-list ical-categories "Category" "Categories") + & "\n" (di:format-list ical-comments "Comment") + & "\n" (di:format-list ical-contacts "Contact") + & "\n" (di:format-list ical-attachments "Attachment") + & "\n" (when (and ical-importing ical-access) "Access: ") & ical-access + & "\n" (when (and ical-importing ical-uid) "UID: ") & ical-uid + & "\n" (when ical-description "Description: ") & ical-description + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + ;; TODO: should diary define a customizable indentation level? + ;; For now, we use 1 because that's what icalendar.el chose + (indent-code-rigidly start end 1) + nil) ; Don't insert return value + (when ical-importing "\n")))) -(define-skeleton di:vjournal-skeleton +(defun di:vjournal-skeleton (vjournal) "Default skeleton to format an `icalendar-vjournal' for the diary." - nil - (when (or non-marking di:import-vjournal-as-nonmarking) - diary-nonmarking-symbol) - (or rrule-sexp start) & " " - summary "\n" - @ ; start of body (for indentation) - & "\n" (when url "URL: ") & url - & "\n" (when status "Status: ") & status - & "\n" (when organizer "Organizer: ") & organizer - & "\n" (di:format-list attendees "Attendee") - & "\n" (di:format-list categories "Category" "Categories") - & "\n" (di:format-list comments "Comment") - & "\n" (di:format-list contacts "Contact") - & "\n" (di:format-list attachments "Attachment") - & "\n" (when (and importing access) "Access: ") & access - & "\n" (when (and importing uid) "UID: ") & uid - ;; In a vjournal, multiple `icalendar-description's are allowed: - & "\n" (di:format-list descriptions "Description") - & "\n" - @ ; end of body - (let* ((end (pop skeleton-positions)) - (start (pop skeleton-positions))) - (indent-code-rigidly start end 1) - nil) ; Don't insert return value - (when importing "\n")) + (ignore vjournal) ; we only need the dynamic `ical-*' variables here + (skeleton-insert + '(nil + (when (or ical-nonmarking di:import-vjournal-as-nonmarking) + diary-nonmarking-symbol) + (or ical-rrule-sexp ical-start) & " " + ical-summary "\n" + @ ; start of body (for indentation) + & "\n" (when ical-url "URL: ") & ical-url + & "\n" (when ical-status "Status: ") & ical-status + & "\n" (when ical-organizer "Organizer: ") & ical-organizer + & "\n" (di:format-list ical-attendees "Attendee") + & "\n" (di:format-list ical-categories "Category" "Categories") + & "\n" (di:format-list ical-comments "Comment") + & "\n" (di:format-list ical-contacts "Contact") + & "\n" (di:format-list ical-attachments "Attachment") + & "\n" (when (and ical-importing ical-access) "Access: ") & ical-access + & "\n" (when (and ical-importing ical-uid) "UID: ") & ical-uid + ;; In a vjournal, multiple `icalendar-description's are allowed: + & "\n" (di:format-list ical-descriptions "Description") + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + (indent-code-rigidly start end 1) + nil) ; Don't insert return value + (when ical-importing "\n")))) -(define-skeleton di:vtodo-skeleton +(defun di:vtodo-skeleton (vtodo) "Default skeleton to format an `icalendar-vtodo' for the diary." - nil - (when non-marking diary-nonmarking-symbol) - (or rrule-sexp due) & " " - (when due "Due: ") summary - (when start (concat " (Start: " start ")")) - "\n" - @ ; start of body (for indentation) - & "\n" (when url "URL: ") & url - & "\n" (when status "Status: ") & status - & "\n" (when completed "Completed: ") & completed - & "\n" (when percent-complete (format "Progress: %d%%" percent-complete)) - & "\n" (when organizer "Organizer: ") & organizer - & "\n" (di:format-list attendees "Attendee") - & "\n" (di:format-list categories "Category" "Categories") - & "\n" (di:format-list comments "Comment") - & "\n" (di:format-list contacts "Contact") - & "\n" (di:format-list attachments "Attachment") - & "\n" (when (and importing access) "Access: ") & access - & "\n" (when (and importing uid) "UID: ") & uid - & "\n" (when description "Description: ") & description - & "\n" - @ ; end of body - (let* ((end (pop skeleton-positions)) - (start (pop skeleton-positions))) - (indent-code-rigidly start end 1) - nil) ; Don't insert return value - (when importing "\n")) + (ignore vtodo) ; we only need the dynamic `ical-*' variables here + (skeleton-insert + '(nil + (when ical-nonmarking diary-nonmarking-symbol) + (or ical-rrule-sexp ical-due) & " " + (when ical-due "Due: ") summary + (when start (concat " (Start: " ical-start ")")) + "\n" + @ ; start of body (for indentation) + & "\n" (when ical-url "URL: ") & ical-url + & "\n" (when ical-status "Status: ") & ical-status + & "\n" (when ical-completed "Completed: ") & ical-completed + & "\n" (when ical-percent-complete + (format "Progress: %d%%" ical-percent-complete)) + & "\n" (when ical-organizer "Organizer: ") & ical-organizer + & "\n" (di:format-list ical-attendees "Attendee") + & "\n" (di:format-list ical-categories "Category" "Categories") + & "\n" (di:format-list ical-comments "Comment") + & "\n" (di:format-list ical-contacts "Contact") + & "\n" (di:format-list ical-attachments "Attachment") + & "\n" (when (and ical-importing ical-access) "Access: ") & ical-access + & "\n" (when (and ical-importing ical-uid) "UID: ") & ical-uid + & "\n" (when ical-description "Description: ") & ical-description + & "\n" + @ ; end of body + (let* ((end (pop skeleton-positions)) + (start (pop skeleton-positions))) + (indent-code-rigidly start end 1) + nil) ; Don't insert return value + (when ical-importing "\n")))) ;;; Further utilities for formatting/importing special kinds of values: (defun di:format-geo-coordinates (geo) @@ -1651,7 +1569,7 @@ Depending on the type of COMPONENT, the body will be formatted by one of: `diary-icalendar-vjournal-format-function' which see. -The variable `nonmarking' will be bound to the value of NONMARKING in +The variable `ical-nonmarking' will be bound to the value of NONMARKING in the relevant skeleton command. If it is non-nil, the user requested the entry to be nonmarking. @@ -1664,36 +1582,27 @@ Returns a string containing the diary entry." (ical:comment :all comment-nodes) (ical:completed :value completed-dt) (ical:contact :all contact-nodes) - (ical:created :value created-dt) (ical:description :value description) ;; in `icalendar-vjournal', multiple `icalendar-description' ;; nodes are allowed: (ical:description :all description-nodes) (ical:dtend :first dtend-node :value dtend) - (ical:dtstamp :value dtstamp) (ical:dtstart :first dtstart-node :value dtstart) (ical:duration :value duration) (ical:due :first due-node :value due-dt) (ical:geo :value geo) - (ical:last-modified :value last-modified-dt) (ical:location :value location) (ical:organizer :first organizer-node ; for skeleton formatting :value organizer-addr) ; for legacy formatting (ical:percent-complete :value percent-complete) (ical:priority :value priority) - (ical:recurrence-id :first recurrence-id-node :value recurrence-id-dt) - (ical:related-to :all related-to-nodes) - (ical:request-status :all request-status-nodes) - (ical:resources :all resources-nodes) (ical:rrule :value rrule) (ical:rdate :all rdate-nodes) - (ical:sequence :value revision) (ical:status :value status) (ical:summary :value summary) (ical:transp :value transp) (ical:uid :value uid) - (ical:url :value url) - (ical:valarm :all alarms)) + (ical:url :value url)) (let* ((is-recurring (or rdate-nodes rrule)) (start-tz (when dtstart-node (ical:with-property dtstart-node @@ -1723,66 +1632,58 @@ Returns a string containing the diary entry." (duration start-tz))) (end-tzname (when end-tz (icr:tzname-on dtend end-tz))) (component-type (ical:ast-node-type component))) - (calendar-dlet - (;; TODO: interpret alarms? Diary has its own mechanism for - ;; this (but no syntax). We could theoretically use alarms to - ;; set up notifications. For now we just pass them on to - ;; user skeletons, so users can do this if desired. - (alarms alarms) - (attachments + (dlet + ;; We use "ical-" rather than "icalendar-" as prefix for these + ;; vars because (a) it's shorter and (b) to avoid shadowing + ;; any library symbols: + ((ical-attachments (when attach-nodes (di:save-attachments-from attach-nodes uid))) - (attendees (mapcar #'di:format-attendee attendee-nodes)) - (categories + (ical-attendees (mapcar #'di:format-attendee attendee-nodes)) + (ical-categories (mapcan (lambda (node) (mapcar #'ical:text-to-string (ical:ast-node-value node))) categories-nodes)) - (access (when access (downcase access))) - (comments + (ical-access (when access (downcase access))) + (ical-comments (mapcar (lambda (node) (ical:text-to-string (ical:ast-node-value node))) comment-nodes)) - (contacts + (ical-contacts (mapcar (lambda (node) (ical:text-to-string (ical:ast-node-value node))) contact-nodes)) - (completed-dt completed-dt) - (completed + (ical-completed (when completed-dt (di:format-date/time-as-local completed-dt))) - (created-dt created-dt) - (created - (when created-dt (di:format-date/time-as-local created-dt))) - (description (when description (di:-nonempty description))) - (descriptions - (when (eq 'icalendar-vjournal component-type) - (mapcar + (ical-description + (if (eq 'icalendar-vjournal component-type) + (mapconcat (lambda (node) (di:-nonempty (ical:text-to-string (ical:ast-node-value node)))) - description-nodes))) - (dtstart dtstart) - (start + description-nodes + "\n\n") + (di:-nonempty description))) + (ical-start (when dtstart - (if (bound-and-true-p importing) + (if (bound-and-true-p ical-importing) (di:format-date/time-as-local dtstart start-tzname) (di:format-time-as-local dtstart start-tzname)))) - (dtend dtend) - (end + (ical-end (when dtend - (if (bound-and-true-p importing) + (if (bound-and-true-p ical-importing) (di:format-date/time-as-local dtend end-tzname) (di:format-time-as-local dtend end-tzname)))) - (dtstamp dtstamp) - (start-to-end + (ical-start-to-end (with-suppressed-warnings ((lexical date) (free-vars date)) (cond ((not dtstart) nil) ((or (not dtend) (equal dtstart dtend)) ;; without a distinct DTEND/DUE, same as start: - (if (bound-and-true-p importing) + (if (bound-and-true-p ical-importing) (di:format-date/time-as-local dtstart start-tzname) (di:format-time-as-local dtstart start-tzname))) - ((and (bound-and-true-p importing) + ((and (bound-and-true-p ical-importing) (cl-typep dtstart 'ical:date) (cl-typep dtend 'ical:date)) ;; Importing two dates: @@ -1793,13 +1694,13 @@ Returns a string containing the diary entry." ;; diary-block needs an inclusive bound, so ;; subtract a day: (ical:date-add dtend :day -1))) - ((and (bound-and-true-p importing) + ((and (bound-and-true-p ical-importing) (equal (ical:date/time-to-date dtstart-local) (ical:date/time-to-date dtend-local))) ;; Importing, start and end times on same day: ;; DATE HH:MM-HH:MM (di:format-time-range dtstart-local dtend-local)) - ((bound-and-true-p importing) + ((bound-and-true-p ical-importing) ;; Importing at least one date-time, on different days: ;; %%(diary-time-block :start ... :end ...) (di:format-time-block-sexp dtstart-local dtend-local)) @@ -1836,51 +1737,31 @@ Returns a string containing the diary entry." (t ;; That's all the cases we care about here. nil)))) - (duration duration) - (due-dt - (when (eq component-type 'ical:vtodo) - ;; in VTODO, DUE does the job of DTEND, so we alias them; - ;; see above - dtend)) - (due + (ical-due (when (eq component-type 'ical:vtodo) (if due-node (di:format-date/time-as-local due-dt due-tzname) ;; here we use start-tzname because due/dtend is calculated from ;; dtstart, not its own node with a tzid: (di:format-date/time-as-local dtend start-tzname)))) - (work-time-sexp - (when (and dtstart due-dt (bound-and-true-p importing)) + (ical-work-time-sexp + (when (and dtstart due-dt (bound-and-true-p ical-importing)) (di:format-time-block-sexp dtstart-local due-dt))) - (coordinates geo) - (geo-location (when geo (di:format-geo-coordinates geo))) - (importing (bound-and-true-p importing)) - (last-modified-dt last-modified-dt) - (last-modified (di:format-date/time-as-local last-modified-dt)) - (location (di:-nonempty location)) - (nonmarking nonmarking) - (organizer (di:format-attendee organizer-node)) - (percent-complete percent-complete) - (priority priority) - (recurrence-id-dt recurrence-id-dt) - (recurrence-id - (di:format-date/time-as-local recurrence-id-dt)) - (related-tos related-to-nodes) - (request-statuses request-status-nodes) - (resources - (mapcan - (lambda (node) - (mapcar #'ical:text-to-string (ical:ast-node-value node))) - resources-nodes)) - (rrule-sexp - (when (and is-recurring (bound-and-true-p importing)) + (ical-importing (bound-and-true-p ical-importing)) + (ical-location (or (di:-nonempty location) + (when geo (di:format-geo-coordinates geo)))) + (ical-nonmarking nonmarking) + (ical-organizer (di:format-attendee organizer-node)) + (ical-percent-complete percent-complete) + (ical-priority priority) + (ical-rrule-sexp + (when (and is-recurring (bound-and-true-p ical-importing)) (di:format-rrule-sexp component))) - (revision revision) - (status (when status (di:-nonempty (downcase status)))) - (summary (di:-nonempty summary)) - (transparency transp) - (uid (di:-nonempty uid)) - (url (di:-nonempty url))) + (ical-status (when status (di:-nonempty (downcase status)))) + (ical-summary (di:-nonempty summary)) + (ical-transparency transp) + (ical-uid (di:-nonempty uid)) + (ical-url (di:-nonempty url))) (with-temp-buffer (cl-case (ical:ast-node-type component) (ical:vevent @@ -1894,13 +1775,16 @@ Returns a string containing the diary entry." (if (functionp ical:import-format) (insert (funcall ical:import-format (di:-vevent-to-legacy-alist component))) - (di:-format-vevent-legacy (or rrule-sexp start-to-end start) - access description location - organizer-addr - summary status url uid)) - (funcall di:vevent-format-function)))) - (ical:vtodo (funcall di:vtodo-format-function)) - (ical:vjournal (funcall di:vjournal-format-function))) + (di:-format-vevent-legacy (or ical-rrule-sexp + ical-start-to-end + ical-start) + ical-access ical-description + ical-location organizer-addr + ical-summary ical-status + ical-url ical-uid)) + (funcall di:vevent-format-function component)))) + (ical:vtodo (funcall di:vtodo-format-function component)) + (ical:vjournal (funcall di:vjournal-format-function component))) (buffer-string)))))) @@ -2007,7 +1891,7 @@ in the `diary-icalendar' group." entry-start) (with-current-buffer import-buf - (calendar-dlet ((importing t)) ; inform skeletons we're importing + (dlet ((ical-importing t)) ; inform skeletons we're importing (dolist (component to-import) (setq entry-start (point)) (insert (di:format-entry component index all-nonmarking)) @@ -2962,7 +2846,7 @@ formatting alarms as mail messages. Returns the modified COMPONENT." (nth 2 opts)))) (index (ical:index-insert-tz (ical:make-index) vtimezone)) (body - (calendar-dlet ((as-alarm 'email)) + (dlet ((ical-as-alarm 'email)) (di:format-entry component index))) (addresses (nth 3 opts)) all-attendees) From 74750e269b978b5a18329642d4370fdea2b536c1 Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Sun, 28 Dec 2025 15:03:09 +0100 Subject: [PATCH 023/191] Some minor code improvements in iCalendar library * lisp/calendar/icalendar-mode.el: Update file header. Fix error display in 'icalendar-errors-mode': * lisp/calendar/icalendar.el (icalendar-error-regexp): Fix to allow " *UNFOLDED:" prefix in buffer names. (Extra colon was breaking match.) (icalendar-format-error): Suppress this prefix preferentially in long buffer names. Add declarations to some iCalendar macros: * lisp/calendar/icalendar-macs.el (icalendar-with-node-value) (icalendar-with-child-of) (icalendar-with-param-of) (icalendar-with-node-children) (icalendar-with-node-value) (icalendar-with-param) * lisp/calendar/icalendar-ast.el (icalendar-make-property) (icalendar-make-component) (icalendar-make-node-from-templates): Add (declare ...) forms. Add `icalendar-trimp' to icalendar-utils.el: * lisp/calendar/icalendar-utils.el (icalendar-trimp): New function. * lisp/calendar/diary-icalendar.el (diary-icalendar-format-entry) (diary-icalendar-parse-attendees-and-organizer) (diary-icalendar-parse-location) (diary-icalendar-parse-url) (diary-icalendar-parse-uid): Use it to replace diary-icalendar--nonempty. (diary-icalendar--nonempty): Remove. Move VTIMEZONE creation to icalendar-recur.el: The following changes move `diary-icalendar-current-tz-to-vtimezone' and associated code to icalendar-recur.el. Library users are likely to need this function, so it makes sense to keep it with other time zone-related code in that file, instead of having them depend on diary-icalendar. * lisp/calendar/icalendar-recur.el (icalendar-tz-data-insufficient) (icalendar-tz-unsupported): New error types. (icalendar-recur-current-tz-to-vtimezone): Rename from `diary-icalendar-current-tz-to-vtimezone'; signal new error types. (icalendar-recur--tz-warning): Rename from `diary-icalendar--tz-warning'. (icalendar-recur--emacs-local-tzid): Rename from `diary-icalendar--emacs-local-tzid'. (icalendar-recur--tz-info-sexp-p): Rename from `diary-icalendar--tz-info-sexp-p'. * lisp/calendar/diary-icalendar.el (diary-icalendar-current-tz-to-vtimezone): Reimplement with `icalendar-recur-current-tz-to-vtimezone'. (diary-icalendar--tz-warning) (diary-icalendar--emacs-local-tzid) (diary-icalendar--tz-info-sexp-p): Renamed and moved; see above. (diary-time-zone-export-strategy): Update validation function name. --- lisp/calendar/diary-icalendar.el | 168 ++++--------------------------- lisp/calendar/icalendar-ast.el | 9 +- lisp/calendar/icalendar-macs.el | 11 +- lisp/calendar/icalendar-mode.el | 5 +- lisp/calendar/icalendar-recur.el | 155 ++++++++++++++++++++++++++++ lisp/calendar/icalendar-utils.el | 5 + lisp/calendar/icalendar.el | 6 +- 7 files changed, 204 insertions(+), 155 deletions(-) diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index 640e063268a..eed53bfd700 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -673,32 +673,6 @@ recurring events for several years beyond the start time." :version "31.1" :type 'integer) -(defun di:-tz-info-sexp-p (_ sexp) - "Validate that SEXP gives time zone info like from `calendar-current-time-zone'." - (and (listp sexp) - (length= sexp 8) - (let ((utc-diff (nth 0 sexp)) - (dst-offset (nth 1 sexp)) - (std-zone (nth 2 sexp)) - (dst-zone (nth 3 sexp)) - (dst-starts (nth 4 sexp)) - (dst-ends (nth 5 sexp)) - (dst-starts-time (nth 6 sexp)) - (dst-ends-time (nth 7 sexp))) - (and - (integerp utc-diff) (< (abs utc-diff) (* 60 24)) - (integerp dst-offset) (< (abs utc-diff) (* 60 24)) - (stringp std-zone) - (stringp dst-zone) - (or (and (listp dst-starts) (memq 'year (flatten-list dst-starts))) - (and (null dst-starts) (equal std-zone dst-zone))) - (or (and (listp dst-ends) (memq 'year (flatten-list dst-ends))) - (and (null dst-ends) (equal std-zone dst-zone))) - (or (and (integerp dst-starts-time) (< (abs dst-starts-time) (* 60 24))) - (null dst-starts-time)) - (or (and (integerp dst-ends-time) (< (abs dst-ends-time) (* 60 24))) - (null dst-ends-time)))))) - (defcustom di:time-zone-export-strategy 'local "Strategy to use for exporting clock times in diary files. @@ -741,7 +715,7 @@ the events you are exporting." (const :tag "Convert local times to UTC" to-utc) (const :tag "Use floating times" floating) (sexp :tag "User-provided TZ information" - :match di:-tz-info-sexp-p + :match icr:-tz-info-sexp-p :type-error "See `calendar-current-time-zone' for format")) :link '(url-link "https://www.rfc-editor.org/rfc/rfc5545#section-3.3.5")) @@ -989,12 +963,6 @@ new code." ;;; Other utilities -(defsubst di:-nonempty (s) - "Ensure that string S is nonempty once trimmed: return the trimmed S, or nil." - (when (and s (stringp s)) - (let ((trimmed (string-trim s))) - (unless (equal "" trimmed) trimmed)))) - (defconst di:entry-regexp (rx line-start (group-n 1 ; first line of entry @@ -1660,10 +1628,10 @@ Returns a string containing the diary entry." (if (eq 'icalendar-vjournal component-type) (mapconcat (lambda (node) - (di:-nonempty (ical:text-to-string (ical:ast-node-value node)))) + (ical:trimp (ical:text-to-string (ical:ast-node-value node)))) description-nodes "\n\n") - (di:-nonempty description))) + (ical:trimp description))) (ical-start (when dtstart (if (bound-and-true-p ical-importing) @@ -1748,7 +1716,7 @@ Returns a string containing the diary entry." (when (and dtstart due-dt (bound-and-true-p ical-importing)) (di:format-time-block-sexp dtstart-local due-dt))) (ical-importing (bound-and-true-p ical-importing)) - (ical-location (or (di:-nonempty location) + (ical-location (or (ical:trimp location) (when geo (di:format-geo-coordinates geo)))) (ical-nonmarking nonmarking) (ical-organizer (di:format-attendee organizer-node)) @@ -1757,11 +1725,11 @@ Returns a string containing the diary entry." (ical-rrule-sexp (when (and is-recurring (bound-and-true-p ical-importing)) (di:format-rrule-sexp component))) - (ical-status (when status (di:-nonempty (downcase status)))) - (ical-summary (di:-nonempty summary)) + (ical-status (when status (ical:trimp (downcase status)))) + (ical-summary (ical:trimp summary)) (ical-transparency transp) - (ical-uid (di:-nonempty uid)) - (ical-url (di:-nonempty url))) + (ical-uid (ical:trimp uid)) + (ical-url (ical:trimp url))) (with-temp-buffer (cl-case (ical:ast-node-type component) (ical:vevent @@ -2108,7 +2076,7 @@ parsed as an `icalendar-organizer' node, or otherwise as an (unless (string-match ":" addr) ; URI scheme already present (setq addr (concat "mailto:" addr))) (when cn - (setq cn (di:-nonempty cn))) + (setq cn (ical:trimp cn))) (if (string-match di:organizer-regexp (buffer-substring (line-beginning-position) (line-end-position))) @@ -2130,7 +2098,7 @@ this node, or nil." (goto-char (point-min)) (when (and di:location-regexp (re-search-forward di:location-regexp nil t)) - (ical:make-property ical:location (di:-nonempty (match-string 1))))) + (ical:make-property ical:location (ical:trimp (match-string 1))))) (defun di:parse-class () "Parse `icalendar-class' node from entry. @@ -2166,7 +2134,7 @@ Searches the entry in the current restriction for an URL matching (goto-char (point-min)) (when (and di:url-regexp (re-search-forward di:url-regexp nil t)) - (ical:make-property ical:url (di:-nonempty (match-string 1))))) + (ical:make-property ical:url (ical:trimp (match-string 1))))) (defun di:parse-uid () "Parse `icalendar-uid' node from entry. @@ -2177,7 +2145,7 @@ Searches the entry in the current restriction for a UID matching (goto-char (point-min)) (when (and di:uid-regexp (re-search-forward di:uid-regexp nil t)) - (ical:make-property ical:uid (di:-nonempty (match-string 1))))) + (ical:make-property ical:uid (ical:trimp (match-string 1))))) (defun di:parse-summary-and-description () "Parse summary and description nodes from current restriction. @@ -3136,112 +3104,18 @@ times according to `diary-icalendar-time-zone-export-strategy'." ;;; Time zone handling during export: -(defconst di:-tz-warning - "This time zone information was inferred from incomplete system information; it should be correct for the date-times within this calendar file referencing this zone, but you should not rely on it more widely.") - -(defconst di:-emacs-local-tzid - "Emacs_Local_") - (defun di:current-tz-to-vtimezone (&optional tz tzid start-year) "Convert TZ to an `icalendar-vtimezone'. -TZ defaults to the output of `calendar-current-time-zone'; if specified, -it should be a list of the same form as that function returns. - -TZID, if specified, should be a string to identify this time zone; it -defaults to `diary-icalendar--emacs-local-tzid' plus the name of the -standard observance according to `calendar-current-time-zone'. - -START-YEAR, if specified, should be an integer giving the year in which -to start the observances in the time zone. It defaults to 1970." - (when (and tz (not (di:-tz-info-sexp-p nil tz))) - (di:signal-export-error - (format "Invalid time zone data: %s.\n%s." tz - "Check the value of `diary-icalendar-time-zone-export-strategy'"))) - (let* ((tzdata (or tz (calendar-current-time-zone))) - (std-offset (* 60 (nth 0 tzdata))) - (dst-offset (+ std-offset - (* 60 (nth 1 tzdata)))) - (std-name (nth 2 tzdata)) - (dst-name (nth 3 tzdata)) - (dst-starts (nth 4 tzdata)) - (dst-ends (nth 5 tzdata)) - (dst-start-minutes (nth 6 tzdata)) - (dst-end-minutes (nth 7 tzdata))) - - (unless (and std-offset - (or (equal std-name dst-name) - (and dst-starts dst-ends dst-start-minutes dst-end-minutes))) - (di:signal-export-error - "Insufficient time zone information to create VTIMEZONE")) - - (if (equal std-name dst-name) - ;; Local time zone doesn't use DST: - (ical:make-vtimezone - (ical:tzid (or tzid (concat di:-emacs-local-tzid std-name))) - (ical:make-standard - (ical:tzname std-name) - (ical:dtstart (ical:make-date-time :year (or start-year 1970) - :month 1 :day 1 - :hour 0 :minute 0 :second 0)) - (ical:tzoffsetfrom std-offset) - (ical:tzoffsetto std-offset) - (ical:comment di:-tz-warning))) - - ;; Otherwise we can provide both STANDARD and DAYLIGHT subcomponents: - (let* ((std->dst-rule - (if (eq (car dst-starts) 'calendar-nth-named-day) - `((FREQ YEARLY) - (BYMONTH (,(nth 3 dst-starts))) - (BYDAY (,(cons (nth 2 dst-starts) - (nth 1 dst-starts))))) - ;; The only other rules that `calendar-current-time-zone' - ;; can return are based on the Persian calendar, which we - ;; cannot express in an `icalendar-recur' value, at least - ;; pending an implementation of RFC 7529 - (di:signal-export-error - (format "Unable to export DST rule for current time zone: %s" - dst-starts)))) - (dst-start-date (calendar-dlet ((year (or start-year 1970))) - (eval dst-starts))) - (dst-start - (ical:date-to-date-time dst-start-date - :hour (/ dst-start-minutes 60) - :minute (mod dst-start-minutes 60) - :second 0)) - (dst->std-rule - (if (eq (car dst-ends) 'calendar-nth-named-day) - `((FREQ YEARLY) - (BYMONTH (,(nth 3 dst-ends))) - (BYDAY (,(cons (nth 2 dst-ends) - (nth 1 dst-ends))))) - (di:signal-export-error - (format "Unable to export DST rule for current time zone: %s" - dst-ends)))) - (std-start-date (calendar-dlet ((year (1- (or start-year 1970)))) - (eval dst-ends))) - (std-start - (ical:date-to-date-time std-start-date - :hour (/ dst-end-minutes 60) - :minute (mod dst-end-minutes 60) - :second 0))) - - (ical:make-vtimezone - (ical:tzid (or tzid (concat di:-emacs-local-tzid std-name))) - (ical:make-standard - (ical:tzname std-name) - (ical:dtstart std-start) - (ical:rrule dst->std-rule) - (ical:tzoffsetfrom dst-offset) - (ical:tzoffsetto std-offset) - (ical:comment di:-tz-warning)) - (ical:make-daylight - (ical:tzname dst-name) - (ical:dtstart dst-start) - (ical:rrule std->dst-rule) - (ical:tzoffsetfrom std-offset) - (ical:tzoffsetto dst-offset) - (ical:comment di:-tz-warning))))))) +See `icalendar-recur-current-tz-to-vtimezone' for arguments' meanings. +This function wraps that one, but signals `icalendar-diary-export-error' +instead if TZ cannot be converted." + (condition-case err + (icr:current-tz-to-vtimezone tz tzid start-year) + ((ical:tz-insufficient-data ical:tz-unsupported) + (di:signal-export-error + (format "Unable to export time zone data: %s.\n%s." tz + "Check the value of `diary-icalendar-time-zone-export-strategy'"))))) ;;; Parsing complete diary entries: diff --git a/lisp/calendar/icalendar-ast.el b/lisp/calendar/icalendar-ast.el index 795d9dde65a..a84e28d36c1 100644 --- a/lisp/calendar/icalendar-ast.el +++ b/lisp/calendar/icalendar-ast.el @@ -490,7 +490,8 @@ The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." ;; TODO: support `ical:other-property', maybe like ;; (ical:other-property "X-NAME" value ...) - (declare (debug (symbolp form form &rest form))) + (declare (debug (symbolp form form &rest form)) + (indent 2)) (unless (ical:property-type-symbol-p type) (error "Not an iCalendar property type: %s" type)) (let ((value-types (cons (get type 'ical:default-type) @@ -553,7 +554,8 @@ properties. The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." - (declare (debug (symbolp form &rest form))) + (declare (debug (symbolp form &rest form)) + (indent 1)) ;; TODO: support `ical:other-component', maybe like ;; (ical:other-component (:x-name "X-NAME") templates ...) (unless (ical:component-type-symbol-p type) @@ -660,7 +662,8 @@ For example, an iCalendar VEVENT could be written like this: Before the constructed node is returned, it is validated by `icalendar-ast-node-valid-p'." - (declare (debug (symbolp form &rest form))) + (declare (debug (symbolp form &rest form)) + (indent 1)) (cond ((not (ical:type-symbol-p type)) (error "Not an iCalendar type symbol: %s" type)) diff --git a/lisp/calendar/icalendar-macs.el b/lisp/calendar/icalendar-macs.el index fe99cef14bc..852b48012a7 100644 --- a/lisp/calendar/icalendar-macs.el +++ b/lisp/calendar/icalendar-macs.el @@ -830,7 +830,8 @@ Each binding in BINDINGS should be a list of one of the following forms: nodes), or the :value-nodes themselves (if they are not). It is a compile-time error to use the singular keywords with a TYPE that takes multiple values, or the plural keywords with a TYPE that does not." - (declare (indent 2)) + (declare (debug (symbolp form form &rest form)) + (indent 2)) ;; Static checks on the bindings prevent various annoying bugs: (dolist (b bindings) (let ((type (car b)) @@ -1003,6 +1004,8 @@ is equivalent to BINDINGS are passed on to `icalendar-with-node-children' and will be available in BODY; see its docstring for their form." + (declare (debug (symbolp form &optional form &rest form)) + (indent 2)) (let ((vn (gensym "icalendar-node")) (val (gensym "icalendar-value")) (is-list (gensym "is-list"))) @@ -1066,6 +1069,8 @@ node's value. If PARAMETER's value is not a syntax node, then `value' is bound directly to PARAMETER's value, and `value-type' and `value-node' are bound to nil." + (declare (debug (symbolp form &rest form)) + (indent 1)) `(ical:with-node-value ,parameter nil ,@body)) (defmacro ical:with-child-of (node type &optional bindings &rest body) @@ -1084,6 +1089,8 @@ is equivalent to (icalendar-with-child-of some-node some-type nil value) See `icalendar-with-node-children' for the form of BINDINGS." + (declare (debug (symbolp form form &optional form &rest form)) + (indent 3)) (let ((child (gensym "icalendar-node"))) `(let ((,child (ical:ast-node-first-child-of ,type ,node))) (ical:with-node-value ,child ,bindings ,@body)))) @@ -1116,6 +1123,8 @@ symbol `value'; thus (icalendar-with-param-of some-property some-type) is equivalent to (icalendar-with-param-of some-property some-type nil value)" + (declare (debug (symbolp form form &rest form)) + (indent 2)) `(ical:with-child-of ,node ,type nil ,@body)) (provide 'icalendar-macs) diff --git a/lisp/calendar/icalendar-mode.el b/lisp/calendar/icalendar-mode.el index 2fc2aec44ff..c68a912d296 100644 --- a/lisp/calendar/icalendar-mode.el +++ b/lisp/calendar/icalendar-mode.el @@ -1,10 +1,12 @@ ;;; icalendar-mode.el --- Major mode for iCalendar format -*- lexical-binding: t; -*- ;;; -;; Copyright (C) 2024 Richard Lawrence +;; Copyright (C) 2024 Free Software Foundation, Inc. ;; Author: Richard Lawrence +;; Created: October 2024 ;; Keywords: calendar +;; Human-Keywords: calendar, iCalendar ;; This file is part of GNU Emacs. @@ -598,7 +600,6 @@ folding and syntax highlighting. Consider using `visual-line-mode' in ;; TODO: mode-specific menu and context menus ;; TODO: eldoc integration ;; TODO: completion of keywords - ;; TODO: hook for folding in change-major-mode-hook? (progn (setq font-lock-defaults '(ical:font-lock-keywords nil t)))) diff --git a/lisp/calendar/icalendar-recur.el b/lisp/calendar/icalendar-recur.el index 2f9045f278e..e3bee0923a9 100644 --- a/lisp/calendar/icalendar-recur.el +++ b/lisp/calendar/icalendar-recur.el @@ -76,6 +76,7 @@ (require 'icalendar-utils) (require 'cl-lib) (require 'calendar) +(require 'cal-dst) (require 'simple) (require 'seq) (eval-when-compile '(require 'icalendar-macs)) @@ -1478,6 +1479,14 @@ UTC offsets local to that time zone." (define-error 'ical:tz-no-observance "No observance found for date-time" 'ical:error) +(define-error 'ical:tz-data-insufficient + "Insufficient time zone data to create VTIMEZONE" + 'ical:error) + +(define-error 'ical:tz-unsupported + "Time zone rules not expressible as iCalendar RRULE" + 'ical:error) + ;; In RFC5545 Section 3.3.10, we read: "If the computed local start time ;; of a recurrence instance does not exist ... the time of the ;; recurrence instance is interpreted in the same manner as an explicit @@ -1983,7 +1992,153 @@ observance." (observance (car obs/onset))) (ical:with-property-of observance 'ical:tzname))) +(defconst icr:-tz-warning + "This time zone information was inferred from incomplete system information; it should be correct for the date-times within this calendar file referencing this zone, but you should not rely on it more widely.") +(defconst icr:-emacs-local-tzid + "Emacs_Local_") + +(defun icr:-tz-info-sexp-p (_ sexp) + "Validate that SEXP gives time zone info like from `calendar-current-time-zone'." + (and (listp sexp) + (length= sexp 8) + (let ((utc-diff (nth 0 sexp)) + (dst-offset (nth 1 sexp)) + (std-zone (nth 2 sexp)) + (dst-zone (nth 3 sexp)) + (dst-starts (nth 4 sexp)) + (dst-ends (nth 5 sexp)) + (dst-starts-time (nth 6 sexp)) + (dst-ends-time (nth 7 sexp))) + (and + (integerp utc-diff) (< (abs utc-diff) (* 60 24)) + (integerp dst-offset) (< (abs utc-diff) (* 60 24)) + (stringp std-zone) + (stringp dst-zone) + (or (and (listp dst-starts) (memq 'year (flatten-list dst-starts))) + (and (null dst-starts) (equal std-zone dst-zone))) + (or (and (listp dst-ends) (memq 'year (flatten-list dst-ends))) + (and (null dst-ends) (equal std-zone dst-zone))) + (or (and (integerp dst-starts-time) (< (abs dst-starts-time) (* 60 24))) + (null dst-starts-time)) + (or (and (integerp dst-ends-time) (< (abs dst-ends-time) (* 60 24))) + (null dst-ends-time)))))) + +(defun icr:current-tz-to-vtimezone (&optional tz tzid start-year) + "Convert TZ to an `icalendar-vtimezone'. + +TZ defaults to the output of `calendar-current-time-zone'; if specified, +it should be a list of the same form as that function returns. +Depending on TZ, this function might signal the following errors: + +`icalendar-tz-data-insufficient' if the data in TZ is not complete + enough to determine time zone rules. +`icalendar-tz-unsupported' if the data in TZ cannot be expressed as an + RFC5545 `icalendar-rrule' property. + +TZID, if specified, should be a string to identify this time zone; it +defaults to `icalendar-recur--emacs-local-tzid' plus the name of the +standard observance according to `calendar-current-time-zone'. + +START-YEAR, if specified, should be an integer giving the year in which +to start the observances in the time zone. It defaults to 1970." + (when (and tz (not (icr:-tz-info-sexp-p nil tz))) + (signal 'ical:tz-data-insufficient + (list :tz tz + :level 2 + :message + "Badly formed TZ data; see `calendar-current-time-zone'"))) + (let* ((tzdata (or tz (calendar-current-time-zone))) + (std-offset (* 60 (nth 0 tzdata))) + (dst-offset (+ std-offset + (* 60 (nth 1 tzdata)))) + (std-name (nth 2 tzdata)) + (dst-name (nth 3 tzdata)) + (dst-starts (nth 4 tzdata)) + (dst-ends (nth 5 tzdata)) + (dst-start-minutes (nth 6 tzdata)) + (dst-end-minutes (nth 7 tzdata))) + + (unless (and std-offset + (or (equal std-name dst-name) + (and dst-starts dst-ends dst-start-minutes dst-end-minutes))) + (signal 'ical:tz-data-insufficient + (list :tz tz :level 2 + :message "Unable to create VTIMEZONE from TZ"))) + + (if (equal std-name dst-name) + ;; Local time zone doesn't use DST: + (ical:make-vtimezone + (ical:tzid (or tzid (concat icr:-emacs-local-tzid std-name))) + (ical:make-standard + (ical:tzname std-name) + (ical:dtstart (ical:make-date-time :year (or start-year 1970) + :month 1 :day 1 + :hour 0 :minute 0 :second 0)) + (ical:tzoffsetfrom std-offset) + (ical:tzoffsetto std-offset) + (ical:comment icr:-tz-warning))) + + ;; Otherwise we can provide both STANDARD and DAYLIGHT subcomponents: + (let* ((std->dst-rule + (if (eq (car dst-starts) 'calendar-nth-named-day) + `((FREQ YEARLY) + (BYMONTH (,(nth 3 dst-starts))) + (BYDAY (,(cons (nth 2 dst-starts) + (nth 1 dst-starts))))) + ;; The only other rules that `calendar-current-time-zone' + ;; can return are based on the Persian calendar, which we + ;; cannot express in an `icalendar-recur' value, at least + ;; pending an implementation of RFC 7529 + (signal 'ical:tz-unsupported + (list :tz tz + :level 2 + :message + (format "Unable to export DST rule for time zone: %s" + dst-starts))))) + (dst-start-date (calendar-dlet ((year (or start-year 1970))) + (eval dst-starts))) + (dst-start + (ical:date-to-date-time dst-start-date + :hour (/ dst-start-minutes 60) + :minute (mod dst-start-minutes 60) + :second 0)) + (dst->std-rule + (if (eq (car dst-ends) 'calendar-nth-named-day) + `((FREQ YEARLY) + (BYMONTH (,(nth 3 dst-ends))) + (BYDAY (,(cons (nth 2 dst-ends) + (nth 1 dst-ends))))) + (signal 'ical:tz-unsupported + (list :tz tz + :level 2 + :message + (format "Unable to export DST rule for time zone: %s" + dst-ends))))) + (std-start-date (calendar-dlet ((year (1- (or start-year 1970)))) + (eval dst-ends))) + (std-start + (ical:date-to-date-time std-start-date + :hour (/ dst-end-minutes 60) + :minute (mod dst-end-minutes 60) + :second 0))) + + (ical:make-vtimezone + (ical:tzid (or tzid (concat icr:-emacs-local-tzid std-name))) + (ical:make-standard + (ical:tzname std-name) + (ical:dtstart std-start) + (ical:rrule dst->std-rule) + (ical:tzoffsetfrom dst-offset) + (ical:tzoffsetto std-offset) + (ical:comment icr:-tz-warning)) + (ical:make-daylight + (ical:tzname dst-name) + (ical:dtstart dst-start) + (ical:rrule std->dst-rule) + (ical:tzoffsetfrom std-offset) + (ical:tzoffsetto dst-offset) + (ical:comment icr:-tz-warning))))))) (provide 'icalendar-recur) diff --git a/lisp/calendar/icalendar-utils.el b/lisp/calendar/icalendar-utils.el index 28d98304d78..3f8e9d085c2 100644 --- a/lisp/calendar/icalendar-utils.el +++ b/lisp/calendar/icalendar-utils.el @@ -82,6 +82,11 @@ COMPONENT can be any component node." (ical:with-param-of property 'ical:tzidparam nil value)) ;; String manipulation +(defun ical:trimp (s &optional trim-left trim-right) + "Like `string-trim', but return nil if the trimmed string is empty." + (when (and s (stringp s)) + (let ((trimmed (string-trim s trim-left trim-right))) + (unless (equal "" trimmed) trimmed)))) (defun ical:strip-mailto (s) "Remove \"mailto:\" case-insensitively from the start of S." diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index d617e1eb8c5..2e00408564e 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -405,7 +405,7 @@ ERR-BUFFER defaults to the buffer returned by `icalendar-error-buffer'." (group "(" (or (group-n 3 "ERROR") (group-n 4 "WARNING") (group-n 5 "INFO")) ")")) - (group-n 1 (zero-or-more (not ":"))) ":" + (group-n 1 (zero-or-one " *UNFOLDED:") (zero-or-more (not ":"))) ":" (zero-or-one (group-n 2 (one-or-more digit))) ":") "Regexp to match iCalendar errors. @@ -455,7 +455,9 @@ data in ERROR-PLIST, if `icalendar-debug-level' is error-plist)))) ;; Make sure buffer name doesn't take too much space: (when (< 8 (length name)) - (put-text-property 9 (length name) 'display "..." name)) + (if (equal " *UNFOLDED:" (substring name 0 11)) + (put-text-property 0 11 'display "..." name) + (put-text-property 9 (length name) 'display "..." name))) (format "(%s)%s:%s: %s\n%s" level name pos message debug-info))) (defun ical:handle-generic-error (err-data &optional err-buffer) From c4dc5bc76632a75eff17426e7f1b855799296464 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 15:47:18 +0100 Subject: [PATCH 024/191] ; Use 'without-restriction' * lisp/emacs-lisp/package.el (package--suggestion-applies-p): Replace 'save-restriction'+'widen' with 'without-restriction'. --- lisp/emacs-lisp/package.el | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 51dd4f6ef18..6c2f3772d3c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4591,15 +4591,13 @@ SUG should be an element of `package-autosuggest-database'." (and (string-match-p ext (buffer-name)) t)) ((or `(,_ magic-mode-alist ,mag ,_) `(,_ magic-mode-alist ,mag)) - (save-restriction - (widen) + (without-restriction (save-excursion (goto-char (point-min)) (looking-at-p mag)))) ((or `(,_ interpreter-mode-alist ,magic ,_) `(,_ interpreter-mode-alist ,magic)) - (save-restriction - (widen) + (without-restriction (save-excursion (goto-char (point-min)) (and (looking-at auto-mode-interpreter-regexp) From 3a3a9e21c1540873714ce2175d2a4a06d18ce99d Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 15:49:38 +0100 Subject: [PATCH 025/191] Mark 'package-autosuggest-database' as private * admin/scrape-elpa.el (scrape-elpa): * etc/package-autosuggest.eld: * lisp/emacs-lisp/package.el (package-autosuggest-database) (package--autosuggest-suggested, package--suggestion-applies-p) (package--autosuggest-find-candidates) (package--autosuggest-install-and-enable): Rename constant name to add double-dash. --- admin/scrape-elpa.el | 2 +- etc/package-autosuggest.eld | 2 +- lisp/emacs-lisp/package.el | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index bf3846c0fcb..f2b5439d082 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -39,7 +39,7 @@ Please review the results before updating the autosuggest database!" (find-file (expand-file-name "package-autosuggest.eld" data-directory)) (erase-buffer) (lisp-data-mode) - (insert ";; The contents of this file are loaded into `package-autosuggest-database' + (insert ";; The contents of this file are loaded into `package--autosuggest-database' ;; and were automatically generate by scraping ELPA for auto-loaded ;; code using the `scrape-elpa' command. Please avoid updating this ;; file manually! diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index cf8b8288e27..ba27252f0da 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -1,4 +1,4 @@ -;; The contents of this file are loaded into `package-autosuggest-database' +;; The contents of this file are loaded into `package--autosuggest-database' ;; and were automatically generate by scraping ELPA for auto-loaded ;; code using the `scrape-elpa' command. Please avoid updating this ;; file manually! diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6c2f3772d3c..d283bcbc4ae 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4532,7 +4532,7 @@ The list is displayed in a buffer named `*Packages*'." ;;;; Autosuggest -(defconst package-autosuggest-database +(defconst package--autosuggest-database (eval-when-compile (with-temp-buffer (insert-file-contents @@ -4573,14 +4573,14 @@ the existence of a suggestion." (defvar package--autosuggest-suggested '() "List of packages that have already been suggested. The elements of this list should be a subset of elements from -`package-autosuggest-database'. Suggestions found in this list will not +`package--autosuggest-database'. Suggestions found in this list will not count as suggestions (e.g. if `package-autosuggest-style' is set to `mode-line', a suggestion found in here will inhibit `package-autosuggest-mode' from displaying a hint in the mode line).") (defun package--suggestion-applies-p (sug) "Check if a suggestion SUG is applicable to the current buffer. -SUG should be an element of `package-autosuggest-database'." +SUG should be an element of `package--autosuggest-database'." (pcase sug (`(,(or (pred (lambda (e) (assq e package--autosuggest-suggested))) (pred package-installed-p)) @@ -4611,14 +4611,14 @@ The elements of the returned list will be a subset of the elements of `package--autosuggest-suggested'." (and package-autosuggest-mode (eq major-mode 'fundamental-mode) (let (suggetions) - (dolist (sug package-autosuggest-database) + (dolist (sug package--autosuggest-database) (when (package--suggestion-applies-p sug) (push sug suggetions))) suggetions))) (defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. -SUG should be an element of `package-autosuggest-database'." +SUG should be an element of `package--autosuggest-database'." (let ((buffers-to-update '())) (dolist (buf (buffer-list)) (with-current-buffer buf From e0c5cc70d2c746350e8a58e0396f7b4f13497feb Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 15:52:40 +0100 Subject: [PATCH 026/191] Mention scrape-elpa.el file name in autosuggest database * admin/scrape-elpa.el (scrape-elpa): Update the inserted comment. --- admin/scrape-elpa.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index f2b5439d082..f513dc36550 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -39,10 +39,10 @@ Please review the results before updating the autosuggest database!" (find-file (expand-file-name "package-autosuggest.eld" data-directory)) (erase-buffer) (lisp-data-mode) - (insert ";; The contents of this file are loaded into `package--autosuggest-database' -;; and were automatically generate by scraping ELPA for auto-loaded -;; code using the `scrape-elpa' command. Please avoid updating this -;; file manually! + (insert ";; The contents of this file are loaded into `package--autosuggest-database'. +;; were automatically generate by scraping ELPA for auto-loaded +;; code using the `scrape-elpa' command from admin/scrape-elpa.el. Please do not +;; update this file manually! ") (fill-paragraph) From e6fd21faf7aa9ed14ee0a045550a5ad1010b824c Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 15:57:06 +0100 Subject: [PATCH 027/191] Update 'package-autosuggest' database * etc/package-autosuggest.eld: Add changes detected by the 'scrape-elpa' command. --- etc/package-autosuggest.eld | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index ba27252f0da..987dc6a6e6b 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -1,9 +1,10 @@ -;; The contents of this file are loaded into `package--autosuggest-database' -;; and were automatically generate by scraping ELPA for auto-loaded -;; code using the `scrape-elpa' command. Please avoid updating this -;; file manually! +;; The contents of this file are loaded into `package--autosuggest-database'. +;; were automatically generate by scraping ELPA for auto-loaded +;; code using the `scrape-elpa' command from admin/scrape-elpa.el. Please do not +;; update this file manually! ( +(a68-mode auto-mode-alist "\\.a68\\'") (ada-mode auto-mode-alist "\\.ad[abs]\\'") (arbitools auto-mode-alist "\\.trf?\\'" arbitools-mode) (auctex auto-mode-alist "\\.hva\\'" LaTeX-mode) @@ -14,6 +15,8 @@ (csharp-mode auto-mode-alist "\\.cs\\'") (csv-mode auto-mode-alist "\\.[Cc][Ss][Vv]\\'") (csv-mode auto-mode-alist "\\.tsv\\'" tsv-mode) +(dicom auto-mode-alist "\\.\\(?:dcm\\|ima\\)\\'" dicom-auto-mode) +(dicom auto-mode-alist "DICOMDIR" dicom-auto-mode) (dismal auto-mode-alist "\\.dis\\'" dismal-mode) (djvu auto-mode-alist "\\.djvu\\'" djvu-init-mode) (dts-mode auto-mode-alist "\\.dtsi?\\'") @@ -42,7 +45,6 @@ (json-mode auto-mode-alist "\\.json\\'") (lmc auto-mode-alist "\\.elmc\\'" lmc-asm-mode) (matlab-mode auto-mode-alist "\\.tlc\\'" tlc-mode) -(matlab auto-mode-alist "\\.tlc\\'" tlc-mode) (muse auto-mode-alist "\\.muse\\'" muse-mode-choose-mode) (auctex auto-mode-alist "\\.drv\\'" latex-mode) (auctex auto-mode-alist "\\.dtx\\'" doctex-mode) @@ -53,6 +55,7 @@ (omn-mode auto-mode-alist "\\.omn\\'") (poke-mode auto-mode-alist "\\.pk\\'") (pspp-mode auto-mode-alist "\\.sps\\'") +(python interpreter-mode-alist "python[0-9.]*" python-mode) (python auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'" conf-mode) (rec-mode auto-mode-alist "\\.rec\\'") (rnc-mode auto-mode-alist "\\.rnc\\'") From 7e3d7a3bcaae562251ae0c3b4ec3d37276f09754 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 16:09:06 +0100 Subject: [PATCH 028/191] ; Fix typo in docstring * lisp/emacs-lisp/package.el (package-autosuggest-style): Refer to 'fundamental-mode'. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d283bcbc4ae..ebec10e3739 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4554,7 +4554,7 @@ enable the package.") You can set this value to `mode-line' (default) to indicate the availability of a package suggestion in the minor mode, `always' to prompt the user in the minibuffer every time a suggestion is available -in a `fundamenta-mode' buffer, `once' to do only prompt the user once +in a `fundamental-mode' buffer, `once' to do only prompt the user once for each suggestion or `message' to just display a message hinting at the existence of a suggestion." :type '(choice (const :tag "Indicate in mode line" mode-line) From 7fe88de4848d8184d73ac00be942b77130277324 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 25 Jan 2026 16:11:00 +0100 Subject: [PATCH 029/191] Refer to 'package-autosuggest-style' in manual. * doc/emacs/package.texi (Package Installation): Mention the user option. --- doc/emacs/package.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index db8d9914d35..fdb0822e85c 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -462,7 +462,8 @@ types. If Emacs opens a file with no specific mode, you can use the @code{package-autosuggest} command to install the recommended packages from ELPA. After enabling @code{package-autosuggest-mode}, Emacs will display a clickable hint in the mode-line if it there is a suggested -package. +package. Using the @code{package-autosuggest-style} user option, you +can adjust how Emacs presents the hint to install a package. @anchor{Package Signing} @cindex package security From 1ff0c58fee23356b3a3ef1c7fee24e22fa020356 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 30 Jan 2026 09:41:42 +0200 Subject: [PATCH 030/191] New function 'checkdoc-batch' (bug#80199) * lisp/emacs-lisp/checkdoc.el (checkdoc--batch-flag): New variable. (checkdoc-rogue-spaces, checkdoc-message-text): Use it along the check for interactive calls to be able to collect errors in the diagnostic buffer. (checkdoc-show-diagnostics): Don't show the diagnostic buffer when 'checkdoc--batch-flag' is non-nil. (checkdoc-batch): New function to check the buffer and print the content of the diagnostic buffer. --- etc/NEWS | 5 +++++ lisp/emacs-lisp/checkdoc.el | 29 +++++++++++++++++++++++++---- 2 files changed, 30 insertions(+), 4 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 1838a1ec3e5..eca0c070783 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2087,6 +2087,11 @@ for docstrings where symbols 'nil' and 't' are in quotes. In most cases, having it enabled leads to a large amount of false positives. +--- +*** New function 'checkdoc-batch'. +It checks the buffer in batch mode, prints all found errors +and signals the first found error. + *** New file-local variable 'lisp-indent-local-overrides'. This variable can be used to locally override the indent specification of symbols. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index c9f9082a27a..fd226b89fda 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -381,6 +381,9 @@ large number of libraries means it is impractical to fix all of these warnings masse. In almost any other case, setting this to anything but t is likely to be counter-productive.") +(defvar checkdoc--batch-flag nil + "Non-nil in batch mode.") + (defun checkdoc-list-of-strings-p (obj) "Return t when OBJ is a list of strings." (declare (obsolete list-of-strings-p "29.1")) @@ -1063,12 +1066,13 @@ Optional argument INTERACT permits more interactive fixing." (e (checkdoc-rogue-space-check-engine nil nil interact)) (checkdoc-generate-compile-warnings-flag (or take-notes checkdoc-generate-compile-warnings-flag))) - (if (not (called-interactively-p 'interactive)) + (if (not (or (called-interactively-p 'interactive) checkdoc--batch-flag)) e (if e (message "%s" (checkdoc-error-text e)) (checkdoc-show-diagnostics) - (message "Space Check: done."))))) + (if (called-interactively-p 'interactive) + (message "Space Check: done.")))))) ;;;###autoload (defun checkdoc-message-text (&optional take-notes) @@ -1081,7 +1085,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." (checkdoc-generate-compile-warnings-flag (or take-notes checkdoc-generate-compile-warnings-flag))) (setq e (checkdoc-message-text-search)) - (if (not (called-interactively-p 'interactive)) + (if (not (or (called-interactively-p 'interactive) checkdoc--batch-flag)) e (if e (user-error "%s" (checkdoc-error-text e)) @@ -2819,7 +2823,7 @@ function called to create the messages." (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." - (if checkdoc-pending-errors + (if (and checkdoc-pending-errors (not checkdoc--batch-flag)) (let* ((b (get-buffer checkdoc-diagnostic-buffer)) (win (if b (display-buffer b)))) (when win @@ -2832,6 +2836,23 @@ function called to create the messages." (setq checkdoc-pending-errors nil) nil))) + +;;;###autoload +(defun checkdoc-batch () + "Check current buffer in batch mode. +Report any errors and signal the first found error." + (when noninteractive + (let ((checkdoc-autofix-flag nil) + (checkdoc--batch-flag t)) + (checkdoc-current-buffer t) + (when checkdoc-pending-errors + (when-let* ((b (get-buffer checkdoc-diagnostic-buffer))) + (with-current-buffer b + (princ (buffer-string))) + (terpri)) + (checkdoc-current-buffer))))) + + (defun checkdoc-get-keywords () "Return a list of package keywords for the current file." (save-excursion From 077b33ef7d3e9d3841382ecf0d6d683d0f157100 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 30 Jan 2026 09:53:30 +0200 Subject: [PATCH 031/191] * lisp/progmodes/eglot.el (eglot-server-programs): Use "elp" for erlang-mode. erlang_ls has been archived in favour of erlang-language-platform. Suggested by Alan & Kim Zimmerman (bug#79943). --- lisp/progmodes/eglot.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 80099a26ee8..251b4e58e38 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -308,7 +308,7 @@ automatically)." (racket-mode . ("racket" "-l" "racket-langserver")) ((latex-mode plain-tex-mode context-mode texinfo-mode bibtex-mode tex-mode) . ,(eglot-alternatives '("digestif" "texlab"))) - (erlang-mode . ("erlang_ls" "--transport" "stdio")) + (erlang-mode . ("elp" "server")) (wat-mode . ("wat_server")) ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) ((toml-ts-mode conf-toml-mode) . ("tombi" "lsp")) From 705c0e3729bf53db9e84ae7c8b932ebc3b2da934 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 11:21:27 +0000 Subject: [PATCH 032/191] Bind 's' to diff-split-hunk in read-only diff-mode * lisp/vc/diff-mode.el (diff-mode-shared-map): Bind 's' to 'diff-split-hunk'. * etc/NEWS: Document the change. --- etc/NEWS | 3 +++ lisp/vc/diff-mode.el | 1 + 2 files changed, 4 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index eca0c070783..78d627068c4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2293,6 +2293,9 @@ region overlaps. Otherwise, they have their existing behavior. With a prefix argument, it now reverse-applies hunks. This matches the existing prefix argument to 'diff-apply-hunk'. +--- +*** 's' is now bound to 'diff-split-hunk' in read-only Diff mode buffers. + ** Ediff +++ diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 5c0fb5fba4c..f57f39de37c 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -218,6 +218,7 @@ See also `diff-mode-read-only-map'." "" #'diff-goto-source "o" #'diff-goto-source ; other-window " " #'undo-ignore-read-only + "s" #'diff-split-hunk ;; The foregoing commands don't affect buffers beyond this one. ;; The following command is the only one that has a single-letter From d0daaead22f37df587113281ebdfd0d4c94636cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Fri, 30 Jan 2026 12:35:14 +0000 Subject: [PATCH 033/191] Eglot: recall diagnostics froms unopened files on session start This is exclusively for the benefit of rust-analyzer, which sends publishDiagnostics for all project files upfront, and never republishes them on 'didOpen'. See https://github.com/joaotavora/eglot/issues/1531. * lisp/progmodes/eglot.el (eglot--flymake-handle-push): Simplify. Don't flymake-list-only-diagnostics here. Save original diagnostic in flymake-list-only-diagnostics setting. (eglot--on-shutdown): Cleanup flymake-list-only-diagnostics. (eglot--flymake-report-push+pulled): Hack in data from flymake-list-only-diagnostics. --- lisp/progmodes/eglot.el | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 251b4e58e38..28ee14c67cb 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1438,6 +1438,12 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see." (maphash (lambda (f s) (when (eq s server) (remhash f eglot--servers-by-xrefed-file))) eglot--servers-by-xrefed-file) + ;; Cleanup entries in 'flymake-list-only-diagnostics' + (setq flymake-list-only-diagnostics + (cl-delete-if + (lambda (x) (eq server + (get-text-property 0 'eglot--server (car x)))) + flymake-list-only-diagnostics)) (cond ((eglot--shutdown-requested server) t) ((not (eglot--inhibit-autoreconnect server)) @@ -3422,11 +3428,8 @@ object. The originator of this \"push\" is usually either regular (with-current-buffer buffer (if (and version (/= version eglot--docver)) (cl-return-from eglot--flymake-handle-push)) - (setq - ;; if no explicit version received, assume it's current. - version eglot--docver - flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics)) + ;; if no explicit version received, assume it's current. + (setq version eglot--docver) (funcall then diagnostics)) (cl-loop for diag-spec across diagnostics @@ -3437,12 +3440,13 @@ object. The originator of this \"push\" is usually either regular (flymake-make-diagnostic path (cons line char) nil (eglot--flymake-diag-type severity) - (list source code message)))) + (list source code message) + `((eglot-lsp-diag . ,diag-spec))))) into diags finally - (setq flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics)) - (push (cons path diags) flymake-list-only-diagnostics)))) + (setf (alist-get (propertize path 'eglot--server server) + flymake-list-only-diagnostics nil nil #'equal) + diags)))) (cl-defun eglot--flymake-pull (&aux (server (eglot--current-server-or-lose)) (origin (current-buffer))) @@ -3506,6 +3510,17 @@ MODE is like `eglot--flymake-report-1'." (pushed-outdated-p (and pushed-docver (< pushed-docver eglot--docver)))) "Push previously collected diagnostics to `eglot--flymake-report-fn'. If KEEP, knowingly push a dummy do-nothing update." + ;; Maybe hack in diagnostics we previously may have saved in + ;; `flymake-list-only-diagnostics', pushed for this file before it was + ;; visited (github#1531). + (when-let* ((hack (and (<= eglot--docver 0) + (null eglot--pushed-diagnostics) + (cdr (assoc (buffer-file-name) + flymake-list-only-diagnostics))))) + (cl-loop + for x in hack + collect (alist-get 'eglot-lsp-diag (flymake-diagnostic-data x)) into res + finally (setq eglot--pushed-diagnostics `(,(vconcat res) ,eglot--docver)))) (eglot--widening (if (and (null eglot--pulled-diagnostics) pushed-outdated-p) ;; Here, we don't have anything interesting to give to Flymake. From 93bba3797e4c9fc69b93ee4ab6c561d76199d1cf Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 13:35:50 +0000 Subject: [PATCH 034/191] Factor out vc-git--branch-remotes * lisp/vc/vc-git.el (vc-git--branch-remotes): New function. (vc-git-trunk-or-topic-p): Use it. * test/lisp/vc/vc-git-tests.el (vc-git-test-branch-remotes): New test. --- lisp/vc/vc-git.el | 42 +++++++++++++++++++++++------------- test/lisp/vc/vc-git-tests.el | 35 ++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 15 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 73db9c0f181..d40ce0de528 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -772,24 +772,36 @@ or an empty string if none." (vc-git--out-match '("symbolic-ref" "HEAD") "^\\(refs/heads/\\)?\\(.+\\)$" 2)) +(defun vc-git--branch-remotes () + "Return alist of configured remote branches for current branch. +If there is a configured upstream, return the remote-tracking branch +with key `upstream'. If there is a distinct configured push remote, +return the remote-tracking branch there with key `push'. +A configured push remote that's just the same as the upstream remote is +ignored because that means we're not actually in a triangular workflow." + ;; Possibly we could simplify this using @{push}, but that may involve + ;; an unwanted dependency on the setting of push.default. + (cl-flet ((get (key) + (string-trim-right (vc-git--out-str "config" key)))) + (let* ((branch (vc-git-working-branch)) + (pull (get (format "branch.%s.remote" branch))) + (merge (get (format "branch.%s.merge" branch))) + (push (get (format "branch.%s.pushRemote" branch))) + (push (if (string-empty-p push) + (get "remote.pushDefault") + push)) + (alist (and (not (string-empty-p pull)) + (not (string-empty-p merge)) + `((upstream . ,(format "%s/%s" pull merge)))))) + (if (or (string-empty-p push) (equal push pull)) + alist + (cl-acons 'push (format "%s/%s" push branch) alist))))) + (defun vc-git-trunk-or-topic-p () "Return `topic' if branch has distinct pull and push remotes, else nil. This is able to identify topic branches for certain forge workflows." - (let* ((branch (vc-git-working-branch)) - (merge (string-trim-right - (vc-git--out-str "config" (format "branch.%s.remote" - branch)))) - (push (string-trim-right - (vc-git--out-str "config" (format "branch.%s.pushRemote" - branch)))) - (push (if (string-empty-p push) - (string-trim-right - (vc-git--out-str "config" "remote.pushDefault")) - push))) - (and (plusp (length merge)) - (plusp (length push)) - (not (equal merge push)) - 'topic))) + (let ((remotes (vc-git--branch-remotes))) + (and (assq 'upstream remotes) (assq 'push remotes) 'topic))) (defun vc-git-topic-outgoing-base () "Return the outgoing base for the current branch as a string. diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index fe55cc75d6f..1552608071e 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -194,4 +194,39 @@ is absent." ("Tracking" . ,main-branch) ("Remote" . "none (tracking local branch)"))))))))) +(ert-deftest vc-git-test-branch-remotes () + "Test behavior of `vc-git--branch-remotes'." + (skip-unless (executable-find vc-git-program)) + (vc-git-test--with-repo repo + (let ((main-branch (vc-git-test--start-branch))) + (should (null (vc-git--branch-remotes))) + (vc-git--out-ok "config" + (format "branch.%s.remote" main-branch) + "origin") + (should (null (vc-git--branch-remotes))) + (vc-git--out-ok "config" + (format "branch.%s.merge" main-branch) + main-branch) + (let ((alist (vc-git--branch-remotes))) + (should (assq 'upstream alist)) + (should (null (assq 'push alist)))) + (vc-git--out-ok "config" + (format "branch.%s.pushRemote" main-branch) + "fork") + (let ((alist (vc-git--branch-remotes))) + (should (assq 'upstream alist)) + (should (equal (cdr (assq 'push alist)) + (concat "fork/" main-branch)))) + (vc-git--out-ok "config" "unset" + (format "branch.%s.pushRemote" main-branch)) + (vc-git--out-ok "config" "remote.pushDefault" "fork") + (let ((alist (vc-git--branch-remotes))) + (should (assq 'upstream alist)) + (should (equal (cdr (assq 'push alist)) + (concat "fork/" main-branch)))) + (vc-git--out-ok "config" "remote.pushDefault" "origin") + (let ((alist (vc-git--branch-remotes))) + (should (assq 'upstream alist)) + (should (null (assq 'push alist))))))) + ;;; vc-git-tests.el ends here From 83db778195a6137ce427e34aa09a57b01ed9f283 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 13:49:35 +0000 Subject: [PATCH 035/191] ; Fix last change. --- lisp/vc/vc-git.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index d40ce0de528..b852cd5b28e 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -785,7 +785,9 @@ ignored because that means we're not actually in a triangular workflow." (string-trim-right (vc-git--out-str "config" key)))) (let* ((branch (vc-git-working-branch)) (pull (get (format "branch.%s.remote" branch))) - (merge (get (format "branch.%s.merge" branch))) + (merge (string-remove-prefix "refs/heads/" + (get (format "branch.%s.merge" + branch)))) (push (get (format "branch.%s.pushRemote" branch))) (push (if (string-empty-p push) (get "remote.pushDefault") From b4a18e466e76a859c30679c0987bd4323daa3ed7 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 13:50:28 +0000 Subject: [PATCH 036/191] vc-git-topic-outgoing-base: Respect a configure push remote * lisp/vc/vc-git.el (vc-git-topic-outgoing-base): If there is a configured push remote, return tracking branch as outgoing base. --- lisp/vc/vc-git.el | 85 +++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 39 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index b852cd5b28e..cb0c7021940 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -809,47 +809,54 @@ This is able to identify topic branches for certain forge workflows." "Return the outgoing base for the current branch as a string. This works by considering the current branch as a topic branch (whether or not it actually is). -Requires that the corresponding trunk exists as a local branch. -The algorithm employed is as follows. Find all merge bases between the -current branch and other local branches. Each of these is a commit on -the current branch. Use `git merge-base --independent' on them all to -find the topologically most recent. Take the branch for which that -commit is a merge base with the current branch to be the branch into -which the current branch will eventually be merged. Find its upstream. -(If there is more than one branch whose merge base with the current -branch is that same topologically most recent commit, try them -one-by-one, accepting the first that has an upstream.)" - (cl-flet ((get-line () (buffer-substring (point) (pos-eol)))) - (let* ((branches (vc-git-branches)) - (current (pop branches)) - merge-bases) - (with-temp-buffer - (dolist (branch branches) - (erase-buffer) - (when (vc-git--out-ok "merge-base" "--all" branch current) - (goto-char (point-min)) - (while (not (eobp)) - (push branch - (alist-get (get-line) merge-bases nil nil #'equal)) - (forward-line 1)))) - (erase-buffer) - (unless (apply #'vc-git--out-ok "merge-base" "--independent" - (mapcar #'car merge-bases)) - (error "`git merge-base --independent' failed")) - ;; If 'git merge-base --independent' printed more than one line, - ;; just pick the first. - (goto-char (point-min)) - (catch 'ret - (dolist (target (cdr (assoc (get-line) merge-bases))) +If there is a distinct push remote for this branch, assume the target +for outstanding changes is the tracking branch, so return that. + +Otherwise, fall back to the following algorithm, which requires that the +corresponding trunk exists as a local branch. Find all merge bases +between the current branch and other local branches. Each of these is a +commit on the current branch. Use `git merge-base --independent' on +them all to find the topologically most recent. Take the branch for +which that commit is a merge base with the current branch to be the +branch into which the current branch will eventually be merged. Find +its upstream. (If there is more than one branch whose merge base with +the current branch is that same topologically most recent commit, try +them one-by-one, accepting the first that has an upstream.)" + (let ((remotes (vc-git--branch-remotes))) + (if-let* ((_ (assq 'push remotes)) + (upstream (assq 'upstream remotes))) + (cdr upstream) + (cl-flet ((get-line () (buffer-substring (point) (pos-eol)))) + (let* ((branches (vc-git-branches)) + (current (pop branches)) + merge-bases) + (with-temp-buffer + (dolist (branch branches) + (erase-buffer) + (when (vc-git--out-ok "merge-base" "--all" branch current) + (goto-char (point-min)) + (while (not (eobp)) + (push branch (alist-get (get-line) merge-bases + nil nil #'equal)) + (forward-line 1)))) (erase-buffer) - (when (vc-git--out-ok "for-each-ref" - "--format=%(upstream:short)" - (concat "refs/heads/" target)) - (goto-char (point-min)) - (let ((outgoing-base (get-line))) - (unless (string-empty-p outgoing-base) - (throw 'ret outgoing-base)))))))))) + (unless (apply #'vc-git--out-ok "merge-base" "--independent" + (mapcar #'car merge-bases)) + (error "`git merge-base --independent' failed")) + ;; If 'git merge-base --independent' printed more than one + ;; line, just pick the first. + (goto-char (point-min)) + (catch 'ret + (dolist (target (cdr (assoc (get-line) merge-bases))) + (erase-buffer) + (when (vc-git--out-ok "for-each-ref" + "--format=%(upstream:short)" + (concat "refs/heads/" target)) + (goto-char (point-min)) + (let ((outgoing-base (get-line))) + (unless (string-empty-p outgoing-base) + (throw 'ret outgoing-base)))))))))))) (defun vc-git-dir--branch-headers () "Return headers for branch-related information." From c1029c88a88091099d9dc6a16dd3667736547fd5 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 13:52:37 +0000 Subject: [PATCH 037/191] ; vc-git-topic-outgoing-base: Merge let into if-let*. --- lisp/vc/vc-git.el | 66 +++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index cb0c7021940..b1a60aeeb23 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -823,40 +823,40 @@ branch into which the current branch will eventually be merged. Find its upstream. (If there is more than one branch whose merge base with the current branch is that same topologically most recent commit, try them one-by-one, accepting the first that has an upstream.)" - (let ((remotes (vc-git--branch-remotes))) - (if-let* ((_ (assq 'push remotes)) - (upstream (assq 'upstream remotes))) - (cdr upstream) - (cl-flet ((get-line () (buffer-substring (point) (pos-eol)))) - (let* ((branches (vc-git-branches)) - (current (pop branches)) - merge-bases) - (with-temp-buffer - (dolist (branch branches) - (erase-buffer) - (when (vc-git--out-ok "merge-base" "--all" branch current) - (goto-char (point-min)) - (while (not (eobp)) - (push branch (alist-get (get-line) merge-bases - nil nil #'equal)) - (forward-line 1)))) + (if-let* ((remotes (vc-git--branch-remotes)) + (_ (assq 'push remotes)) + (upstream (assq 'upstream remotes))) + (cdr upstream) + (cl-flet ((get-line () (buffer-substring (point) (pos-eol)))) + (let* ((branches (vc-git-branches)) + (current (pop branches)) + merge-bases) + (with-temp-buffer + (dolist (branch branches) (erase-buffer) - (unless (apply #'vc-git--out-ok "merge-base" "--independent" - (mapcar #'car merge-bases)) - (error "`git merge-base --independent' failed")) - ;; If 'git merge-base --independent' printed more than one - ;; line, just pick the first. - (goto-char (point-min)) - (catch 'ret - (dolist (target (cdr (assoc (get-line) merge-bases))) - (erase-buffer) - (when (vc-git--out-ok "for-each-ref" - "--format=%(upstream:short)" - (concat "refs/heads/" target)) - (goto-char (point-min)) - (let ((outgoing-base (get-line))) - (unless (string-empty-p outgoing-base) - (throw 'ret outgoing-base)))))))))))) + (when (vc-git--out-ok "merge-base" "--all" branch current) + (goto-char (point-min)) + (while (not (eobp)) + (push branch (alist-get (get-line) merge-bases + nil nil #'equal)) + (forward-line 1)))) + (erase-buffer) + (unless (apply #'vc-git--out-ok "merge-base" "--independent" + (mapcar #'car merge-bases)) + (error "`git merge-base --independent' failed")) + ;; If 'git merge-base --independent' printed more than one + ;; line, just pick the first. + (goto-char (point-min)) + (catch 'ret + (dolist (target (cdr (assoc (get-line) merge-bases))) + (erase-buffer) + (when (vc-git--out-ok "for-each-ref" + "--format=%(upstream:short)" + (concat "refs/heads/" target)) + (goto-char (point-min)) + (let ((outgoing-base (get-line))) + (unless (string-empty-p outgoing-base) + (throw 'ret outgoing-base))))))))))) (defun vc-git-dir--branch-headers () "Return headers for branch-related information." From ae7761598dc95a65491cfff978bb5119ccdc6b57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Fri, 30 Jan 2026 15:42:53 +0100 Subject: [PATCH 038/191] Pass lazy doc string to 'defalias' * lisp/emacs-lisp/bytecomp.el (byte-compile-file-form-defalias): We correctly emit a lazy-loaded doc string but then passed a literal string to 'defalias' by mistake; fix that. Saves 40 KiB in .elc files. --- lisp/emacs-lisp/bytecomp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 52bc20af173..edfd9491a2f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5141,7 +5141,8 @@ binding slots have been popped." (when (stringp doc) (setq rest (byte-compile--list-with-n rest 0 - (byte-compile--docstring doc (nth 0 form) name))))) + (byte-compile--docstring doc (nth 0 form) name))) + (setq form (nconc (take 3 form) rest)))) (pcase-let* ;; `macro' is non-nil if it defines a macro. ;; `fun' is the function part of `arg' (defaults to `arg'). From fcdd8678f97e98b2afc38f1e999559eff726972a Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 15:06:52 +0000 Subject: [PATCH 039/191] Make diff-hunk-kill respect an active region * lisp/vc/diff-mode.el (diff--revert-kill-hunks): New workhorse routine. (diff-hunk-kill, diff-revert-and-kill-hunk): Call it. (diff-hunk-kill): New BEG and END parameters and interactive form. * doc/emacs/files.texi (Diff Mode): * etc/NEWS: Document the change. --- doc/emacs/files.texi | 3 +- etc/NEWS | 7 ++- lisp/vc/diff-mode.el | 137 ++++++++++++++++++++++++++++--------------- lisp/vc/vc-git.el | 2 +- 4 files changed, 98 insertions(+), 51 deletions(-) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 567c1492518..a9bcee0b060 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1835,7 +1835,8 @@ the start of the @var{n}th previous file. @findex diff-hunk-kill @item M-k -Kill the hunk at point (@code{diff-hunk-kill}). +Kill the hunk at point (@code{diff-hunk-kill}). If the region is +active, kills all hunks the region overlaps. @findex diff-file-kill @item M-K diff --git a/etc/NEWS b/etc/NEWS index 78d627068c4..be507f525ba 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2284,9 +2284,10 @@ one as before. This makes them different from 'vc-diff' and *** 'diff-apply-hunk' now supports creating and deleting files. +++ -*** 'diff-apply-hunk' and 'diff-apply-buffer' now consider the region. -If the region is active, these commands now apply all hunks that the -region overlaps. Otherwise, they have their existing behavior. +*** Diff mode's application and killing commands now consider the region. +If the region is active, 'diff-apply-hunk', 'diff-apply-buffer' and +'diff-hunk-kill' now apply or kill all hunks that the region overlaps. +Otherwise, they have their existing behavior. +++ *** 'diff-apply-buffer' can reverse-apply. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index f57f39de37c..28e29cf36c5 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -883,31 +883,19 @@ If the prefix ARG is given, restrict the view to the current file instead." (goto-char (point-min)) (re-search-forward diff-hunk-header-re nil t))) -(defun diff-hunk-kill () - "Kill the hunk at point." - (interactive) - (if (not (diff--some-hunks-p)) - (error "No hunks") - (diff-beginning-of-hunk t) - (let* ((hunk-bounds (diff-bounds-of-hunk)) - (file-bounds (ignore-errors (diff-bounds-of-file))) - ;; If the current hunk is the only one for its file, kill the - ;; file header too. - (bounds (if (and file-bounds - (progn (goto-char (car file-bounds)) - (= (progn (diff-hunk-next) (point)) - (car hunk-bounds))) - (progn (goto-char (cadr hunk-bounds)) - ;; bzr puts a newline after the last hunk. - (while (looking-at "^\n") - (forward-char 1)) - (= (point) (cadr file-bounds)))) - file-bounds - hunk-bounds)) - (inhibit-read-only t)) - (apply #'kill-region bounds) - (goto-char (car bounds)) - (ignore-errors (diff-beginning-of-hunk t))))) +(defun diff-hunk-kill (&optional beg end) + "Kill the hunk at point. +When killing the last hunk left for a file, kill the file header too. +Interactively, if the region is active, kill all hunks that the region +overlaps. + +When called from Lisp with optional arguments BEG and END non-nil, kill +all hunks overlapped by the region from BEG to END as though called +interactively with an active region delimited by BEG and END." + (interactive "R") + (when (xor beg end) + (error "Invalid call to `diff-hunk-kill'")) + (diff--revert-kill-hunks beg end nil)) ;; This is not `diff-kill-other-hunks' because we might need to make ;; copies of file headers in order to ensure the new kill ring entry @@ -2283,6 +2271,83 @@ With a prefix argument, try to REVERSE the hunk." :type 'boolean :version "31.1") +(defun diff--revert-kill-hunks (beg end revertp) + "Workhorse routine for killing hunks, after possibly reverting them. +If BEG and END are nil, kill the hunk at point. +Otherwise kill all hunks overlapped by region delimited by BEG and END. +When killing a hunk that's the only one remaining for its file, kill the +file header too. +If REVERTP is non-nil, reverse-apply hunks before killing them." + ;; With BEG and END non-nil, we push each hunk to the kill ring + ;; separately. If we want to push to the kill ring just once, we have + ;; to decide how to handle file headers such that the meanings of the + ;; hunks in the kill ring entry, considered as a whole patch, do not + ;; deviate too far from the meanings the hunks had in this buffer. + ;; + ;; For example, if we have a single hunk for one file followed by + ;; multiple hunks for another file, and we naĂŻvely kill the single + ;; hunk and the first of the multiple hunks, our kill ring entry will + ;; be a patch applying those two hunks to the first file. This is + ;; because killing the single hunk will have brought its file header + ;; with it, but not so killing the second hunk. So we will have put + ;; together hunks that were previously for two different files. + ;; + ;; One option is to *copy* every file header that the region overlaps + ;; (and that we will not kill, because we are leaving other hunks for + ;; that file behind). But then the text this command pushes to the + ;; kill ring would be different from the text it removes from the + ;; buffer, which would be unintuitive for an Emacs kill command. + ;; + ;; An alternative might be to have restrictions as follows: + ;; + ;; Interactively, if the region is active, try to kill all hunks that the + ;; region overlaps. This works when either + ;; - all the hunks the region overlaps are for the same file; or + ;; - the last hunk the region overlaps is the last hunk for its file. + ;; These restrictions are so that the text added to the kill ring does not + ;; merge together hunks for different files under a single file header. + ;; + ;; We would error out if neither property is met. When either holds, + ;; any file headers the region overlaps are ones we should kill. + (unless (diff--some-hunks-p) + (error "No hunks")) + (if beg + (save-excursion + (goto-char beg) + (setq beg (car (diff-bounds-of-hunk))) + (goto-char end) + (unless (looking-at diff-hunk-header-re) + (setq end (cadr (diff-bounds-of-hunk))))) + (pcase-setq `(,beg ,end) (diff-bounds-of-hunk))) + (when (or (not revertp) (null (diff-apply-buffer beg end t))) + (goto-char end) + (when-let* ((pos (diff--at-diff-header-p))) + (goto-char pos)) + (setq beg (copy-marker beg) end (point-marker)) + (unwind-protect + (cl-loop initially (goto-char beg) + for (hunk-beg hunk-end) = (diff-bounds-of-hunk) + for file-bounds = (ignore-errors (diff-bounds-of-file)) + for (file-beg file-end) = file-bounds + for inhibit-read-only = t + if (and file-bounds + (progn + (goto-char file-beg) + (diff-hunk-next) + (eq (point) hunk-beg)) + (progn + (goto-char hunk-end) + ;; bzr puts a newline after the last hunk. + (while (looking-at "^\n") (forward-char 1)) + (eq (point) file-end))) + do (kill-region file-beg file-end) (goto-char file-beg) + else do (kill-region hunk-beg hunk-end) (goto-char hunk-beg) + do (ignore-errors (diff-beginning-of-hunk t)) + until (or (< (point) (marker-position beg)) + (eql (point) (marker-position end)))) + (set-marker beg nil) + (set-marker end nil)))) + (defun diff-revert-and-kill-hunk (&optional beg end) "Reverse-apply and then kill the hunk at point. Save changed buffer. Interactively, if the region is active, reverse-apply and kill all @@ -2308,27 +2373,7 @@ BEG and END." (error "Invalid call to `diff-revert-and-kill-hunk'")) (when (or (not diff-ask-before-revert-and-kill-hunk) (y-or-n-p "Really reverse-apply and kill hunk(s)?")) - (if beg - (save-excursion - (goto-char beg) - (setq beg (car (diff-bounds-of-hunk))) - (goto-char end) - (unless (looking-at diff-hunk-header-re) - (setq end (cadr (diff-bounds-of-hunk))))) - (pcase-setq `(,beg ,end) (diff-bounds-of-hunk))) - (when (null (diff-apply-buffer beg end t)) - ;; Use `diff-hunk-kill' because it properly handles file headers. - (goto-char end) - (when-let* ((pos (diff--at-diff-header-p))) - (goto-char pos)) - (setq beg (copy-marker beg) end (point-marker)) - (unwind-protect - (cl-loop initially (goto-char beg) - do (diff-hunk-kill) - until (or (< (point) (marker-position beg)) - (eql (point) (marker-position end)))) - (set-marker beg nil) - (set-marker end nil))))) + (diff--revert-kill-hunks beg end t))) (defun diff-apply-buffer (&optional beg end reverse test-or-no-save) "Apply the diff in the entire diff buffer. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index b1a60aeeb23..d6a7145b34e 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -811,7 +811,7 @@ This works by considering the current branch as a topic branch (whether or not it actually is). If there is a distinct push remote for this branch, assume the target -for outstanding changes is the tracking branch, so return that. +for outstanding changes is the tracking branch, and return that. Otherwise, fall back to the following algorithm, which requires that the corresponding trunk exists as a local branch. Find all merge bases From 53a3883bf664e0128cc8a74145ddfd8b115d828d Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 30 Jan 2026 15:56:58 +0000 Subject: [PATCH 040/191] vc--incoming-revision: Signal error on cache hit * lisp/vc/vc.el (vc--incoming-revision): Signal an error instead of returning nil on a cache hit (bug#80270). (vc--outgoing-base-mergebase): Simplify, given that vc--incoming-revision now handles the error case. --- lisp/vc/vc.el | 47 ++++++++++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 770906ff6cc..14da03cda1d 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3330,15 +3330,13 @@ to which `vc-push' would push as UPSTREAM-LOCATION, unconditionally. (This is passed when the user invokes an outgoing base command with a \\`C-u C-u' prefix argument; see `vc--maybe-read-outgoing-base'.) REFRESH is passed on to `vc--incoming-revision'." - (if-let* ((incoming - (vc--incoming-revision backend - (pcase upstream-location - ('t nil) - ('nil (vc--outgoing-base backend)) - (_ upstream-location)) - refresh))) - (vc-call-backend backend 'mergebase incoming) - (user-error "No incoming revision -- local-only branch?"))) + (vc-call-backend backend 'mergebase + (vc--incoming-revision backend + (pcase upstream-location + ('t nil) + ('nil (vc--outgoing-base backend)) + (_ upstream-location)) + refresh))) ;;;###autoload (defun vc-root-diff-outgoing-base (&optional upstream-location) @@ -4435,20 +4433,23 @@ BACKEND is the VC backend." ;; Do store `nil', before signaling an error, if there is no incoming ;; revision, because that's also something that can be slow to ;; determine and so should be remembered. - (if-let* ((_ (not refresh)) - (record (assoc upstream-location - (vc--repo-getprop backend 'vc-incoming-revision)))) - (cdr record) - (let ((res (vc-call-backend backend 'incoming-revision - upstream-location refresh))) - (if-let* ((alist (vc--repo-getprop backend 'vc-incoming-revision))) - (setf (alist-get upstream-location alist nil nil #'equal) - res) - (vc--repo-setprop backend - 'vc-incoming-revision - `((,upstream-location . ,res)))) - (or res - (user-error "No incoming revision -- local-only branch?"))))) + (or (if-let* ((_ (not refresh)) + (record (assoc upstream-location + (vc--repo-getprop backend + 'vc-incoming-revision)))) + (cdr record) + (let ((res (vc-call-backend backend 'incoming-revision + upstream-location refresh))) + (if-let* ((alist (vc--repo-getprop backend + 'vc-incoming-revision))) + (setf (alist-get upstream-location alist + nil nil #'equal) + res) + (vc--repo-setprop backend + 'vc-incoming-revision + `((,upstream-location . ,res)))) + res)) + (user-error "No incoming revision -- local-only branch?"))) ;;;###autoload (defun vc-root-log-incoming (&optional upstream-location) From 69a2b9fa17054794723455fbac84beb51290dfa1 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Fri, 30 Jan 2026 12:30:40 -0500 Subject: [PATCH 041/191] xsettings: honor GDK DPI scaling values Some XWayland setups only report DPI changes through GDK xsettings, so Emacs missed DPI updates there. Recognize the GDK DPI and scaling settings and use them to compute the effective DPI. * src/xsettings.c (parse_settings): Recognize Gdk/UnscaledDPI and Gdk/WindowScalingFactor. Use them to compute DPI when present. --- src/xsettings.c | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/src/xsettings.c b/src/xsettings.c index 25edce78841..71cd6a9ad6c 100644 --- a/src/xsettings.c +++ b/src/xsettings.c @@ -187,6 +187,8 @@ store_tool_bar_style_changed (const char *newstyle, #ifndef HAVE_PGTK #if defined USE_CAIRO || defined HAVE_XFT #define XSETTINGS_FONT_NAME "Gtk/FontName" +#define XSETTINGS_GDK_DPI_NAME "Gdk/UnscaledDPI" +#define XSETTINGS_GDK_WSCALE_NAME "Gdk/WindowScalingFactor" #endif #define XSETTINGS_TOOL_BAR_STYLE "Gtk/ToolbarStyle" #endif @@ -626,6 +628,15 @@ parse_settings (unsigned char *prop, int bytes_parsed = 0; int settings_seen = 0; int i = 0; +#if defined USE_CAIRO || defined HAVE_XFT + /* Some X environments, e.g. XWayland, communicate DPI changes only + through the GDK xsettings values and not the regular Xft one, so + recognize both schemes. We want to see both the GDK window scaling + factor and the post-scaling DPI so we can compute our desired + actual DPI. */ + int gdk_unscaled_dpi = 0; + int gdk_window_scale = 0; +#endif /* First 4 bytes is a serial number, skip that. */ @@ -668,7 +679,9 @@ parse_settings (unsigned char *prop, want_this = strcmp (XSETTINGS_TOOL_BAR_STYLE, name) == 0; #if defined USE_CAIRO || defined HAVE_XFT if ((nlen > 6 && memcmp (name, "Xft/", 4) == 0) - || strcmp (XSETTINGS_FONT_NAME, name) == 0) + || strcmp (XSETTINGS_FONT_NAME, name) == 0 + || strcmp (XSETTINGS_GDK_DPI_NAME, name) == 0 + || strcmp (XSETTINGS_GDK_WSCALE_NAME, name) == 0) want_this = true; #endif @@ -769,6 +782,10 @@ parse_settings (unsigned char *prop, settings->seen |= SEEN_DPI; settings->dpi = ival / 1024.0; } + else if (strcmp (name, XSETTINGS_GDK_DPI_NAME) == 0) + gdk_unscaled_dpi = ival; + else if (strcmp (name, XSETTINGS_GDK_WSCALE_NAME) == 0) + gdk_window_scale = ival; else if (strcmp (name, "Xft/lcdfilter") == 0) { settings->seen |= SEEN_LCDFILTER; @@ -786,6 +803,19 @@ parse_settings (unsigned char *prop, } } +#if defined USE_CAIRO || defined HAVE_XFT + if (gdk_unscaled_dpi > 0 && gdk_window_scale > 0) + { + /* Override any previous DPI settings. GDK ones are intended to + be authoritative. + See + https://mail.gnome.org/archives/commits-list/2013-June/msg06726.html + */ + settings->seen |= SEEN_DPI; + settings->dpi = gdk_window_scale * gdk_unscaled_dpi / 1024.0; + } +#endif + return settings_seen; } #endif From e68239773ce6f6ff85795e37030f9b4f03f5942f Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Fri, 5 May 2023 15:31:58 +0200 Subject: [PATCH 042/191] pixel-scroll: Avoid loading `cua-base' CUA is not necessarily used together with `pixel-scroll-precision-mode'. Make `pixel-scroll-interpolate-down' and `pixel-scroll-interpolate-up' independent and avoid loading cua-base. * lisp/pixel-scroll.el (pixel-scroll-interpolate-up) (pixel-scroll-interpolate-down): Do not use `cua-scroll-down' and `cua-scroll-up'; replace them with inline code. (Bug#80245) --- lisp/pixel-scroll.el | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index dbb532f691b..23e63add994 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -90,7 +90,6 @@ (require 'mwheel) (require 'subr-x) (require 'ring) -(require 'cua-base) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -831,7 +830,13 @@ It is a vector of the form [ VELOCITY TIME SIGN ]." ;; since we want exactly 1 ;; page to be scrolled. nil 1) - (cua-scroll-up))) + (cond + ((eobp) + (scroll-up)) ; signal error + (t + (condition-case nil + (scroll-up) + (end-of-buffer (goto-char (point-max)))))))) ;;;###autoload (defun pixel-scroll-interpolate-up () @@ -840,7 +845,13 @@ It is a vector of the form [ VELOCITY TIME SIGN ]." (if pixel-scroll-precision-interpolate-page (pixel-scroll-precision-interpolate (window-text-height nil t) nil 1) - (cua-scroll-down))) + (cond + ((bobp) + (scroll-down)) ; signal error + (t + (condition-case nil + (scroll-down) + (beginning-of-buffer (goto-char (point-min)))))))) ;;;###autoload (define-minor-mode pixel-scroll-precision-mode From a0748d9791c7dbf8604ef9312c1b889cb87a42ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Marks?= Date: Fri, 23 Jan 2026 17:45:09 -0500 Subject: [PATCH 043/191] New function 'truncate-string-pixelwise' (bug#80244) This function will truncate a string on a pixelwise basis in a work buffer and using a binary search rather than brute force. * lisp/emacs-lisp/subr-x.el (work-buffer--prepare-pixelwise): New defun helper function. (string-pixel-width): Use the helper function. (truncate-string-pixelwise): New defun. * test/lisp/misc-tests.el (misc-test-truncate-string-pixelwise): (misc-test-truncate-string-pixelwise-unicode): New test. * doc/lispref/display.texi (Size of Displayed Text): Document the function. * etc/NEWS: Announce the function. --- doc/lispref/display.texi | 34 +++++++++++++ etc/NEWS | 8 +++ lisp/emacs-lisp/subr-x.el | 103 +++++++++++++++++++++++++++++++------- test/lisp/misc-tests.el | 80 +++++++++++++++++++++++++++++ 4 files changed, 207 insertions(+), 18 deletions(-) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 4211b435db5..464c0badc36 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2243,6 +2243,9 @@ means hide the excess parts of @var{string} with a @code{display} text property (@pxref{Display Property}) showing the ellipsis, instead of actually truncating the string. +See also the function @code{truncate-string-pixelwise} for pixel-level +resolution. + @example @group (truncate-string-to-width "\tab\t" 12 4) @@ -2440,6 +2443,37 @@ non-@code{nil}, use any face remappings (@pxref{Face Remapping}) from that buffer when computing the width of @var{string}. @end defun +@defun truncate-string-pixelwise string max-pixels &optional buffer ellipsis ellipsis-pixels +This is a convenience function that uses @code{window-text-pixel-size} +to truncate @var{string} to @var{max-pixels} pixels. Caveat: if you +call this function to measure the width of a string with embedded +newlines, it will then return the width of the widest substring that +does not include newlines. The meaning of this result is the widest +line taken by the string if inserted into a buffer. If @var{buffer} is +non-@code{nil}, use any face remappings (@pxref{Face Remapping}) from +that buffer when computing the width of @var{string}. + +If @var{ellipsis} is non-@code{nil}, it should be a string which will +replace the end of @var{string} when it is truncated. In this case, +more characters will be removed from @var{string} to free enough space +for @var{ellipsis} to fit within @var{max-pixels} pixels. However, if +the pixel width of @var{string} is less than the pixel width of +@var{ellipsis}, @var{ellipsis} will not be appended to the result. If +@var{ellipsis} is non-@code{nil} and not a string, it stands for the +value returned by the function @code{truncate-string-ellipsis}, +described above. + +If @var{ellipsis-pixels} is non-@code{nil} and @var{ellipsis} is +non-@code{nil}, it should be the number of pixels of @var{ellipsis} that +you should precompute using @code{string-pixel-width}, specifying the +same buffer. This is useful to avoid the cost of recomputing this value +repeatedly when you have many strings to truncate using the same +ellipsis string. + +See also the function @code{truncate-string-to-width} for +character-level resolution. +@end defun + @defun line-pixel-height This function returns the height in pixels of the line at point in the selected window. The value includes the line spacing of the line diff --git a/etc/NEWS b/etc/NEWS index be507f525ba..2cf91cfd5f7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3847,6 +3847,14 @@ It has been obsolete since Emacs 26.1. Use the group 'text' instead. If supplied, 'string-pixel-width' will use any face remappings from BUFFER when computing the string's width. ++++ +** New function 'truncate-string-pixelwise'. +This function truncates a string to the specified maximum number of +pixels rather than by characters, as in 'truncate-string-to-width', and +respects face remappings if BUFFER is specified. You can also specify +an optional ellipsis string to append, similar to +'truncate-string-to-width'. + --- ** New macro 'with-work-buffer'. This macro is similar to the already existing macro 'with-temp-buffer', diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 8d04958487f..db854863b32 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -37,6 +37,7 @@ (eval-when-compile (require 'cl-lib)) +(require 'mule-util) (defmacro internal--thread-argument (first? &rest forms) "Internal implementation for `thread-first' and `thread-last'. @@ -357,6 +358,29 @@ buffer when possible, instead of creating a new one on each call." (progn ,@body) (work-buffer--release ,work-buffer)))))) +(defun work-buffer--prepare-pixelwise (string buffer) + "Set up the current buffer to correctly compute STRING's pixel width. +Call this with a work buffer as the current buffer. +BUFFER is the originating buffer and if non-nil, make the current +buffer's (work buffer) face remappings match it." + (when buffer + (dolist (v '(face-remapping-alist + char-property-alias-alist + default-text-properties)) + (if (local-variable-p v buffer) + (set (make-local-variable v) + (buffer-local-value v buffer))))) + ;; Avoid deactivating the region as side effect. + (let (deactivate-mark) + (insert string)) + ;; If `display-line-numbers' is enabled in internal + ;; buffers (e.g. globally), it breaks width calculation + ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', + ;; for the same reason. + (add-text-properties + (point-min) (point-max) + '(display-line-numbers-disable t line-prefix "" wrap-prefix ""))) + ;;;###autoload (defun string-pixel-width (string &optional buffer) "Return the width of STRING in pixels. @@ -371,26 +395,69 @@ substring that does not include newlines." ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. (with-work-buffer - ;; Setup current buffer to correctly compute pixel width. - (when buffer - (dolist (v '(face-remapping-alist - char-property-alias-alist - default-text-properties)) - (if (local-variable-p v buffer) - (set (make-local-variable v) - (buffer-local-value v buffer))))) - ;; Avoid deactivating the region as side effect. - (let (deactivate-mark) - (insert string)) - ;; If `display-line-numbers' is enabled in internal - ;; buffers (e.g. globally), it breaks width calculation - ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', - ;; for the same reason. - (add-text-properties - (point-min) (point-max) - '(display-line-numbers-disable t line-prefix "" wrap-prefix "")) + (work-buffer--prepare-pixelwise string buffer) (car (buffer-text-pixel-size nil nil t))))) +;;;###autoload +(defun truncate-string-pixelwise (string max-pixels &optional buffer + ellipsis ellipsis-pixels) + "Return STRING truncated to fit within MAX-PIXELS. +If BUFFER is non-nil, use the face remappings, alternative and default +properties from that buffer when determining the width. +If you call this function to measure pixel width of a string +with embedded newlines, it returns the width of the widest +substring that does not include newlines. + +If ELLIPSIS is non-nil, it should be a string which will replace the end +of STRING if it extends beyond MAX-PIXELS, unless the pixel width of +STRING is equal to or less than the pixel width of ELLIPSIS. If it is +non-nil and not a string, then ELLIPSIS defaults to +`truncate-string-ellipsis', or to three dots when it's nil. + +If ELLIPSIS-PIXELS is non-nil, it is the pixel width of ELLIPSIS, and +can be used to avoid the cost of recomputing this for multiple calls to +this function using the same ELLIPSIS." + (declare (important-return-value t)) + (if (zerop (length string)) + 0 + ;; Keeping a work buffer around is more efficient than creating a + ;; new temporary buffer. + (with-work-buffer + (work-buffer--prepare-pixelwise string buffer) + (set-window-buffer nil (current-buffer) 'keep-margins) + ;; Use a binary search to prune the number of calls to + ;; `window-text-pixel-size'. + ;; These are 1-based buffer indexes. + (let* ((low 1) + (high (1+ (length string))) + mid) + (when (> (car (window-text-pixel-size nil 1 high)) max-pixels) + (when (and ellipsis (not (stringp ellipsis))) + (setq ellipsis (truncate-string-ellipsis))) + (setq ellipsis-pixels (if ellipsis + (if ellipsis-pixels + ellipsis-pixels + (string-pixel-width ellipsis buffer)) + 0)) + (let ((adjusted-pixels + (if (> max-pixels ellipsis-pixels) + (- max-pixels ellipsis-pixels) + max-pixels))) + (while (<= low high) + (setq mid (floor (+ low high) 2)) + (if (<= (car (window-text-pixel-size nil 1 mid)) + adjusted-pixels) + (setq low (1+ mid)) + (setq high (1- mid)))))) + (set-window-buffer nil buffer 'keep-margins) + (if mid + ;; Binary search ran. + (if (and ellipsis (> max-pixels ellipsis-pixels)) + (concat (substring string 0 (1- high)) ellipsis) + (substring string 0 (1- high))) + ;; Fast path. + string))))) + ;;;###autoload (defun string-glyph-split (string) "Split STRING into a list of strings representing separate glyphs. diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index b6f5f01ad2a..5d0b9ae0604 100644 --- a/test/lisp/misc-tests.el +++ b/test/lisp/misc-tests.el @@ -25,6 +25,7 @@ (require 'ert) (require 'misc) +(require 'mule-util) (defmacro with-misc-test (original result &rest body) (declare (indent 2)) @@ -243,5 +244,84 @@ (setq-default display-line-numbers dln)) (should (= w0 w1)))) +;; Exercise `truncate-string-pixelwise' with strings of the same +;; characters of differing widths, with and without ellipses, in varying +;; faces, and varying face heights and compare results to each +;; character's measured width. +(ert-deftest misc-test-truncate-string-pixelwise () + (dolist (c '(?W ?X ?y ?1)) + (dolist (ellipsis `(nil "..." ,(truncate-string-ellipsis))) + (dolist (face '(fixed-pitch variable-pitch)) + (dolist (height '(1.0 0.5 1.5)) + (with-temp-buffer + (setq-local face-remapping-alist `((,face . default))) + (face-remap-add-relative 'default :height height) + (let ((char-pixels (string-pixel-width + (make-string 1 c) (current-buffer)))) + (dotimes (i 20) + (setq i (1+ i)) + (should (eq i (length + (truncate-string-pixelwise + (make-string (* i 2) c) + (* i char-pixels) + (current-buffer) + ellipsis)))))))))))) + +;; Exercise `truncate-string-pixelwise' with varying unicode strings, in +;; varying faces, and varying face heights and compare results to a +;; naive `string-pixel-width' based string truncate function. +(ert-deftest misc-test-truncate-string-pixelwise-unicode () + :tags '(:expensive-test) + (skip-when noninteractive) + (let ((max-pixels 500) + (truncate-string-naive (lambda (string pixels buffer) + (while (and (length> string 0) + (> (string-pixel-width string buffer) pixels)) + (setq string (substring string 0 (1- (length string))))) + string)) + (strings (list + "foo bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar baz" + (concat "話èȘȘć€©äž‹ć€§ć‹ąïŒŒćˆ†äč…ćż…ćˆïŒŒćˆäč…ćż…ćˆ†ïŒšć‘šæœ«äžƒćœ‹ćˆ†çˆ­ïŒŒćč¶ć…„æ–Œç§Šă€‚" + "ćŠç§Šæ»…äč‹ćŸŒïŒŒæ„šă€æŒąćˆ†çˆ­ïŒŒćˆćč¶ć…„æ–ŒæŒąă€‚æŒąæœè‡Șé«˜ç„–æ–Źç™œè›‡è€Œè”·çŸ©ïŒŒ" + "äž€ç”±ć€©äž‹ă€‚ćŸŒäŸ†ć…‰æ­Šäž­èˆˆïŒŒć‚łè‡łç»ćžïŒŒé‚ćˆ†ç‚șäž‰ćœ‹ă€‚æŽšć…¶è‡Žäș‚äč‹ç”±ïŒŒ" + "æź†ć§‹æ–ŒæĄ“ă€éˆäșŒćžă€‚æĄ“ćžçŠéŒźć–„éĄžïŒŒćŽ‡äżĄćźŠćź˜ă€‚ćŠæĄ“ćžćŽ©ïŒŒéˆćžćłäœïŒŒ" + "ć€§ć°‡è»ç«‡æ­Šă€ć€Șć‚…é™łè•ƒïŒŒć…±ç›žèŒ”äœă€‚æ™‚æœ‰ćźŠćź˜æ›čçŻ€ç­‰ćŒ„æŹŠïŒŒç«‡æ­Šă€é™łè•ƒèŹ€èȘ…äč‹ïŒŒ" + "䜜äș‹äžćŻ†ïŒŒćç‚șæ‰€ćźłă€‚äž­æ¶“è‡Ș歀愈橫") + (concat "ĐșĐŸŃ€ĐŸŃ‡Đ” Ń‚Đ”ĐżĐ”Ń€ŃŒ ДслО ĐżĐŸ руссĐșĐž ĐœĐ°ĐżĐžŃĐ°Ń‚ŃŒ ĐČсД чДтĐșĐŸ ОлО ĐČсД раĐČĐœĐŸ" + " ĐșĐŸŃ€ĐŸŃ‡Đ” Ń‚Đ”ĐżĐ”Ń€ŃŒ ДслО ĐżĐŸ руссĐșĐž ĐœĐ°ĐżĐžŃĐ°Ń‚ŃŒ ĐČсД чДтĐșĐŸ ОлО ĐČсД раĐČĐœĐŸ" + " ĐșĐŸŃ€ĐŸŃ‡Đ” Ń‚Đ”ĐżĐ”Ń€ŃŒ ДслО ĐżĐŸ руссĐșĐž ĐœĐ°ĐżĐžŃĐ°Ń‚ŃŒ ĐČсД чДтĐșĐŸ ОлО ĐČсД раĐČĐœĐŸ" + " ĐșĐŸŃ€ĐŸŃ‡Đ” Ń‚Đ”ĐżĐ”Ń€ŃŒ ДслО ĐżĐŸ руссĐșĐž ĐœĐ°ĐżĐžŃĐ°Ń‚ŃŒ ĐČсД чДтĐșĐŸ ОлО ĐČсД раĐČĐœĐŸ") + "Đ±ŃƒĐŽĐ”Ń‚ разрыĐČ ŃŃ‚Ń€ĐŸĐșĐž ĐœĐ”ĐżĐŸĐœŃŃ‚ĐœĐŸ ĐłĐŽĐ”đŸđŸš©đŸŽŒđŸŽđŸłïž đŸłïž <200d>đŸŒˆđŸłïž <200d>âš§ïžđŸŽ<200d>☠" + (apply #'concat (make-list 200 "\u0065\u0301 ")) ; composed é \u00E9 + (let ((woman-loves-man ; đŸ‘©â€â€ïžâ€đŸ‘š + (concat "\N{WOMAN}" + "\N{ZERO WIDTH JOINER}" + "\N{HEAVY BLACK HEART}" + "\N{VARIATION SELECTOR-16}" + "\N{ZERO WIDTH JOINER}" + "\N{MAN}" + " "))) + (apply #'concat (make-list 200 woman-loves-man))) + (propertize (let ((varying-height-string + (mapconcat + #'identity + (list "AWi!" + (propertize "foo" 'face '(:height 2.5)) + (propertize "bar" 'face '(:height 0.5)) + (propertize "baz" 'face '(:height 1.0))) + " "))) + (apply #'concat (make-list 100 varying-height-string))) + 'face 'variable-pitch)))) + (dolist (face '(fixed-pitch variable-pitch)) + (dolist (height '(1.0 0.5 1.5)) + (with-temp-buffer + (setq-local face-remapping-alist `((,face . default))) + (face-remap-add-relative 'default :height height) + (dolist (string strings) + (should (eq (length (funcall truncate-string-naive + string max-pixels (current-buffer))) + (length (truncate-string-pixelwise + string max-pixels (current-buffer))))))))))) + (provide 'misc-tests) ;;; misc-tests.el ends here From f081afe23df938e027904d94664e3c5fe3f6b76c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 31 Jan 2026 11:24:53 +0200 Subject: [PATCH 044/191] ; Improve documentation of 'condition-case-unless-debug' * doc/lispref/control.texi (Handling Errors): * lisp/subr.el (condition-case-unless-debug): Improve the documentation of 'condition-case-unless-debug'. (Bug#80234) --- doc/lispref/control.texi | 4 +++- lisp/subr.el | 8 +++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index a4776030cf2..7c3f29c7226 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -2344,7 +2344,9 @@ the other usual filtering mechanisms say it should. @xref{Error Debugging}. The macro @code{condition-case-unless-debug} provides another way to handle debugging of such forms. It behaves exactly like @code{condition-case}, unless the variable @code{debug-on-error} is -non-@code{nil}, in which case it does not handle any errors at all. +non-@code{nil}, in which case it causes Emacs to enter the debugger +before executing any applicable handler. (The applicable handler, if +any, will still run when the debugger exits.) @end defmac Once Emacs decides that a certain handler handles the error, it diff --git a/lisp/subr.el b/lisp/subr.el index 40325c30326..fcf03dd4f67 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -5445,9 +5445,11 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced." (t val))))))) (defmacro condition-case-unless-debug (var bodyform &rest handlers) - "Like `condition-case' except that it does not prevent debugging. -More specifically if `debug-on-error' is set then the debugger will be invoked -even if this catches the signal." + "Like `condition-case', except that it does not prevent debugging. +More specifically, if `debug-on-error' is set, then the debugger will +be invoked even if some handler catches the signal. +Note that this doesn't prevent the handler from executing, it just +causes the debugger to be called before running the handler." (declare (debug condition-case) (indent 2)) `(condition-case ,var ,bodyform From 1652e36c6c303f2934f6b03fd5b37088dac3d6e2 Mon Sep 17 00:00:00 2001 From: Jens Schmidt Date: Sun, 25 Jan 2026 13:57:21 +0100 Subject: [PATCH 045/191] ; Fix documentaion of 'seq-intersection' * doc/lispref/sequences.texi (Sequence Functions): * lisp/emacs-lisp/seq.el (seq-intersection): Fix documentaion of 'seq-intersection'. (Bug#80257) --- doc/lispref/sequences.texi | 6 +++--- lisp/emacs-lisp/seq.el | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 4de739aa915..853b577c910 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -1110,9 +1110,9 @@ instead of the default @code{equal}. @cindex sequences, intersection of @cindex intersection of sequences This function returns a copy of @var{sequence1} from which the -elements that appear in @var{sequence2} where removed. If the optional -argument @var{function} is non-@code{nil}, it is a function of two -arguments to use to compare elements instead of the default +elements that do not appear in @var{sequence2} were removed. If the +optional argument @var{function} is non-@code{nil}, it is a function of +two arguments to use to compare elements instead of the default @code{equal}. @example diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 4963624ee2d..881fae951b6 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -567,7 +567,7 @@ This does not modify SEQUENCE1 or SEQUENCE2." ;;;###autoload (cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) - "Return copy of SEQUENCE1 with elements that appear in SEQUENCE2 removed. + "Return copy of SEQUENCE1 with elements that do not appear in SEQUENCE2 removed. \"Equality\" of elements is defined by the function TESTFN, which defaults to `equal'. This does not modify SEQUENCE1 or SEQUENCE2." From 39dc99518c6a481df1cc544c02461bd2eaff955f Mon Sep 17 00:00:00 2001 From: Kierin Bell Date: Fri, 23 Jan 2026 18:47:04 -0500 Subject: [PATCH 046/191] Add new input method for Tuscarora * lisp/leim/quail/iroquoian.el: New input method "tuscarora-postfix". * etc/NEWS: Announce the new input method. (Bug#80264) --- etc/NEWS | 8 +- lisp/leim/quail/iroquoian.el | 198 ++++++++++++++++++++++++++++++++--- 2 files changed, 190 insertions(+), 16 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 2cf91cfd5f7..8cd29a5659f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -853,10 +853,10 @@ Northern Iroquoian language family: 'mohawk-postfix' (Mohawk [Kanien’kĂ©ha / Kanyen’kĂ©ha / OnkwehonwehnĂ©ha]), 'oneida-postfix' (Oneida [Onʌyote’a·kå· / Onyota’a:kĂĄ: / UkwehuwehnĂ©ha]), 'cayuga-postfix' (Cayuga [Gayogo̱ho:nÇ«hnĂ©ha:ˀ]), 'onondaga-postfix' (Onondaga -[OnĆłdaʔgegĂĄÊ”]), and 'seneca-postfix' (Seneca [Onödowá’ga:’]). -Additionally, there is a general-purpose 'haudenosaunee-postfix' input -method to facilitate writing in the orthographies of the five languages -simultaneously. +[OnĆłdaʔgegĂĄÊ”]), 'seneca-postfix' (Seneca [Onödowá’ga:’]), and +'tuscarora-postfix' (Tuscarora [SkarĂč·ręʔ]). Additionally, there is a +general-purpose 'haudenosaunee-postfix' input method to facilitate +writing in the orthographies of the six languages simultaneously. --- *** New input methods for languages based on Burmese. diff --git a/lisp/leim/quail/iroquoian.el b/lisp/leim/quail/iroquoian.el index 0bd822217b3..748fadf1d09 100644 --- a/lisp/leim/quail/iroquoian.el +++ b/lisp/leim/quail/iroquoian.el @@ -24,7 +24,7 @@ ;; This file implements input methods for Northern Iroquoian languages. -;; Input methods are implemented for all Five Nations Iroquois +;; Input methods are implemented for the following Northern Iroquoian ;; languages: ;; - Mohawk (Kanien’kĂ©ha / Kanyen’kĂ©ha / OnkwehonwehnĂ©ha) @@ -32,6 +32,7 @@ ;; - Onondaga (OnĆłdaʔgegĂĄÊ”) ;; - Cayuga (Gayogo̱ho:nÇ«hnĂ©ha:ˀ) ;; - Seneca (Onödowá’ga:’) +;; - Tuscarora (SkarĂč·ręʔ) ;; A composite input method for all of the languages above is also ;; defined: `haudenosaunee-postfix'. @@ -39,7 +40,6 @@ ;; Input methods are not yet implemented for the remaining Northern ;; Iroquoian languages, including: -;; - Tuscarora (SkarĂč:ręʔ) ;; - Wendat (Huron) / Wyandot ;;; Code: @@ -798,6 +798,159 @@ simultaneously using the input method `haudenosaunee-postfix'." iroquoian-seneca-vowel-alist)) (quail-defrule key trans)) + +;;; Tuscarora + +;; +;; The primary community orthography used for Tuscarora follows that +;; used in Blair Rudes's dictionary (see below). +;; +;; Reference work for Tuscarora orthography: +;; +;; Blair Rudes. 1999. Tuscarora-English/English-Tuscarora +;; dictionary. Toronto: University of Toronto Press. +;; + +(defconst iroquoian-tuscarora-modifier-alist + '(("::" ?\N{MIDDLE DOT})) + "Alist of rules for modifier letters in Tuscarora input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-tuscarora-vowel-alist + '(("a'" ?ĂĄ) + ("a`" ?Ă ) + ("A'" ?Á) + ("A`" ?À) + ("e'" ?Ă©) + ("e`" ?Ăš) + ("E'" ?É) + ("E`" ?È) + ("i'" ?Ă­) + ("i`" ?ĂŹ) + ("I'" ?Í) + ("I`" ?Ì) + ("u'" ?Ăș) + ("u`" ?Ăč) + ("U'" ?Ú) + ("U`" ?Ù) + ("e," ?ę) + ("e,'" ["ę́"]) + ("e,`" ["ę̀"]) + ("E," ?Ę) + ("E,'" ["Ę́"]) + ("E,`" ["Ę̀"]) + + ("a''" ["a'"]) + ("a``" ["a`"]) + ("A''" ["A'"]) + ("A``" ["A`"]) + ("e''" ["e'"]) + ("e``" ["e`"]) + ("E''" ["E'"]) + ("E``" ["E`"]) + ("i''" ["i'"]) + ("i``" ["i`"]) + ("I''" ["I'"]) + ("I``" ["I`"]) + ("u''" ["u'"]) + ("u``" ["u`"]) + ("U''" ["U'"]) + ("U``" ["U`"]) + + ("e,," ["e,"]) + ("e,''" ["ę'"]) + ("e,``" ["ę`"]) + ("E,," ["E,"]) + ("E,''" ["Ę'"]) + ("E,``" ["Ę`"])) + "Alist of rules for vowel letters in Tuscarora input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-tuscarora-consonant-alist + '((";;" ?\N{LATIN LETTER GLOTTAL STOP}) + ("c/" ?č) + ("c//" ["c/"]) + ("C/" ?Č) + ("C//" ["C/"]) + ("t/" ?Ξ) + ("t//" ["t/"])) + "Alist of rules for consonant letters in Tuscarora input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-tuscarora-exception-alist + '(("_" ?\N{COMBINING LOW LINE}) + ("__" ?_)) + "Alist of rules for phonological exception marking in Tuscarora input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "tuscarora-postfix" "Tuscarora" "TUS<" t + "Tuscarora (SkarĂč·ręʔ) input method with postfix modifiers + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | +| \\=` | Grave accent | a` -> à | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+---------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | + +a, e, i, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-------+-------------+------------------------------------| +| ;; | ˀ | Glottal stop | +| c/ | č | Postalveolar affricate | +| C/ | Č | Postalveolar affricate (capital) | +| t/ | Ξ | Voiceless dental fricative | + +h, k, n, r, s, t, w, and y are bound to a single key. + +b, l, m, and p are used rarely in loanwords. They are also each bound +to a single key. + +Stress exception markers: + +| Key | Description | Example | +|-----+--------------------+----------| +| _ | Combining low line | a_ -> aÌČ | + +Note: Not all fonts can properly display a combining low line on all +letters. + +Underlining has been used by some to indicate that vowels behave +exceptionally with regard to stress placement. Alternatively, markup or +other methods can be used to create an underlining effect. + +To enter a plain underscore, type the underscore twice. + +All Haudenosaunee languages, including Tuscarora can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-tuscarora-modifier-alist + iroquoian-tuscarora-consonant-alist + iroquoian-tuscarora-vowel-alist + iroquoian-tuscarora-exception-alist)) + (quail-defrule key trans)) + ;;; Haudenosaunee (composite Northern Iroquoian) @@ -857,7 +1010,8 @@ simultaneously using the input method `haudenosaunee-postfix'." iroquoian-oneida-modifier-alist iroquoian-onondaga-modifier-alist iroquoian-cayuga-modifier-alist - iroquoian-seneca-modifier-alist)) + iroquoian-seneca-modifier-alist + iroquoian-tuscarora-modifier-alist)) "Alist of rules for modifier letters in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") @@ -866,7 +1020,8 @@ Entries are as with rules in `quail-define-rules'.") iroquoian-oneida-vowel-alist iroquoian-onondaga-vowel-alist iroquoian-cayuga-vowel-alist - iroquoian-seneca-vowel-alist)) + iroquoian-seneca-vowel-alist + iroquoian-tuscarora-vowel-alist)) "Alist of rules for vowel letters in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") @@ -879,16 +1034,17 @@ Entries are as with rules in `quail-define-rules'.") iroquoian-oneida-consonant-alist iroquoian-onondaga-consonant-alist iroquoian-cayuga-consonant-alist - iroquoian-seneca-consonant-alist) + iroquoian-seneca-consonant-alist + iroquoian-tuscarora-consonant-alist) (lambda (c1 c2) (equal (car c1) (car c2)))) "Alist of rules for consonant letters in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") -(defconst iroquoian-haudenosaunee-devoicing-alist +(defconst iroquoian-haudenosaunee-exception-alist '(("_" ?\N{COMBINING LOW LINE}) ("__" ?_)) - "Alist of rules for devoicing characters in Haudenosaunee input methods. + "Alist of rules for phonological exception markers in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") (defconst iroquoian-haudenosaunee-nasal-alist iroquoian-onondaga-nasal-alist @@ -906,6 +1062,7 @@ This input method can be used to enter the following languages: - Cayuga (Gayogo̱ho:nÇ«hnĂ©ha:ˀ) - Onondaga (OnĆłdaʔgegĂĄÊ”) - Seneca (Onödowá’ga:’) +- Tuscarora (SkarĂč·ręʔ) Modifiers: @@ -989,6 +1146,12 @@ Vowels: | a\" | Ă€ | Low front vowel | | A\" | Ä | Low front vowel (capital) | | Single-key vowels: a e i o u | +|----------------------------------------------------------------------| +| Tuscarora | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| Single-key vowels: a e i u | Consonants: @@ -1023,8 +1186,16 @@ Consonants: | s/ | ĆĄ | Voiceless postalveolar fricative | | S/ | Ć  | Voiceless postalveolar fricative (capital) | | Single-key consonants: d g h j k n s t w y z (b m p) | +|----------------------------------------------------------------------| +| Tuscarora | +| -------------------------------------------------------------------- | +| ;: | ʔ | Glottal stop (alternate) | +| c/ | č | Postalveolar affricate | +| C/ | Č | Postalveolar affricate (capital) | +| t/ | Ξ | Voiceless dental fricative | +| Single-key consonants: h k n r s t w y (b l m p) | -Devoicing: +Phonological exception markers: | Key | Description | Examples | |-----+------------------------+------------------------------| @@ -1035,8 +1206,10 @@ Note: Not all fonts can properly display a combining low line on all letters and a combining macron below on all vowels. Underlining is commonly used in Oneida to indicate devoiced syllables on -pre-pausal forms (also called utterance-final forms). Alternatively, -markup or other methods can be used to create an underlining effect. +pre-pausal forms (also called utterance-final forms), and it has been +used in some Tuscarora orthographies to indicate that vowels behave +exceptionally with regard to stress placement. Alternatively, markup or +other methods can be used to create an underlining effect. To enter a plain underscore, the underscore twice. @@ -1046,7 +1219,8 @@ To enter a plain hyphen after a vowel, simply type the hyphen twice. There are individual input methods for each of the languages that can be entered with this input method: `mohawk-postfix', `oneida-postfix', -`onondaga-postfix', `cayuga-postfix', `seneca-postfix'." +`onondaga-postfix', `cayuga-postfix', `seneca-postfix', +`tuscarora-postfix'.." nil t nil nil nil nil nil nil nil nil t) (pcase-dolist (`(,key ,trans) @@ -1054,7 +1228,7 @@ entered with this input method: `mohawk-postfix', `oneida-postfix', iroquoian-haudenosaunee-consonant-alist iroquoian-haudenosaunee-nasal-alist iroquoian-haudenosaunee-vowel-alist - iroquoian-haudenosaunee-devoicing-alist)) + iroquoian-haudenosaunee-exception-alist)) (quail-defrule key trans)) (provide 'iroquoian) From cd152ea6114cda81b839a465af5ebd09fb342b09 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 31 Jan 2026 12:06:53 +0200 Subject: [PATCH 047/191] ; Fix last change * lisp/leim/quail/iroquoian.el (iroquoian-haudenosaunee-exception-alist): Doc fix. --- lisp/leim/quail/iroquoian.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/leim/quail/iroquoian.el b/lisp/leim/quail/iroquoian.el index 748fadf1d09..66aea7da38a 100644 --- a/lisp/leim/quail/iroquoian.el +++ b/lisp/leim/quail/iroquoian.el @@ -1044,7 +1044,7 @@ Entries are as with rules in `quail-define-rules'.") (defconst iroquoian-haudenosaunee-exception-alist '(("_" ?\N{COMBINING LOW LINE}) ("__" ?_)) - "Alist of rules for phonological exception markers in Haudenosaunee input methods. + "Rules' alist for phonological exception markers in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") (defconst iroquoian-haudenosaunee-nasal-alist iroquoian-onondaga-nasal-alist From 049eefa611912c6894c5fdeef2127ab2165e0144 Mon Sep 17 00:00:00 2001 From: "Jacob S. Gordon" Date: Mon, 26 Jan 2026 16:20:00 -0500 Subject: [PATCH 048/191] display-time: Add option to customize help-echo format This option controls the format of the help-echo when hovering over the time display in mode line. (Bug#80143) * lisp/time.el (display-time-help-echo-format): Add option. (display-time-string-forms): Use it. * etc/NEWS (Time): Announce the new option. --- etc/NEWS | 5 +++++ lisp/time.el | 16 +++++++++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 8cd29a5659f..8929fcc1215 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3338,6 +3338,11 @@ each refresh. The sort direction can be controlled by using a cons cell of a format string and a boolean. Alternatively, a sorting function can be provided directly. +--- +*** New user option 'display-time-help-echo-format'. +This option controls the format of the help echo when hovering over the +time. + ** Fill +++ diff --git a/lisp/time.el b/lisp/time.el index c78a51e9f97..f553ebab413 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -177,6 +177,18 @@ depend on `display-time-day-and-date' and `display-time-24hr-format'." :type '(choice (const :tag "Default" nil) string)) +(defcustom display-time-help-echo-format "%a %b %e, %Y" + "Format for the help echo when hovering over the time in the mode line. +Use the function `customize-variable' to choose a common format, and/or +see the function `format-time-string' for an explanation of the syntax." + :version "31.1" + :type `(choice + ,@(mapcar #'(lambda (fmt) + (list 'const + ':tag (format-time-string fmt 0 "UTC") fmt)) + '("%a %b %e, %Y" "%F (%a)" "%a %D")) + (string :tag "Format string"))) + (defcustom display-time-string-forms '((if (and (not display-time-format) display-time-day-and-date) (format-time-string "%a %b %e " now) @@ -186,7 +198,9 @@ depend on `display-time-day-and-date' and `display-time-24hr-format'." (if display-time-24hr-format "%H:%M" "%-I:%M%p")) now) 'face 'display-time-date-and-time - 'help-echo (format-time-string "%a %b %e, %Y" now)) + 'help-echo (format-time-string (if (stringp display-time-help-echo-format) + display-time-help-echo-format + "%a %b %e, %Y") now)) load (if mail ;; Build the string every time to act on customization. From 046f5ef018997e8ef60d2157864ed7d02934d81f Mon Sep 17 00:00:00 2001 From: Boris Buliga Date: Sat, 31 Jan 2026 12:18:08 +0200 Subject: [PATCH 049/191] Fix macOS 26 (Tahoe) scrolling lag and input handling issues macOS 26 introduced new event processing behavior that causes scrolling lag and input handling problems in Emacs. This patch disables two features via NSUserDefaults when built against the macOS 26 SDK: - NSEventConcurrentProcessingEnabled - NSApplicationUpdateCycleEnabled This fix is based on the equivalent patch in emacs-mac by Mitsuharu Yamamoto. See: https://bitbucket.org/mituharu/emacs-mac/commits/e52ebfd * src/nsterm.m (ns_term_init): Disable problematic event processing when built for macOS 26+. (Bug#80268) --- src/nsterm.m | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/nsterm.m b/src/nsterm.m index ca06195a798..c852b70be74 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5838,6 +5838,15 @@ static Lisp_Object ns_new_font (struct frame *f, Lisp_Object font_object, ns_pending_service_names = [[NSMutableArray alloc] init]; ns_pending_service_args = [[NSMutableArray alloc] init]; +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 260000 + /* Disable problematic event processing on macOS 26 (Tahoe) to avoid + scrolling lag and input handling issues. These are undocumented + options as of macOS 26.0. */ + [NSUserDefaults.standardUserDefaults + registerDefaults:@{@"NSEventConcurrentProcessingEnabled" : @"NO", + @"NSApplicationUpdateCycleEnabled" : @"NO"}]; +#endif + /* Start app and create the main menu, window, view. Needs to be here because ns_initialize_display_info () uses AppKit classes. The view will then ask the NSApp to stop and return to Emacs. */ From f7edfdcfd465f3ac9b0f870b2bf0b9a3a234bd9d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 31 Jan 2026 12:59:17 +0200 Subject: [PATCH 050/191] ; Fix documentation of 'help-fns-describe-function-functions' * lisp/help-fns.el (help-fns-describe-function-functions): Doc fix (bug#80291). --- lisp/help-fns.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 6cbc75f92fb..73066dd6f3d 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -40,8 +40,8 @@ (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. -Those functions will be run after the header line and argument -list was inserted, and before the documentation is inserted. +Those functions will be run after the header line, the argument +list, and the function's documentation are inserted. The functions will be called with one argument: the function's symbol. They can assume that a newline was output just before they were called, and they should terminate any of their own output with a newline. From b75bfa219ecc8baed724b1da989582c5c6ed753e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 31 Jan 2026 13:13:57 +0200 Subject: [PATCH 051/191] ; * admin/authors.el (authors-aliases): Add Boris Buliga. --- admin/authors.el | 1 + 1 file changed, 1 insertion(+) diff --git a/admin/authors.el b/admin/authors.el index afcc56c6003..41653b8bddf 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -69,6 +69,7 @@ files.") (nil "BlaCk_Void" "alstjr7375@daum\\.net") (nil "bug-gnu-emacs@gnu\\.org") ; mistake ("Björn Torkelsson" "Bjorn Torkelsson") + ("Boris Buliga" "boris@d12frosted\\.io") (nil "brandon\\.irizarry@gmail\\.com") ("Brian Fox" "Brian J\\. Fox") ("Brian P Templeton" "BT Templeton") From 346f1bda6bf07776587bacb19f19d82ee026220c Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 31 Jan 2026 13:37:56 +0100 Subject: [PATCH 052/191] Improve connection-local variables documentation. * doc/emacs/custom.texi (Connection Variables): * doc/lispref/variables.texi (Applying Connection Local Variables): Improve documentation. --- doc/emacs/custom.texi | 78 ++++++++++++++++++++++++++++---------- doc/lispref/variables.texi | 13 +++++++ 2 files changed, 72 insertions(+), 19 deletions(-) diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 7663e2b21df..d79bcf3fe0f 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1615,24 +1615,30 @@ your preference, such as @code{ws-butler-mode}. @cindex per-connection local variables Most of the variables reflect the situation on the local machine. -Often, they must use a different value when you operate in buffers -with a remote default directory. Think about the behavior when -calling @code{shell} -- on your local machine, you might use -@file{/bin/bash} and rely on termcap, but on a remote machine, it may -be @file{/bin/ksh} and terminfo. +Often, they must use a different value when you operate in buffers with +a remote default directory. Think about the behavior when calling +@code{shell} --- on your local machine, you might use @file{/bin/bash} +and rely on termcap, but on a remote machine, it may be @file{/bin/ksh} +and terminfo. - This can be accomplished with @dfn{connection-local variables}. -Directory and file local variables override connection-local -variables. Unsafe connection-local variables are handled in the same -way as unsafe file-local variables (@pxref{Safe File Variables}). + This can be accomplished with @dfn{connection-local variables}. Such +variables are declared depending on the value of +@code{default-directory} of the current buffer. When a buffer has a +remote @code{default-directory}, and there exist a connection-local +variable which matches @code{default-directory}, this alternative value +of the variable is used. Directory and file local variables override +connection-local variables. Unsafe connection-local variables are +handled in the same way as unsafe file-local variables (@pxref{Safe File +Variables}). @findex connection-local-set-profile-variables @findex connection-local-set-profiles - Connection-local variables are declared as a group of -variables/value pairs in a @dfn{profile}, using the + Connection-local variables are declared as a group of variables/value +pairs in a @dfn{profile}, using the @code{connection-local-set-profile-variables} function. The function -@code{connection-local-set-profiles} activates profiles for a given -criteria, identifying a remote machine: +@code{connection-local-set-profiles} declares profiles for a given +criteria (the first argument), identifying a remote machine with respect +to @code{default-directory} of the current buffer: @example (connection-local-set-profile-variables 'remote-terminfo @@ -1654,12 +1660,46 @@ criteria, identifying a remote machine: This code declares three different profiles, @code{remote-terminfo}, @code{remote-ksh}, and @code{remote-bash}. The profiles -@code{remote-terminfo} and @code{remote-ksh} are applied to all -buffers which have a remote default directory matching the regexp -@code{"remotemachine"} as host name. Such a criteria can also -discriminate for the properties @code{:protocol} (this is the Tramp -method) or @code{:user} (a remote user name). The @code{nil} criteria -matches all buffers with a remote default directory. +@code{remote-terminfo} and @code{remote-ksh} are applied to all buffers +which have a remote @code{default-directory} matching the string +@code{"remotemachine"} as host name. + + Criteria, the first argument of @code{connection-local-set-profiles}, +specifies, how the profiles match @code{default-directory}. It is a +plist identifying a connection and the application using this +connection. Property names might be @code{:application}, +@code{:protocol}, @code{:user} and @code{:machine}. The property value +of @code{:application} is a symbol, all other property values are +strings. In general the symbol @code{tramp} should be used as +@code{:application} value. Some packages use a different +@code{:application} (for example @code{eshell} or @code{vc-git}); they +say it in their documentation then. All properties are optional. + + The other properties are used for checking @code{default-directory}. +The propertiy @code{:protocol} is used for the method a remote +@code{default-directory} uses, the property +@code{:user} is the remote user name, and the property @code{:machine} +is the remote host name. All checks are performed via +@code{string-equal}. The @code{nil} criteria matches all buffers +with a remote default directory. + + Connection-local variables are not activated by default. A package +which uses connection-local variables must activate them for a given +buffer, specifying for which @code{:application} it uses them. +@xref{Applying Connection Local Variables,,, elisp, The Emacs Lisp +Reference Manual}, for details. + + After the above definition of profiles and their activation, any +connection made by Tramp to the @samp{remotemachine} system will use + +@itemize +@item @code{t} as the connection-specific value of @code{system-uses-terminfo}, +@item @samp{dumb-emacs-ansi} as the connection-specific value of +@code{comint-terminfo-terminal}, +@item @samp{/bin/ksh} as the connection-specific value of as +@code{shell-file-name}, +@item @samp{-c} as the connection-specific value of @code{shell-command-switch}. +@end itemize Be careful when declaring different profiles with the same variable, and setting these profiles to criteria which could match in parallel. diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 29a272eec92..2f5ee037f3e 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2653,6 +2653,19 @@ This macro returns the connection-local value of @var{symbol} for If @var{symbol} does not have a connection-local binding, the value is the default binding of the variable. + +The difference to @code{with-connection-local@{-application@}-variables} +is, that @code{symbol} is not set buffer-local. A typical usage pattern +is to use only the the connection value of a variable if it exists, and +not to use its default value otherwise (using @code{my-app-variable} +initialized above): + +@lisp +(if (connection-local-p my-app-variable 'my-app) + (connection-local-value my-app-variable 'my-app) + ;; Something else. + ) +@end lisp @end defmac @defvar enable-connection-local-variables From e08efecd96bbe1fa15fc0d94f631acadef6566de Mon Sep 17 00:00:00 2001 From: Jens Schmidt Date: Sun, 25 Jan 2026 13:57:21 +0100 Subject: [PATCH 053/191] Improve documentation of 'seq-difference' * doc/lispref/sequences.texi (Sequence Functions): * lisp/emacs-lisp/seq.el (seq-difference): Clarify the documentation of 'seq-difference'. (Bug#80257) --- doc/lispref/sequences.texi | 9 +++++---- lisp/emacs-lisp/seq.el | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 853b577c910..afee255346c 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -1125,10 +1125,11 @@ two arguments to use to compare elements instead of the default @defun seq-difference sequence1 sequence2 &optional function - This function returns a list of the elements that appear in -@var{sequence1} but not in @var{sequence2}. If the optional argument -@var{function} is non-@code{nil}, it is a function of two arguments to -use to compare elements instead of the default @code{equal}. + This function returns a copy of @var{sequence1} from which the +elements that appear in @var{sequence2} were removed. If the optional +argument @var{function} is non-@code{nil}, it is a function of two +arguments to use to compare elements instead of the default +@code{equal}. @example @group diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 881fae951b6..e0a41b380b5 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -579,7 +579,7 @@ This does not modify SEQUENCE1 or SEQUENCE2." '())) (cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) - "Return list of all the elements that appear in SEQUENCE1 but not in SEQUENCE2. + "Return copy of SEQUENCE1 with elements that appear in SEQUENCE2 removed. \"Equality\" of elements is defined by the function TESTFN, which defaults to `equal'. This does not modify SEQUENCE1 or SEQUENCE2." From 385bcc6117349363a562871815005c87f9483590 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sat, 31 Jan 2026 15:52:26 +0100 Subject: [PATCH 054/191] Fix lazy doc string fontify bug in elisp-byte-code-mode (bug#80292) * lisp/progmodes/elisp-mode.el (elisp-byte-code-syntax-propertize): Reset point to just after the start of the previous match so that we don't skip past the end of the lazy string, which can happen if it's zero-length; that could lead to an infinite loop. --- lisp/progmodes/elisp-mode.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index c4fb6946aeb..14cc5abd6a8 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -1783,7 +1783,9 @@ and `eval-expression-print-level'. (funcall (syntax-propertize-rules (emacs-lisp-byte-code-comment-re - (1 (prog1 "< b" (elisp--byte-code-comment end (point)))))) + (1 (prog1 "< b" + (goto-char (match-end 1)) + (elisp--byte-code-comment end (point)))))) start end)) ;;;###autoload From 87dfb040b08adf22cea41115adaa913997c04437 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sat, 31 Jan 2026 15:55:47 +0100 Subject: [PATCH 055/191] Don't produce zero-length lazy strings * lisp/emacs-lisp/bytecomp.el (byte-compile--docstring): There is no gain from making an empty string lazy. (It also contributed to bug#80292.) --- lisp/emacs-lisp/bytecomp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index edfd9491a2f..949a1a5e517 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1856,7 +1856,8 @@ It is too wide if it has any lines longer than the largest of ;; The native compiler doesn't use those dynamic docstrings. (not byte-native-compiling) ;; Docstrings can only be dynamic when compiling a file. - byte-compile--\#$) + byte-compile--\#$ + (not (equal doc ""))) ; empty lazy strings are pointless (let* ((byte-pos (with-memoization ;; Reuse a previously written identical docstring. ;; This is not done out of thriftiness but to try and From 967294d2cb4db828b514293f4b32d8ca7caadf39 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 1 Feb 2026 08:49:57 +0200 Subject: [PATCH 056/191] Fix desktop saving and restoring in daemon sessions * lisp/desktop.el (desktop--check-dont-save): Don't save daemon's initial frame. * lisp/frameset.el (frameset-restore): Don't try deleting the daemon's initial frame. (Bug#80294) --- lisp/desktop.el | 10 ++++++++-- lisp/frameset.el | 15 ++++++++++++--- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/lisp/desktop.el b/lisp/desktop.el index 74961032303..df98079b1c2 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -1064,13 +1064,19 @@ DIRNAME must be the directory in which the desktop file will be saved." ;; ---------------------------------------------------------------------------- (defun desktop--check-dont-save (frame) - (not (frame-parameter frame 'desktop-dont-save))) + (and (not (frame-parameter frame 'desktop-dont-save)) + ;; Don't save daemon initial frames, since we cannot (and don't + ;; need to) restore them. + (not (and (daemonp) + (equal (terminal-name (frame-terminal frame)) + "initial_terminal"))))) (defconst desktop--app-id `(desktop . ,desktop-file-version)) (defun desktop-save-frameset () "Save the state of existing frames in `desktop-saved-frameset'. -Frames with a non-nil `desktop-dont-save' parameter are not saved." +Frames with a non-nil `desktop-dont-save' parameter are not saved. +Likewise the initial frame of a daemon sesion." (setq desktop-saved-frameset (and desktop-restore-frames (frameset-save nil diff --git a/lisp/frameset.el b/lisp/frameset.el index 85a90f67c68..e11a1da7e9b 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1362,9 +1362,18 @@ All keyword parameters default to nil." ;; Clean up the frame list (when cleanup-frames (let ((map nil) - (cleanup (if (eq cleanup-frames t) - (lambda (frame action) - (when (memq action '(:rejected :ignored)) + (cleanup + (if (eq cleanup-frames t) + (lambda (frame action) + (when (and (memq action '(:rejected :ignored)) + ;; Don't try deleting the daemon's initial + ;; frame, as that would only trigger + ;; warnings. + (not + (and (daemonp) + (equal (terminal-name (frame-terminal + frame)) + "initial_terminal")))) (delete-frame frame))) cleanup-frames))) (maphash (lambda (frame _action) (push frame map)) frameset--action-map) From ac07913bd81db8ffdab2754cc6f75158460ee02b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 1 Feb 2026 12:46:45 +0100 Subject: [PATCH 057/191] ; * lisp/progmodes/elisp-mode.el: slightly better rescanning point Suggested by Stefan Monnier. --- lisp/progmodes/elisp-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 14cc5abd6a8..f5c3dc3fbb2 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -1784,7 +1784,7 @@ and `eval-expression-print-level'. (syntax-propertize-rules (emacs-lisp-byte-code-comment-re (1 (prog1 "< b" - (goto-char (match-end 1)) + (goto-char (match-end 2)) (elisp--byte-code-comment end (point)))))) start end)) From d13769955eea8b448805bc8cba18a983d91fc477 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 14:14:17 +0100 Subject: [PATCH 058/191] Inline database of package suggestions * lisp/emacs-lisp/package.el (package--autosuggest-database): Remove unnecessary variable. (package--autosuggest-find-candidates): Load the database at compile time. (package--autosuggest-suggested, package--suggestion-applies-p) (package--autosuggest-install-and-enable): Update documentation. --- lisp/emacs-lisp/package.el | 69 ++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ebec10e3739..d50e06845b8 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4532,23 +4532,6 @@ The list is displayed in a buffer named `*Packages*'." ;;;; Autosuggest -(defconst package--autosuggest-database - (eval-when-compile - (with-temp-buffer - (insert-file-contents - (expand-file-name "package-autosuggest.eld" data-directory)) - (read (current-buffer)))) - "List of hints for packages to suggest installing. -Each hint has the form (PACKAGE TYPE DATA), where PACKAGE is a symbol -denoting the package and major-mode the hint applies to, TYPE is one of -`auto-mode-alist', `magic-mode-alist' or `interpreter-mode-alist' -indicating the type of check to be made and DATA is the value to check -against TYPE in the intuitive way (e.g. for `auto-mode-alist' DATA is a -regular expression matching a file name that PACKAGE should be suggested -for). If the package name and the major mode name differ, then an -optional forth element MAJOR-MODE can indicate what command to invoke to -enable the package.") - (defcustom package-autosuggest-style 'mode-line "How to draw attention to `package-autosuggest-mode' suggestions. You can set this value to `mode-line' (default) to indicate the @@ -4572,19 +4555,25 @@ the existence of a suggestion." (defvar package--autosuggest-suggested '() "List of packages that have already been suggested. -The elements of this list should be a subset of elements from -`package--autosuggest-database'. Suggestions found in this list will not -count as suggestions (e.g. if `package-autosuggest-style' is set to -`mode-line', a suggestion found in here will inhibit -`package-autosuggest-mode' from displaying a hint in the mode line).") +Suggestions found in this list will not count as suggestions (e.g. if +`package-autosuggest-style' is set to `mode-line', a suggestion found in +here will inhibit `package-autosuggest-mode' from displaying a hint in +the mode line).") (defun package--suggestion-applies-p (sug) "Check if a suggestion SUG is applicable to the current buffer. -SUG should be an element of `package--autosuggest-database'." +Each suggestion has the form (PACKAGE TYPE DATA), where PACKAGE is a +symbol denoting the package and major-mode the suggestion applies to, +TYPE is one of `auto-mode-alist', `magic-mode-alist' or +`interpreter-mode-alist' indicating the type of check to be made and +DATA is the value to check against TYPE in the intuitive way (e.g. for +`auto-mode-alist' DATA is a regular expression matching a file name that +PACKAGE should be suggested for). If the package name and the major +mode name differ, then an optional forth element MAJOR-MODE can indicate +what command to invoke to enable the package." (pcase sug - (`(,(or (pred (lambda (e) (assq e package--autosuggest-suggested))) - (pred package-installed-p)) - . ,_) + ((or (guard (not (eq major-mode 'fundamental-mode))) + `(,(pred package-installed-p) . ,_)) nil) ((or `(,_ auto-mode-alist ,ext ,_) `(,_ auto-mode-alist ,ext)) @@ -4606,19 +4595,27 @@ SUG should be an element of `package--autosuggest-database'." magic))))))) (defun package--autosuggest-find-candidates () - "Return a list of suggestions that might be interesting the current buffer. -The elements of the returned list will be a subset of the elements of -`package--autosuggest-suggested'." - (and package-autosuggest-mode (eq major-mode 'fundamental-mode) - (let (suggetions) - (dolist (sug package--autosuggest-database) - (when (package--suggestion-applies-p sug) - (push sug suggetions))) - suggetions))) + "Return a list of suggestions that might be interesting the current buffer. +The elements of the returned list will have the form described in +`package--suggestion-applies-p'." + (and (eq major-mode 'fundamental-mode) + (let ((suggetions '())) + (dolist (sug (eval-when-compile + (with-temp-buffer + (insert-file-contents + (expand-file-name "package-autosuggest.eld" + data-directory)) + (read (current-buffer))))) + (when (and (package--suggestion-applies-p sug) + (if (eq package-autosuggest-style 'once) + (not (memq (car sug) package--autosuggest-suggested)) + t)) + (push sug suggetions))) + suggetions))) (defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. -SUG should be an element of `package--autosuggest-database'." +SUG should be of the form as described in `package--suggestion-applies-p'." (let ((buffers-to-update '())) (dolist (buf (buffer-list)) (with-current-buffer buf From ad89a3e8d66a8100a9deb1331242cdcd63fc451f Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 14:20:01 +0100 Subject: [PATCH 059/191] Display hint for package suggestions after mode name * lisp/emacs-lisp/package.el (package--autosugest-line-format): Insert a space before the mode-line hint. (package--autosuggest-after-change-mode): Add hint to 'mode-name'. --- lisp/emacs-lisp/package.el | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d50e06845b8..5aae6babc67 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4644,7 +4644,7 @@ SUG should be of the form as described in `package--suggestion-applies-p'." ((eq package-autosuggest-style 'mode-line)) (avail (package--autosuggest-find-candidates))) (propertize - (format "Install %s?" + (format " Install %s?" (mapconcat #'symbol-name (delete-dups (mapcar #'car avail)) @@ -4656,10 +4656,6 @@ SUG should be of the form as described in `package--suggestion-applies-p'." (define-key map [mode-line down-mouse-1] #'package-autosuggest) map))))) -(add-to-list - 'mode-line-misc-info - '(package-autosuggest-mode ("" package--autosugest-line-format))) - (defun package--autosuggest-after-change-mode () "Display package suggestions for the current buffer. This function should be added to `after-change-major-mode-hook'." @@ -4669,6 +4665,9 @@ This function should be added to `after-change-major-mode-hook'." ", "))) (pcase-exhaustive package-autosuggest-style ('mode-line + (setq mode-name (append (ensure-list mode-name) + '((package-autosuggest-mode + package--autosugest-line-format)))) (force-mode-line-update t)) ('always (when (yes-or-no-p (format "Install suggested packages (%s)?" pkgs)) From b6b599aa83e56a8a70a9cdccd4640830558d288d Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 15:14:10 +0100 Subject: [PATCH 060/191] Add more elaborate prompt when suggesting packages * lisp/emacs-lisp/package.el (package--autosugest-prompt): Add new function. (package--autosuggest-after-change-mode, package-autosuggest): Call new function. --- lisp/emacs-lisp/package.el | 80 +++++++++++++++++++++++++++----------- 1 file changed, 58 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5aae6babc67..f68bd4f7d55 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4656,6 +4656,59 @@ SUG should be of the form as described in `package--suggestion-applies-p'." (define-key map [mode-line down-mouse-1] #'package-autosuggest) map))))) +(defun package--autosugest-prompt (packages) + "Query the user whether to install PACKAGES or not. +PACKAGES is a list of package suggestions in the form as described in +`package--suggestion-applies-p'. The function returns a non-nil value +if affirmative, otherwise nil" + (let* ((inhibit-read-only t) (use-hard-newlines t) + (nl (propertize "\n" 'hard t)) (nlnl (concat nl nl)) + (buf (current-buffer))) + (with-current-buffer (get-buffer-create + (format "*package suggestion: %s*" + (buffer-name buf))) + (erase-buffer) + (insert + "The buffer \"" + (buffer-name buf) + "\" currently lacks any language-specific support. +The package manager has detected that by installing a third-party package, +Emacs can provide the editor support for these kinds of files:" nl) + + (when (length> packages 1) + (insert nl "(Note that there are multiple candidate packages, +so you have to select which to install!)" nl)) + + (pcase-dolist ((and sug `(,pkg . ,_)) packages) + (insert nl "* " (buttonize "Install" #'package--autosuggest-install-and-enable sug) + " \"" (buttonize (symbol-name pkg) #'describe-package pkg) "\".") + (add-to-list 'package--autosuggest-suggested pkg)) + + (insert nl "* " (buttonize "Do not install anything" (lambda (_) (quit-window))) "." + nl "* " (buttonize "Permanently disable package suggestions" + (lambda (_) + (customize-save-variable + 'package-autosuggest-mode nil + "Disabled at user's request") + (quit-window))) + "." + + nlnl "To learn more about package management, read " + (buttonize "(emacs) Packages" (lambda (_) (info "(emacs) Packages"))) + ".") + + (fill-region (point-min) (point-max)) + (special-mode) + (button-mode t) + (enriched-mode t) + (variable-pitch-mode t) + + (let ((win (display-buffer-below-selected (current-buffer) '()))) + (fit-window-to-buffer win) + (select-window win) + (set-window-dedicated-p win t) + (set-window-point win (point-min)))))) + (defun package--autosuggest-after-change-mode () "Display package suggestions for the current buffer. This function should be added to `after-change-major-mode-hook'." @@ -4669,13 +4722,8 @@ This function should be added to `after-change-major-mode-hook'." '((package-autosuggest-mode package--autosugest-line-format)))) (force-mode-line-update t)) - ('always - (when (yes-or-no-p (format "Install suggested packages (%s)?" pkgs)) - (mapc #'package--autosuggest-install-and-enable avail))) - ('once - (when (yes-or-no-p (format "Install suggested packages (%s)?" pkgs)) - (mapc #'package--autosuggest-install-and-enable avail)) - (setq package--autosuggest-suggested (append avail package--autosuggest-suggested))) + ((or 'once 'always) + (package--autosugest-prompt avail)) ('message (message (substitute-command-keys @@ -4685,21 +4733,9 @@ This function should be added to `after-change-major-mode-hook'." (defun package-autosuggest () "Prompt the user to install the suggested packages." (interactive) - (let* ((avail (or (package--autosuggest-find-candidates) - (user-error "No suggestions found"))) - (use-dialog-box t) - (prompt (concat - "Install " - (mapconcat - #'symbol-name - (delete-dups (mapcar #'car avail)) - ", ") - "?"))) - (if (yes-or-no-p prompt) - (mapc #'package--autosuggest-install-and-enable avail) - (setq package--autosuggest-suggested (append avail package--autosuggest-suggested)) - (when (eq package-autosuggest-style 'mode-line) - (force-mode-line-update t))))) + (let ((avail (or (package--autosuggest-find-candidates) + (user-error "No package suggestions found")))) + (package--autosugest-prompt avail))) (defun package-reset-suggestions () "Forget previous package suggestions. From 4db3be200114caacf068f56dc60796fd7c77b619 Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Wed, 7 Jan 2026 18:19:13 +0100 Subject: [PATCH 061/191] Fix iCalendar macro (debug ...) forms and indentation As discussed in Bug#74994. * lisp/calendar/icalendar-ast.el (icalendar-make-param) (icalendar-make-property, icalendar-make-component) (icalendar-make-node-from-templates) * lisp/calendar/icalendar-macs.el (icalendar-with-node-children) (icalendar-with-node-value, icalendar-with-param) (icalendar-with-child-of, icalendar-with-property-of): Remove extraneous arguments in (debug ...) forms. * lisp/calendar/icalendar-recur.el * lisp/calendar/diary-icalendar.el: Fix indentation of calls to them. Plus one other minor fix: * lisp/calendar/diary-icalendar.el (diary-icalendar-current-tz-to-vtimezone): Ignore unused error variable (fixes a byte compiler warning). --- lisp/calendar/diary-icalendar.el | 24 ++++++++++++------------ lisp/calendar/icalendar-ast.el | 10 +++++----- lisp/calendar/icalendar-macs.el | 10 +++++----- lisp/calendar/icalendar-recur.el | 32 ++++++++++++++++---------------- 4 files changed, 38 insertions(+), 38 deletions(-) diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index eed53bfd700..c15e2cdbddf 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -2111,7 +2111,7 @@ node. Return this node, or nil." (when (and di:class-regexp (re-search-forward di:class-regexp nil t)) (ical:make-property ical:class - (upcase (string-trim (match-string 1)))))) + (upcase (string-trim (match-string 1)))))) (defun di:parse-status () "Parse `icalendar-status' node from entry. @@ -2123,7 +2123,7 @@ as an `icalendar-status' node. Return this node, or nil." (when (and di:status-regexp (re-search-forward di:status-regexp nil t)) (ical:make-property ical:status - (upcase (string-trim (match-string 1)))))) + (upcase (string-trim (match-string 1)))))) (defun di:parse-url () "Parse `icalendar-url' node from entry. @@ -2635,7 +2635,7 @@ Returns a pair of nodes (START RRULE)." "`diary-float' with large N=%d may not be supported on other systems" n))) (list (ical:make-property ical:dtstart dtstart - (ical:valuetypeparam 'ical:date)) + (ical:valuetypeparam 'ical:date)) (ical:make-property ical:rrule rrule)))) (defun di:offset-sexp-to-nodes (sexp) @@ -2824,7 +2824,7 @@ formatting alarms as mail messages. Returns the modified COMPONENT." (setq all-attendees (append entry-attendees all-attendees))) ((stringp address) (push (ical:make-property ical:attendee - (concat "mailto:" address)) + (concat "mailto:" address)) all-attendees)))) (push (ical:make-valarm (ical:action "EMAIL") @@ -2968,7 +2968,7 @@ nil, if MONTHS, DAYS and YEARS are all integers)." (rrule-node (when freq (ical:make-property ical:rrule recur-value))) (rdate-node (when rdates (ical:make-property ical:rdate rdates - (ical:valuetypeparam rdate-type)))) + (ical:valuetypeparam rdate-type)))) (dtstart-node (ical:make-property ical:dtstart dtstart))) (list dtstart-node (or rrule-node rdate-node)))))) @@ -3050,16 +3050,16 @@ property and must be present even if the recurrence set is empty.)" (append (list (ical:make-property ical:dtstart dtstart - (ical:valuetypeparam 'ical:date)) + (ical:valuetypeparam 'ical:date)) ;; TODO: should we maybe use an X-name property for this? (ical:make-property ical:comment (format "%s" sexp))) (if rdates (list (ical:make-property ical:rdate rdates - (ical:valuetypeparam 'ical:date))) + (ical:valuetypeparam 'ical:date))) (list (ical:make-property ical:exdate exdates - (ical:valuetypeparam 'ical:date))))))) + (ical:valuetypeparam 'ical:date))))))) (defun di:sexp-to-nodes (sexp &optional vtimezone) "Convert a diary S-expression SEXP to a list of iCalendar property nodes. @@ -3110,7 +3110,7 @@ times according to `diary-icalendar-time-zone-export-strategy'." See `icalendar-recur-current-tz-to-vtimezone' for arguments' meanings. This function wraps that one, but signals `icalendar-diary-export-error' instead if TZ cannot be converted." - (condition-case err + (condition-case _ (icr:current-tz-to-vtimezone tz tzid start-year) ((ical:tz-insufficient-data ical:tz-unsupported) (di:signal-export-error @@ -3270,7 +3270,7 @@ recursive calls to this function made by :buffer (current-buffer) :position (point))) (push (ical:make-property ical:duration - (ical:duration-between dtstart dtend)) + (ical:duration-between dtstart dtend)) all-props)) ;; Otherwise we make a normal DTEND: (push (ical:make-property ical:dtend dtend) @@ -3309,7 +3309,7 @@ recursive calls to this function made by vtimezone))) values))) (push (ical:make-property ical:rdate rdates - (ical:tzidparam tzid)) + (ical:tzidparam tzid)) all-props))) ;; preserve any other node read from date, e.g. RRULE, as is: @@ -3341,7 +3341,7 @@ recursive calls to this function made by (when url (push url all-props))) (push (or (di:parse-uid) (ical:make-property ical:uid - (ical:make-uid all-props))) + (ical:make-uid all-props))) all-props) ;; Allow users to add to the properties parsed: diff --git a/lisp/calendar/icalendar-ast.el b/lisp/calendar/icalendar-ast.el index a84e28d36c1..e9c289f16db 100644 --- a/lisp/calendar/icalendar-ast.el +++ b/lisp/calendar/icalendar-ast.el @@ -358,7 +358,7 @@ VALUE does not satisfy (any type in) TYPE." (signal 'wrong-type-argument (list `(list-of ,type) value))) (unless (cl-typep value type) (signal 'wrong-type-argument (list type value))) - (ical:make-ast-node type (list :value value)))) + (ical:make-ast-node type (list :value value)))) ((listp type) ;; N.B. nil is allowed; in that case, `ical:type-of' will check all ;; types in `ical:value-types': @@ -416,7 +416,7 @@ will return an `icalendar-deltoparam' node whose value is a list of The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." - (declare (debug (symbolp form form))) + (declare (debug (symbolp form))) ;; TODO: support `ical:otherparam' (unless (ical:param-type-symbol-p type) (error "Not an iCalendar param type: %s" type)) @@ -490,7 +490,7 @@ The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." ;; TODO: support `ical:other-property', maybe like ;; (ical:other-property "X-NAME" value ...) - (declare (debug (symbolp form form &rest form)) + (declare (debug (symbolp form &rest form)) (indent 2)) (unless (ical:property-type-symbol-p type) (error "Not an iCalendar property type: %s" type)) @@ -554,7 +554,7 @@ properties. The resulting syntax node is checked for validity by `icalendar-ast-node-valid-p' before it is returned." - (declare (debug (symbolp form &rest form)) + (declare (debug (symbolp &rest form)) (indent 1)) ;; TODO: support `ical:other-component', maybe like ;; (ical:other-component (:x-name "X-NAME") templates ...) @@ -662,7 +662,7 @@ For example, an iCalendar VEVENT could be written like this: Before the constructed node is returned, it is validated by `icalendar-ast-node-valid-p'." - (declare (debug (symbolp form &rest form)) + (declare (debug (symbolp &rest form)) (indent 1)) (cond ((not (ical:type-symbol-p type)) diff --git a/lisp/calendar/icalendar-macs.el b/lisp/calendar/icalendar-macs.el index 852b48012a7..d46eca978a0 100644 --- a/lisp/calendar/icalendar-macs.el +++ b/lisp/calendar/icalendar-macs.el @@ -830,7 +830,7 @@ Each binding in BINDINGS should be a list of one of the following forms: nodes), or the :value-nodes themselves (if they are not). It is a compile-time error to use the singular keywords with a TYPE that takes multiple values, or the plural keywords with a TYPE that does not." - (declare (debug (symbolp form form &rest form)) + (declare (debug (form form &rest form)) (indent 2)) ;; Static checks on the bindings prevent various annoying bugs: (dolist (b bindings) @@ -1004,7 +1004,7 @@ is equivalent to BINDINGS are passed on to `icalendar-with-node-children' and will be available in BODY; see its docstring for their form." - (declare (debug (symbolp form &optional form &rest form)) + (declare (debug (form &optional form &rest form)) (indent 2)) (let ((vn (gensym "icalendar-node")) (val (gensym "icalendar-value")) @@ -1069,7 +1069,7 @@ node's value. If PARAMETER's value is not a syntax node, then `value' is bound directly to PARAMETER's value, and `value-type' and `value-node' are bound to nil." - (declare (debug (symbolp form &rest form)) + (declare (debug (form &rest form)) (indent 1)) `(ical:with-node-value ,parameter nil ,@body)) @@ -1089,7 +1089,7 @@ is equivalent to (icalendar-with-child-of some-node some-type nil value) See `icalendar-with-node-children' for the form of BINDINGS." - (declare (debug (symbolp form form &optional form &rest form)) + (declare (debug (form form &optional form &rest form)) (indent 3)) (let ((child (gensym "icalendar-node"))) `(let ((,child (ical:ast-node-first-child-of ,type ,node))) @@ -1123,7 +1123,7 @@ symbol `value'; thus (icalendar-with-param-of some-property some-type) is equivalent to (icalendar-with-param-of some-property some-type nil value)" - (declare (debug (symbolp form form &rest form)) + (declare (debug (form form &rest form)) (indent 2)) `(ical:with-child-of ,node ,type nil ,@body)) diff --git a/lisp/calendar/icalendar-recur.el b/lisp/calendar/icalendar-recur.el index e3bee0923a9..391f3b91a92 100644 --- a/lisp/calendar/icalendar-recur.el +++ b/lisp/calendar/icalendar-recur.el @@ -2123,22 +2123,22 @@ to start the observances in the time zone. It defaults to 1970." :minute (mod dst-end-minutes 60) :second 0))) - (ical:make-vtimezone - (ical:tzid (or tzid (concat icr:-emacs-local-tzid std-name))) - (ical:make-standard - (ical:tzname std-name) - (ical:dtstart std-start) - (ical:rrule dst->std-rule) - (ical:tzoffsetfrom dst-offset) - (ical:tzoffsetto std-offset) - (ical:comment icr:-tz-warning)) - (ical:make-daylight - (ical:tzname dst-name) - (ical:dtstart dst-start) - (ical:rrule std->dst-rule) - (ical:tzoffsetfrom std-offset) - (ical:tzoffsetto dst-offset) - (ical:comment icr:-tz-warning))))))) + (ical:make-vtimezone + (ical:tzid (or tzid (concat icr:-emacs-local-tzid std-name))) + (ical:make-standard + (ical:tzname std-name) + (ical:dtstart std-start) + (ical:rrule dst->std-rule) + (ical:tzoffsetfrom dst-offset) + (ical:tzoffsetto std-offset) + (ical:comment icr:-tz-warning)) + (ical:make-daylight + (ical:tzname dst-name) + (ical:dtstart dst-start) + (ical:rrule std->dst-rule) + (ical:tzoffsetfrom std-offset) + (ical:tzoffsetto dst-offset) + (ical:comment icr:-tz-warning))))))) (provide 'icalendar-recur) From a234b9004887f1fb640d32a91d38c93d8133294c Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 16:13:31 +0100 Subject: [PATCH 062/191] ; Close package suggestion window after installing package * lisp/emacs-lisp/package.el (package--autosuggest-after-change-mode): Call 'quit-window' after installing package. --- lisp/emacs-lisp/package.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index f68bd4f7d55..e01d38c3c9c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4680,7 +4680,10 @@ Emacs can provide the editor support for these kinds of files:" nl) so you have to select which to install!)" nl)) (pcase-dolist ((and sug `(,pkg . ,_)) packages) - (insert nl "* " (buttonize "Install" #'package--autosuggest-install-and-enable sug) + (insert nl "* " (buttonize "Install" + (lambda (_) + (package--autosuggest-install-and-enable sug) + (quit-window))) " \"" (buttonize (symbol-name pkg) #'describe-package pkg) "\".") (add-to-list 'package--autosuggest-suggested pkg)) From 24f45c85ea0d9ac90e7be96712ac23b3e80bd1d3 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 16:14:24 +0100 Subject: [PATCH 063/191] Enable 'package-autosuggest-mode' by default * lisp/emacs-lisp/package.el (package-autosuggest-mode): Set :init-value. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index e01d38c3c9c..23a95c73416 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4548,7 +4548,7 @@ the existence of a suggestion." ;;;###autoload (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." - :global t + :global t :init-value t (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) From 2652e11930125b5b5e28f3f01e73b07eacb5ef75 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 1 Feb 2026 17:26:56 +0200 Subject: [PATCH 064/191] Minor improvements in vertical cusror motion * src/xdisp.c (move_it_vertically_backward): Zero out cached value of line height, to avoid using stale and incorrect values. (try_window_reusing_current_matrix): Fix conditions for changes in tab-line height. Reported by Michael Heerdegen in https://lists.gnu.org/archive/html/help-gnu-emacs/2026-01/msg00163.html This improves the scrolling a little bit, but doesn't solve the problem entirely. --- src/xdisp.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index fa826c366dd..22e178fcdc9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -11300,6 +11300,7 @@ move_it_vertically_backward (struct it *it, int dy) int line_height; RESTORE_IT (&it3, &it3, it3data); + last_height = 0; y1 = line_bottom_y (&it3); line_height = y1 - y0; RESTORE_IT (it, it, it2data); @@ -21673,8 +21674,9 @@ try_window_reusing_current_matrix (struct window *w) return false; /* If top-line visibility has changed, give up. */ - if (window_wants_tab_line (w) - != MATRIX_TAB_LINE_ROW (w->current_matrix)->mode_line_p) + if (!w->current_matrix->header_line_p + && (window_wants_tab_line (w) + != MATRIX_TAB_LINE_ROW (w->current_matrix)->mode_line_p)) return false; /* If top-line visibility has changed, give up. */ From 8f5badc26bc47b0964f299cdb81354aff3e952b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 1 Feb 2026 18:16:44 +0100 Subject: [PATCH 065/191] * etc/symbol-releases.eld: 'any' and 'all' added in Emacs 31 --- etc/symbol-releases.eld | 2 ++ 1 file changed, 2 insertions(+) diff --git a/etc/symbol-releases.eld b/etc/symbol-releases.eld index 3c666423cc0..225e7d86cff 100644 --- a/etc/symbol-releases.eld +++ b/etc/symbol-releases.eld @@ -9,6 +9,8 @@ ;; TYPE being `fun' or `var'. ( + ("31.1" fun any) + ("31.1" fun all) ("30.1" fun dired-click-to-select-mode) ("30.1" var dired-click-to-select-mode) ("29.1" fun plistp) From 9b1935dc2e600d47fff9250b052dd80cc658b34f Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 19:41:04 +0100 Subject: [PATCH 066/191] Explain why package suggestions match * lisp/emacs-lisp/package.el (package--autosugest-prompt): Go through all suggestions for the same package and mention why a package suggestion was relevant. --- lisp/emacs-lisp/package.el | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 23a95c73416..d587c8bbfd9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4679,12 +4679,25 @@ Emacs can provide the editor support for these kinds of files:" nl) (insert nl "(Note that there are multiple candidate packages, so you have to select which to install!)" nl)) - (pcase-dolist ((and sug `(,pkg . ,_)) packages) + (pcase-dolist (`(,pkg . ,sugs) (seq-group-by #'car packages)) (insert nl "* " (buttonize "Install" (lambda (_) - (package--autosuggest-install-and-enable sug) + (package--autosuggest-install-and-enable + (car sugs)) (quit-window))) - " \"" (buttonize (symbol-name pkg) #'describe-package pkg) "\".") + " \"" (buttonize (symbol-name pkg) #'describe-package pkg) "\" (") + (dolist (sug sugs) + (unless (eq (char-before) ?\() + (insert ", ")) + (pcase sug + (`(,_ auto-mode-alist . ,_) + (insert "matches file extension ")) + (`(,_ magic-mode-alist . ,_) + (insert "matches magic bytes")) + (`(,_ interpreter-mode-alist . ,_) + (insert "matches interpreter ")))) + (delete-horizontal-space) (insert ")") + (add-to-list 'package--autosuggest-suggested pkg)) (insert nl "* " (buttonize "Do not install anything" (lambda (_) (quit-window))) "." From 0054a5ff0cbb06fea6035a0eeab7bcc110c90767 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 19:43:26 +0100 Subject: [PATCH 067/191] Clarify that package suggestions have to be confirmed * lisp/emacs-lisp/package.el (package--autosugest-prompt): Adjust message to indicate that no changes have yet occurred. Co-Developed-By: Jens Schmidt --- lisp/emacs-lisp/package.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d587c8bbfd9..32294169d74 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4672,8 +4672,8 @@ if affirmative, otherwise nil" "The buffer \"" (buffer-name buf) "\" currently lacks any language-specific support. -The package manager has detected that by installing a third-party package, -Emacs can provide the editor support for these kinds of files:" nl) +The Emacs package manager can provide the editor support for these kinds +of files by installing a third-party package:" nl) (when (length> packages 1) (insert nl "(Note that there are multiple candidate packages, From 1b8eaed7231b2849ca310ce2c1f15100875517f0 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 19:44:06 +0100 Subject: [PATCH 068/191] ; Use right variable name in 'pcase' * lisp/emacs-lisp/package.el (package--suggestion-applies-p): Do not refer to the interpreter regexp as "magic". --- lisp/emacs-lisp/package.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 32294169d74..1f1b44f9531 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4584,15 +4584,15 @@ what command to invoke to enable the package." (save-excursion (goto-char (point-min)) (looking-at-p mag)))) - ((or `(,_ interpreter-mode-alist ,magic ,_) - `(,_ interpreter-mode-alist ,magic)) + ((or `(,_ interpreter-mode-alist ,intr ,_) + `(,_ interpreter-mode-alist ,intr)) (without-restriction (save-excursion (goto-char (point-min)) (and (looking-at auto-mode-interpreter-regexp) (string-match-p (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") - magic))))))) + intr))))))) (defun package--autosuggest-find-candidates () "Return a list of suggestions that might be interesting the current buffer. From 850382c7d6ec386cb5f42ea125b0458953322504 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 1 Feb 2026 20:58:17 +0100 Subject: [PATCH 069/191] Adjust formatting of package suggestion buffer * lisp/emacs-lisp/package.el (package--autosugest-prompt): Move 'describe-package' link into the parentheses after the "Install ..." button. --- lisp/emacs-lisp/package.el | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1f1b44f9531..c88f3b2c1c5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4680,23 +4680,25 @@ of files by installing a third-party package:" nl) so you have to select which to install!)" nl)) (pcase-dolist (`(,pkg . ,sugs) (seq-group-by #'car packages)) - (insert nl "* " (buttonize "Install" - (lambda (_) - (package--autosuggest-install-and-enable - (car sugs)) - (quit-window))) - " \"" (buttonize (symbol-name pkg) #'describe-package pkg) "\" (") + (insert nl "* " + (buttonize (concat "Install " (symbol-name pkg)) + (lambda (_) + (package--autosuggest-install-and-enable + (car sugs)) + (quit-window))) + " (" (buttonize "about" #'describe-package pkg) + ", matches ") (dolist (sug sugs) - (unless (eq (char-before) ?\() + (unless (eq (char-before) ?\s) (insert ", ")) (pcase sug (`(,_ auto-mode-alist . ,_) - (insert "matches file extension ")) + (insert "file extension ")) (`(,_ magic-mode-alist . ,_) - (insert "matches magic bytes")) + (insert "magic bytes")) (`(,_ interpreter-mode-alist . ,_) - (insert "matches interpreter ")))) - (delete-horizontal-space) (insert ")") + (insert "interpreter ")))) + (delete-horizontal-space) (insert ").") (add-to-list 'package--autosuggest-suggested pkg)) From 89bc088a8d2026decbfd5ca80fcd6406d93c72f2 Mon Sep 17 00:00:00 2001 From: Stephen Berman Date: Mon, 2 Feb 2026 00:27:03 +0100 Subject: [PATCH 070/191] ; Fix last change to iroquoian.el * lisp/leim/quail/iroquoian.el (iroquoian-haudenosaunee-exception-alist): Delete mistaken apostrophe in doc string. --- lisp/leim/quail/iroquoian.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/leim/quail/iroquoian.el b/lisp/leim/quail/iroquoian.el index 66aea7da38a..38b53f39483 100644 --- a/lisp/leim/quail/iroquoian.el +++ b/lisp/leim/quail/iroquoian.el @@ -1044,7 +1044,7 @@ Entries are as with rules in `quail-define-rules'.") (defconst iroquoian-haudenosaunee-exception-alist '(("_" ?\N{COMBINING LOW LINE}) ("__" ?_)) - "Rules' alist for phonological exception markers in Haudenosaunee input methods. + "Rules alist for phonological exception markers in Haudenosaunee input methods. Entries are as with rules in `quail-define-rules'.") (defconst iroquoian-haudenosaunee-nasal-alist iroquoian-onondaga-nasal-alist From a269bcb86beeb0d27c95aa4ff5bb3d22624c664a Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 2 Feb 2026 12:57:12 +0000 Subject: [PATCH 071/191] diff-mode-shared-map: Bind '@' to diff-revert-and-kill-hunk * lisp/vc/diff-mode.el (diff-mode-shared-map): Bind '@' to diff-revert-and-kill-hunk. --- lisp/vc/diff-mode.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 28e29cf36c5..2f0d949f108 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -221,11 +221,12 @@ See also `diff-mode-read-only-map'." "s" #'diff-split-hunk ;; The foregoing commands don't affect buffers beyond this one. - ;; The following command is the only one that has a single-letter + ;; The following command is the only one that has a single-character ;; binding and which affects buffers beyond this one. ;; However, the following command asks for confirmation by default, ;; so that seems okay. --spwhitton - "u" #'diff-revert-and-kill-hunk) + "u" #'diff-revert-and-kill-hunk + "@" #'diff-revert-and-kill-hunk) ;; Not `diff-read-only-mode-map' because there is no such mode ;; `diff-read-only-mode'; see comment above. From 16b10d76179747fc031911d567eb9253ab197e6e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 2 Feb 2026 15:24:21 +0200 Subject: [PATCH 072/191] ; Improve indexing in the ELisp manual * doc/lispref/functions.texi (Function Names): * doc/lispref/variables.texi (Tips for Defining): Improve indexing. --- doc/lispref/functions.texi | 1 + doc/lispref/variables.texi | 3 +++ 2 files changed, 4 insertions(+) diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index c64ec3ea715..5444cea7fa9 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -674,6 +674,7 @@ variable; these two uses of a symbol are independent and do not conflict. (This is not the case in some dialects of Lisp, like Scheme.) +@cindex internal functions, naming conventions By convention, if a function's symbol consists of two names separated by @samp{--}, the function is intended for internal use and the first part names the file defining the function. For example, a diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 2f5ee037f3e..e89b28eb0c0 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -617,6 +617,8 @@ float-pi @node Tips for Defining @section Tips for Defining Variables Robustly +@cindex variables, naming conventions +@cindex naming conventions, variables When you define a variable whose value is a function, or a list of functions, use a name that ends in @samp{-function} or @@ -659,6 +661,7 @@ The value is a whole shell command. @item @dots{}-switches The value specifies options for a command. +@cindex internal variables, naming conventions @item @var{prefix}--@dots{} The variable is intended for internal use and is defined in the file @file{@var{prefix}.el}. (Emacs code contributed before 2018 may From 53bc4a2cb6578c53f9ca4bf00fd7480d7c3fe5ba Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 2 Feb 2026 17:42:40 -0500 Subject: [PATCH 073/191] isearch.el: Remove autoloads hacks * lisp/isearch.el (char-fold-to-regexp): Remove redundant autoload. (emoji--read-emoji): Use `declare-function` rather than autoload. --- lisp/isearch.el | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lisp/isearch.el b/lisp/isearch.el index 5b5b2f0561a..b677e89c7cd 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -274,8 +274,6 @@ It is nil if none yet.") Default value, nil, means edit the string instead." :type 'boolean) -(autoload 'char-fold-to-regexp "char-fold") - (defcustom search-default-mode nil "Default mode to use when starting isearch. Value is nil, t, or a function. @@ -2827,7 +2825,6 @@ With argument, add COUNT copies of the character." (mapconcat 'isearch-text-char-description string "")))))))) -(autoload 'emoji--read-emoji "emoji") (defun isearch-emoji-by-name (&optional count) "Read an Emoji name and add it to the search string COUNT times. COUNT (interactively, the prefix argument) defaults to 1. @@ -2835,6 +2832,7 @@ The command accepts Unicode names like \"smiling face\" or \"heart with arrow\", and completion is available." (interactive "p") (emoji--init) + (declare-function emoji--read-emoji "emoji" ()) (with-isearch-suspended (pcase-let* ((`(,glyph . ,derived) (emoji--read-emoji)) (emoji (if derived From 083f89f85859add3d1ebfa41a4d77afd7692ae3b Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 3 Feb 2026 05:12:49 +0200 Subject: [PATCH 074/191] Fix [More] buttons in tutorial and other buttons in Semantic * lisp/help-mode.el (help-setup-xref): Update docstring (bug#80276). * etc/NEWS: Add description for the earlier change in help-setup-xref. * lisp/tutorial.el (tutorial--describe-nonstandard-key) (tutorial--detailed-help): Use 'with-help-window', call it after. * lisp/cedet/semantic/util.el (semantic-describe-buffer): Same. * lisp/cedet/semantic/decorate/include.el (semantic-decoration-include-describe) (semantic-decoration-unknown-include-describe) (semantic-decoration-fileless-include-describe) (semantic-decoration-unparsed-include-describe) (semantic-decoration-all-include-summary): Same. --- etc/NEWS | 6 + lisp/cedet/semantic/decorate/include.el | 32 ++- lisp/cedet/semantic/util.el | 7 +- lisp/help-mode.el | 10 +- lisp/tutorial.el | 272 ++++++++++++------------ 5 files changed, 166 insertions(+), 161 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 8929fcc1215..3a9d5ef6f8f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3690,6 +3690,12 @@ display time or even cause Emacs to hang trying to display such a face. Affected APIs include 'defface', 'set-face-attribute', their callers, and other similar functions. +** 'help-setup-xref' re-enables the major mode of the Help buffer. +As a result, in many cases the buffer will be read-only afterwards. +So now it is even more important that any calls to 'with-help-window' +(recommended) to 'with-output-to-temp-buffer' are done after. It was the +recommended way to use it previously as well, but less critically so. + * Lisp Changes in Emacs 31.1 diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index c91b04fb6a1..021c2d8fee9 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -352,9 +352,9 @@ Argument EVENT is the mouse clicked event." (file (semantic-dependency-tag-file tag)) (table (when file (semanticdb-file-table-object file t)))) - (with-output-to-temp-buffer (help-buffer) ; "*Help*" - (help-setup-xref (list #'semantic-decoration-include-describe) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'semantic-decoration-include-describe) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) ; "*Help*" (princ "Include File: ") (princ (semantic-format-tag-name tag nil t)) (princ "\n") @@ -451,9 +451,9 @@ Argument EVENT is the mouse clicked event." (interactive) (let ((tag (semantic-current-tag)) (mm major-mode)) - (with-output-to-temp-buffer (help-buffer) ; "*Help*" - (help-setup-xref (list #'semantic-decoration-unknown-include-describe) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'semantic-decoration-unknown-include-describe) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) ; "*Help*" (princ "Include File: ") (princ (semantic-format-tag-name tag nil t)) (princ "\n\n") @@ -534,9 +534,9 @@ Argument EVENT is the mouse clicked event." (let* ((tag (semantic-current-tag)) (table (semanticdb-find-table-for-include tag (current-buffer))) ) ;; (mm major-mode) - (with-output-to-temp-buffer (help-buffer) ; "*Help*" - (help-setup-xref (list #'semantic-decoration-fileless-include-describe) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'semantic-decoration-fileless-include-describe) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) ; "*Help*" (princ "Include Tag: ") (princ (semantic-format-tag-name tag nil t)) (princ "\n\n") @@ -573,10 +573,9 @@ Argument EVENT describes the event that caused this function to be called." Argument EVENT is the mouse clicked event." (interactive) (let ((tag (semantic-current-tag))) - (with-output-to-temp-buffer (help-buffer); "*Help*" - (help-setup-xref (list #'semantic-decoration-unparsed-include-describe) - (called-interactively-p 'interactive)) - + (help-setup-xref (list #'semantic-decoration-unparsed-include-describe) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer); "*Help*" (princ "Include File: ") (princ (semantic-format-tag-name tag nil t)) (princ "\n") @@ -654,10 +653,9 @@ Argument EVENT describes the event that caused this function to be called." (tags (semantic-fetch-tags)) (inc (semantic-find-tags-by-class 'include table)) ) - (with-output-to-temp-buffer (help-buffer) ;"*Help*" - (help-setup-xref (list #'semantic-decoration-all-include-summary) - (called-interactively-p 'interactive)) - + (help-setup-xref (list #'semantic-decoration-all-include-summary) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) ;"*Help*" (princ "Include Summary for File: ") (princ (file-truename (buffer-file-name))) (princ "\n") diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el index a1cd2cfde24..2ca8de839b5 100644 --- a/lisp/cedet/semantic/util.el +++ b/lisp/cedet/semantic/util.el @@ -271,10 +271,9 @@ If TAG is not specified, use the tag at point." (interactive) (let ((buff (current-buffer)) ) - - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'semantic-describe-buffer) - (called-interactively-p 'interactive)) + (help-setup-xref (list #'semantic-describe-buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) (with-current-buffer standard-output (princ "Semantic Configuration in ") (princ (buffer-name buff)) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index f15ae633edc..47fa3590177 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -501,9 +501,13 @@ buffer after following a reference. INTERACTIVE-P is non-nil if the calling command was invoked interactively. In this case the stack of items for help buffer \"back\" buttons is cleared. -This should be called very early, before the output buffer is cleared, -because we want to record the \"previous\" position of point so we can -restore it properly when going back." +This function also re-enables the major mode of the buffer, thus +resetting local variables to the values set by the mode and running the +mode hooks. + +So this should be called very early, before the output buffer is +cleared, also because we want to record the \"previous\" position of +point so we can restore it properly when going back." (with-current-buffer (help-buffer) ;; Re-enable major mode, killing all unrelated local vars. (funcall major-mode) diff --git a/lisp/tutorial.el b/lisp/tutorial.el index c071c1ff1d8..6ade473c975 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -69,18 +69,17 @@ Where WHERE is a text describing the key sequences to which DEF-FUN is bound now (or, if it is remapped, a key sequence for the function it is remapped to)" - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'tutorial--describe-nonstandard-key value) - (called-interactively-p 'interactive)) - (with-current-buffer (help-buffer) - (insert - "Your Emacs customizations override the default binding for this key:" - "\n\n") - (let ((inhibit-read-only t)) - (cond - ((eq (car value) 'cua-mode) - (insert - "CUA mode is enabled. + (help-setup-xref (list #'tutorial--describe-nonstandard-key value) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (insert + "Your Emacs customizations override the default binding for this key:" + "\n\n") + (let ((inhibit-read-only t)) + (cond + ((eq (car value) 'cua-mode) + (insert + "CUA mode is enabled. When CUA mode is enabled, you can use C-z, C-x, C-c, and C-v to undo, cut, copy, and paste in addition to the normal Emacs @@ -94,70 +93,70 @@ options: - press the prefix key twice very quickly (within 0.2 seconds), - press the prefix key and the following key within 0.2 seconds, or - use the SHIFT key with the prefix key, i.e. C-S-x or C-S-c.")) - ((eq (car value) 'current-binding) - (let ((cb (nth 1 value)) - (db (nth 2 value)) - (key (nth 3 value)) - (where (nth 4 value)) - map - (maps (current-active-maps)) - mapsym) - ;; Look at the currently active keymaps and try to find - ;; first the keymap where the current binding occurs: - (while maps - (let* ((m (car maps)) - (mb (lookup-key m key t))) - (setq maps (cdr maps)) - (when (eq mb cb) - (setq map m) - (setq maps nil)))) - ;; Now, if a keymap was found we must found the symbol - ;; name for it to display to the user. This can not - ;; always be found since all keymaps does not have a - ;; symbol pointing to them, but here they should have - ;; that: - (when map - (mapatoms (lambda (s) - (and - ;; If not already found - (not mapsym) - ;; and if s is a keymap - (and (boundp s) - (keymapp (symbol-value s))) - ;; and not the local symbol map - (not (eq s 'map)) - ;; and the value of s is map - (eq map (symbol-value s)) - ;; then save this value in mapsym - (setq mapsym s))))) - (insert - (format-message - "The default Emacs binding for the key %s is the command `%s'. " - (key-description key) - db)) - (insert "However, your customizations have " - (if cb - (format-message "rebound it to the command `%s'" cb) - "unbound it")) - (insert ".") - (when mapsym - (insert " (For the more advanced user:" - (format-message - " This binding is in the keymap `%s'.)" mapsym))) - (if (string= where "") - (unless (keymapp db) - (insert "\n\nYou can use M-x " - (format "%s" db) - " RET instead.")) - (insert "\n\nWith your current key bindings" - " you can use " - (if (string-match-p "^the .*menus?$" where) - "" - "the key ") - where - (format-message " to get the function `%s'." db)))) - (fill-region (point-min) (point))))) - (help-print-return-message)))) + ((eq (car value) 'current-binding) + (let ((cb (nth 1 value)) + (db (nth 2 value)) + (key (nth 3 value)) + (where (nth 4 value)) + map + (maps (current-active-maps)) + mapsym) + ;; Look at the currently active keymaps and try to find + ;; first the keymap where the current binding occurs: + (while maps + (let* ((m (car maps)) + (mb (lookup-key m key t))) + (setq maps (cdr maps)) + (when (eq mb cb) + (setq map m) + (setq maps nil)))) + ;; Now, if a keymap was found we must found the symbol + ;; name for it to display to the user. This can not + ;; always be found since all keymaps does not have a + ;; symbol pointing to them, but here they should have + ;; that: + (when map + (mapatoms (lambda (s) + (and + ;; If not already found + (not mapsym) + ;; and if s is a keymap + (and (boundp s) + (keymapp (symbol-value s))) + ;; and not the local symbol map + (not (eq s 'map)) + ;; and the value of s is map + (eq map (symbol-value s)) + ;; then save this value in mapsym + (setq mapsym s))))) + (insert + (format-message + "The default Emacs binding for the key %s is the command `%s'. " + (key-description key) + db)) + (insert "However, your customizations have " + (if cb + (format-message "rebound it to the command `%s'" cb) + "unbound it")) + (insert ".") + (when mapsym + (insert " (For the more advanced user:" + (format-message + " This binding is in the keymap `%s'.)" mapsym))) + (if (string= where "") + (unless (keymapp db) + (insert "\n\nYou can use M-x " + (format "%s" db) + " RET instead.")) + (insert "\n\nWith your current key bindings" + " you can use " + (if (string-match-p "^the .*menus?$" where) + "" + "the key ") + where + (format-message " to get the function `%s'." db)))) + (fill-region (point-min) (point))))) + (help-print-return-message))) (defconst tutorial--default-keys (eval-when-compile @@ -272,71 +271,70 @@ options: (defun tutorial--detailed-help (button) "Give detailed help about changed keys." - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'tutorial--detailed-help button) - (called-interactively-p 'interactive)) - (with-current-buffer (help-buffer) - (let* ((tutorial-buffer (button-get button 'tutorial-buffer)) - (explain-key-desc (button-get button 'explain-key-desc)) - (changed-keys (with-current-buffer tutorial-buffer - (save-excursion - (goto-char (point-min)) - (tutorial--find-changed-keys - tutorial--default-keys))))) - (when changed-keys - (insert - "The following key bindings used in the tutorial have been changed + (help-setup-xref (list #'tutorial--detailed-help button) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let* ((tutorial-buffer (button-get button 'tutorial-buffer)) + (explain-key-desc (button-get button 'explain-key-desc)) + (changed-keys (with-current-buffer tutorial-buffer + (save-excursion + (goto-char (point-min)) + (tutorial--find-changed-keys + tutorial--default-keys))))) + (when changed-keys + (insert + "The following key bindings used in the tutorial have been changed from the Emacs default:\n\n" ) - (let ((frm " %-14s %-27s %-16s\n")) - (insert (format frm - "Standard Key" "Command" "In Your Emacs"))) - (dolist (tk changed-keys) - (let* ((def-fun (nth 1 tk)) - (key (nth 0 tk)) - (def-fun-txt (nth 2 tk)) - (where (nth 3 tk)) - (remark (nth 4 tk)) - (key-txt (key-description key)) - (key-fun (with-current-buffer tutorial-buffer (key-binding key)))) - (unless (eq def-fun key-fun) - ;; Insert key binding description: - (when (string= key-txt explain-key-desc) - (put-text-property 0 (length key-txt) - 'face 'tutorial-warning-face key-txt)) - (insert " " key-txt " ") - (indent-to 18) - ;; Insert a link describing the old binding: - (insert-button def-fun-txt - 'value def-fun - 'action - (lambda (button) (interactive) - (describe-function - (button-get button 'value))) - 'follow-link t) - (indent-to 45) - (when (listp where) - (setq where "list")) - ;; Tell where the old binding is now: - (insert (format " %-16s " - (if (string= "" where) - (format "M-x %s" def-fun-txt) - where))) - ;; Insert a link with more information, for example - ;; current binding and keymap or information about - ;; cua-mode replacements: - (insert-button (car remark) - 'action - (lambda (b) (interactive) - (let ((value (button-get b 'value))) - (tutorial--describe-nonstandard-key value))) - 'value (cdr remark) - 'follow-link t) - (insert "\n"))))) + (let ((frm " %-14s %-27s %-16s\n")) + (insert (format frm + "Standard Key" "Command" "In Your Emacs"))) + (dolist (tk changed-keys) + (let* ((def-fun (nth 1 tk)) + (key (nth 0 tk)) + (def-fun-txt (nth 2 tk)) + (where (nth 3 tk)) + (remark (nth 4 tk)) + (key-txt (key-description key)) + (key-fun (with-current-buffer tutorial-buffer (key-binding key)))) + (unless (eq def-fun key-fun) + ;; Insert key binding description: + (when (string= key-txt explain-key-desc) + (put-text-property 0 (length key-txt) + 'face 'tutorial-warning-face key-txt)) + (insert " " key-txt " ") + (indent-to 18) + ;; Insert a link describing the old binding: + (insert-button def-fun-txt + 'value def-fun + 'action + (lambda (button) (interactive) + (describe-function + (button-get button 'value))) + 'follow-link t) + (indent-to 45) + (when (listp where) + (setq where "list")) + ;; Tell where the old binding is now: + (insert (format " %-16s " + (if (string= "" where) + (format "M-x %s" def-fun-txt) + where))) + ;; Insert a link with more information, for example + ;; current binding and keymap or information about + ;; cua-mode replacements: + (insert-button (car remark) + 'action + (lambda (b) (interactive) + (let ((value (button-get b 'value))) + (tutorial--describe-nonstandard-key value))) + 'value (cdr remark) + 'follow-link t) + (insert "\n"))))) - (insert " + (insert " It is OK to change key bindings, but changed bindings do not correspond to what the tutorial says.\n\n") - (help-print-return-message))))) + (help-print-return-message)))) (defun tutorial--find-changed-keys (default-keys) "Find the key bindings used in the tutorial that have changed. From 4ab81f82bf6cb5f2318cbdd27fca88f76aeae85a Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Tue, 3 Feb 2026 17:25:57 +0100 Subject: [PATCH 075/191] Do not compile database into package.el * lisp/emacs-lisp/package.el (package--autosuggest-database): Add new variable. (package--autosuggest-find-candidates): Load the contents of the database from 'data-directory' if necessary, and store them in the new variable. --- lisp/emacs-lisp/package.el | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c88f3b2c1c5..93c02b678e7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4594,18 +4594,27 @@ what command to invoke to enable the package." (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") intr))))))) +(defvar package--autosuggest-database 'unset + "A list of package suggestions. +Each entry in the list is of a form suitable to for +`package--suggestion-applies-p', which see. The special value `unset' +is used to indicate that `package--autosuggest-find-candidates' should +load the database into memory.") + (defun package--autosuggest-find-candidates () "Return a list of suggestions that might be interesting the current buffer. The elements of the returned list will have the form described in `package--suggestion-applies-p'." (and (eq major-mode 'fundamental-mode) (let ((suggetions '())) - (dolist (sug (eval-when-compile - (with-temp-buffer - (insert-file-contents - (expand-file-name "package-autosuggest.eld" - data-directory)) - (read (current-buffer))))) + (when (eq package--autosuggest-database 'unset) + (setq package--autosuggest-database + (with-temp-buffer + (insert-file-contents + (expand-file-name "package-autosuggest.eld" + data-directory)) + (read (current-buffer))))) + (dolist (sug package--autosuggest-database) (when (and (package--suggestion-applies-p sug) (if (eq package-autosuggest-style 'once) (not (memq (car sug) package--autosuggest-suggested)) From 6dc2336a4f2c49e5678ebf7ed7b7b4e5ad3ca565 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 4 Feb 2026 13:26:08 +0100 Subject: [PATCH 076/191] Make vc-git-tests work with git < 2.46 * test/lisp/vc/vc-git-tests.el (vc-git-test-branch-remotes): The 'unset' subcommand to 'git config' was introduced in git 2.46; use the '--unset' option instead. --- test/lisp/vc/vc-git-tests.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index 1552608071e..9721cc4d4ff 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -217,7 +217,7 @@ is absent." (should (assq 'upstream alist)) (should (equal (cdr (assq 'push alist)) (concat "fork/" main-branch)))) - (vc-git--out-ok "config" "unset" + (vc-git--out-ok "config" "--unset" (format "branch.%s.pushRemote" main-branch)) (vc-git--out-ok "config" "remote.pushDefault" "fork") (let ((alist (vc-git--branch-remotes))) From 1396b373ff7a947cd6e897a99cdcadd901a3ae03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 4 Feb 2026 14:33:36 +0100 Subject: [PATCH 077/191] ediff-mult-tests.el: remove temporary directory after test * test/lisp/vc/ediff-mult-tests.el (ediff-test-bug3348): Clean up. --- test/lisp/vc/ediff-mult-tests.el | 39 +++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/test/lisp/vc/ediff-mult-tests.el b/test/lisp/vc/ediff-mult-tests.el index e3514f77d2f..4d7f3f35859 100644 --- a/test/lisp/vc/ediff-mult-tests.el +++ b/test/lisp/vc/ediff-mult-tests.el @@ -27,28 +27,31 @@ (let ((test-dir (expand-file-name "bug-3348-testdir" temporary-file-directory))) (make-directory test-dir t) - (cd test-dir) + (unwind-protect + (progn + (cd test-dir) - (make-directory "dir-a" t) - (make-directory "dir-b" t) + (make-directory "dir-a" t) + (make-directory "dir-b" t) - (with-temp-file "dir-a/file" - (insert "aaa\n")) - (with-temp-file "dir-b/file" - (insert "bbb\n")) + (with-temp-file "dir-a/file" + (insert "aaa\n")) + (with-temp-file "dir-b/file" + (insert "bbb\n")) - (ediff-directories "dir-a" "dir-b" nil) - (switch-to-buffer "*Ediff Session Group Panel*") + (ediff-directories "dir-a" "dir-b" nil) + (switch-to-buffer "*Ediff Session Group Panel*") - (ediff-next-meta-item 1) - (ediff-mark-for-operation-at-pos nil) - (ediff-collect-custom-diffs) + (ediff-next-meta-item 1) + (ediff-mark-for-operation-at-pos nil) + (ediff-collect-custom-diffs) - (with-current-buffer "*Ediff Multifile Diffs*" - (write-file "foo.patch")) + (with-current-buffer "*Ediff Multifile Diffs*" + (write-file "foo.patch")) - (with-temp-file "dir-b/file" - (insert "BBB\n")) - (ediff-collect-custom-diffs) + (with-temp-file "dir-b/file" + (insert "BBB\n")) + (ediff-collect-custom-diffs) - (should-not (equal ediff-meta-diff-buffer (get-buffer "foo.patch"))))) + (should-not (equal ediff-meta-diff-buffer (get-buffer "foo.patch")))) + (delete-directory test-dir t)))) From f73cb8fba211bb47d7b992ef8a94f9987bdd31e0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 4 Feb 2026 10:59:23 -0500 Subject: [PATCH 078/191] shortdoc: Don't burp on missing docstrings * lisp/emacs-lisp/shortdoc.el (shortdoc--display-function): Report missing docstrings more cleanly than "Wrong type argument: stringp, nil". --- lisp/emacs-lisp/shortdoc.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 70583e08dbd..8b382bd14dd 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1707,7 +1707,9 @@ function's documentation in the Info manual")) ;; Doc string. (insert " " (or (plist-get data :doc) - (car (split-string (documentation function) "\n")))) + (car (split-string (or (documentation function) + "Error: missing docstring.") + "\n")))) (insert "\n") (add-face-text-property start-section (point) 'shortdoc-section t) (let ((print-escape-newlines t) From f38b0872f0a1f32404e3b0b07f56a208306d68b0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 4 Feb 2026 11:03:57 -0500 Subject: [PATCH 079/191] (yaml-ts-mode-yamllint-options): Use a list of strings It is both simpler to code and marginally more general (allows spaces in arguments). * lisp/textmodes/yaml-ts-mode.el (yaml-ts-mode-yamllint-options): Use a list. (yaml-ts-mode-flymake): Adjust accordingly. --- lisp/textmodes/yaml-ts-mode.el | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el index 948186b5a9a..c1521c82c22 100644 --- a/lisp/textmodes/yaml-ts-mode.el +++ b/lisp/textmodes/yaml-ts-mode.el @@ -48,12 +48,11 @@ (defcustom yaml-ts-mode-yamllint-options nil "Additional options to pass to yamllint command used for Flymake support. -If non-nil, this should be a single string with command-line options -for the yamllint command, with individual options separated by whitespace." +This should be a list of strings, each one passed as a separate argument +to the yamllint command." :group 'yaml-ts-mode :version "31.1" - :type '(choice (const :tag "None" nil) - (string :tag "Options as a single string"))) + :type '(repeat string)) (defvar yaml-ts-mode--syntax-table (let ((table (make-syntax-table))) @@ -199,10 +198,7 @@ Calls REPORT-FN directly." (when (process-live-p yaml-ts-mode--flymake-process) (kill-process yaml-ts-mode--flymake-process)) (let ((yamllint (executable-find "yamllint")) - (params (if yaml-ts-mode-yamllint-options - (append (split-string yaml-ts-mode-yamllint-options) '("-f" "parsable" "-")) - '("-f" "parsable" "-"))) - + (params (append yaml-ts-mode-yamllint-options '("-f" "parsable" "-"))) (source (current-buffer)) (diagnostics-pattern (eval-when-compile (rx bol (+? nonl) ":" ; every diagnostic line start with the filename From 3ea1010a6b0a63e90896133deaba189f13d47436 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 4 Feb 2026 11:14:10 -0500 Subject: [PATCH 080/191] * lisp/comint.el (comint-redirect-hook): Defvar (bug#80313) --- lisp/comint.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/comint.el b/lisp/comint.el index f4d484f037d..8d2692e50e6 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -3715,6 +3715,9 @@ last function is the text that is actually inserted in the redirection buffer. You can use `add-hook' to add functions to this list either globally or locally.") +(defvar comint-redirect-hook nil + "Normal hook run after completing a comint-redirect.") + ;; Internal variables (defvar comint-redirect-output-buffer nil From 0277fd791bca001254652d581172124c0c5f2f14 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 4 Feb 2026 17:36:32 +0100 Subject: [PATCH 081/191] Rephrase package suggestion message * lisp/emacs-lisp/package.el (package--autosugest-prompt): Follow Richard's suggestion from https://mail.gnu.org/archive/html/emacs-devel/2026-02/msg00040.html. --- lisp/emacs-lisp/package.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 93c02b678e7..bf7e08580f9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4681,8 +4681,8 @@ if affirmative, otherwise nil" "The buffer \"" (buffer-name buf) "\" currently lacks any language-specific support. -The Emacs package manager can provide the editor support for these kinds -of files by installing a third-party package:" nl) +The package manager can provide the editor support for these kinds of +files by downloading a package from Emacs's package archive:" nl) (when (length> packages 1) (insert nl "(Note that there are multiple candidate packages, From fd6d8faa62c56064c41a9709ab1010eecb8797f2 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Mon, 2 Feb 2026 16:04:04 -0800 Subject: [PATCH 082/191] Fix aligning buffer regions containing multiple alignment sections * lisp/align.el (align-region): Use markers to ensure the regions stay accurate after overlapping aligning modifications. (Bug#80316) * test/lisp/align-tests.el (align-c-multi-section): New test. --- lisp/align.el | 38 +++++++++++++++++++++++++------- test/lisp/align-tests.el | 47 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+), 8 deletions(-) diff --git a/lisp/align.el b/lisp/align.el index 1f1c8f58009..c2132da17ea 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -1407,11 +1407,18 @@ aligner would have dealt with are." (align-region beg end 'entire exclude-rules nil + ;; Use markers for exclusion area bounds so + ;; they remain accurate after subsequent + ;; alignment sections modify the buffer. (lambda (b e mode) (or (and mode (listp mode)) + (let ((bm (copy-marker b)) + (em (copy-marker e t))) + (push bm markers) + (push em markers) (setq exclude-areas - (cons (cons b e) - exclude-areas))))) + (cons (cons bm em) + exclude-areas)))))) (setq exclude-areas (nreverse (sort exclude-areas #'car-less-than-car)))) @@ -1458,12 +1465,15 @@ aligner would have dealt with are." (setq same nil) (align--set-marker eol (line-end-position))) - ;; remember the beginning position of this rule - ;; match, and save the match-data, since either - ;; the `valid' form, or the code that searches for - ;; section separation, might alter it - (setq rule-beg (match-beginning first) - save-match-data (match-data)) + ;; Remember the beginning position of this rule + ;; match as a marker so it remains accurate after + ;; `align-regions' modifies the buffer for a + ;; previous alignment section. Also save the + ;; match-data, since either the `valid' form, or + ;; the code that searches for section separation, + ;; might alter it. + (align--set-marker rule-beg (match-beginning first) t) + (setq save-match-data (match-data)) (or rule-beg (error "No match for subexpression %s" first)) @@ -1480,6 +1490,18 @@ aligner would have dealt with are." (when (and last-point (align-new-section-p last-point rule-beg thissep)) + ;; Convert saved match-data positions to + ;; markers before `align-regions' modifies + ;; the buffer, so the restored match-data + ;; reflects the updated buffer state. + (setq save-match-data + (mapcar (lambda (pos) + (if (integerp pos) + (let ((m (copy-marker pos))) + (push m markers) + m) + pos)) + save-match-data)) (align-regions regions align-props rule func) (setq regions nil) (setq align-props nil)) diff --git a/test/lisp/align-tests.el b/test/lisp/align-tests.el index 92605a7f4aa..43660f8de87 100644 --- a/test/lisp/align-tests.el +++ b/test/lisp/align-tests.el @@ -36,6 +36,53 @@ (ert-test-erts-file (ert-resource-file "c-mode.erts") (test-align-transform-fun #'c-mode))) +(ert-deftest align-c-multi-section () + "Test alignment of multiple sections in C code. +Regression test for bug where positions become stale after earlier +sections are aligned, causing incorrect alignment in later sections." + (let ((input "int main(void) +{ + long signed int foo = 5; + int bar = 7; + { + int a1 = 4; + int b1 = 2; + long signed int junk1 = 2; + } + { + int a2 = 4; /* comment */ + int b2 = 2; + long signed int junk2 = 2; /* another comment */ + } + + return 0; +} +") + (expected "int main(void) +{ + long signed int foo = 5; + int bar = 7; + { + int a1 = 4; + int b1 = 2; + long signed int junk1 = 2; + } + { + int a2 = 4; /* comment */ + int b2 = 2; + long signed int junk2 = 2; /* another comment */ + } + + return 0; +} +")) + (with-temp-buffer + (c-mode) + (setq indent-tabs-mode nil) + (insert input) + (align (point-min) (point-max)) + (should (equal (buffer-string) expected))))) + (ert-deftest align-css () (let ((indent-tabs-mode nil)) (ert-test-erts-file (ert-resource-file "css-mode.erts") From f660a5469c9f7f85ca0925f2a5727df88f529f46 Mon Sep 17 00:00:00 2001 From: Troy Brown Date: Wed, 4 Feb 2026 23:07:01 -0500 Subject: [PATCH 083/191] Fix last change in align.el * lisp/align.el (align-region): Additional fix of last change. (Bug#80316) Copyright-paperwork-exempt: yes --- lisp/align.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/align.el b/lisp/align.el index c2132da17ea..362d59f2231 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -1475,7 +1475,7 @@ aligner would have dealt with are." (align--set-marker rule-beg (match-beginning first) t) (setq save-match-data (match-data)) - (or rule-beg + (or (marker-position rule-beg) (error "No match for subexpression %s" first)) ;; unless the `valid' attribute is set, and tells From 8beb69b77ca68a4fca1848d268f29041418df021 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 5 Feb 2026 11:28:13 +0200 Subject: [PATCH 084/191] ; Fix cross references in "User Lisp Directory" * doc/emacs/custom.texi (User Lisp Directory): Fix wording, punctuation, and cross-references. (Bug#80321) --- doc/emacs/custom.texi | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index d79bcf3fe0f..b2fcb3c489f 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -3138,30 +3138,33 @@ elisp, The Emacs Lisp Reference Manual}. If the directory specified by @code{user-lisp-directory}, defaulting to @file{~/.config/emacs/user-lisp/} or @file{~/.emacs.d/user-lisp/}, exists, then at startup Emacs will prepare Lisp files within that -directory for use in the session. Emacs does the following things: +directory for use in the session. Specifically, Emacs does the +following: @itemize @item Gather and activate autoload cookies. This means that you can use autoloaded commands and other entry points for the files in your @code{user-lisp-directory} without explicitly loading any of the -files in your initialization file. (@pxref{Autoload,,, elisp, The -Emacs Lisp Reference Manual}.) +files in your initialization file. @xref{Autoload,,, elisp, The +Emacs Lisp Reference Manual}. @item -Byte-compile all files, and if supported on your system, natively -compile them too. This speeds up the execution of the code in the -files when they are loaded. (@pxref{Byte Compilation,,, elisp, The -Emacs Lisp Reference Manual}.) +Byte-compile all the files (@pxref{Byte Compilation,,, elisp, The Emacs +Lisp Reference Manual}), and if supported by your build of Emacs, +compile them to native code as well (@pxref{Native Compilation,,, elisp, +The Emacs Lisp Reference Manual}). This speeds up the execution of the +code in those files when they are loaded and when they are executed +later. @item Adjust @code{load-path} such that all the files can be loaded and -autoloaded in the usual ways. (@pxref{Library Search,,, elisp, The -Emacs Lisp Reference Manual}.) +autoloaded in the usual ways. @xref{Library Search,,, elisp, The +Emacs Lisp Reference Manual}. @end itemize - The User Lisp directory is processed before loading the @ref{Init -File} file. Therefore any customizations to the user options discussed -below must be made in your early init file (@pxref{Early Init File}) in -order to have any effect. + The User Lisp directory is processed before loading your init file +(@pxref{Init File}). Therefore any customizations to the user +options discussed below must be made in your early init file +(@pxref{Early Init File}) in order to have any effect. @vindex user-lisp-ignored-directories @vindex user-lisp-auto-scrape From 0dfaa756120f4feecf5f6011ec243741b071e440 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 5 Feb 2026 11:31:05 +0000 Subject: [PATCH 085/191] Bind "s" in diff-mode-read-only-map, not diff-mode-shared-map * lisp/vc/diff-mode.el (diff-mode-shared-map): Move binding for "s" from here ... (diff-mode-read-only-map): ... to here (bug#80330). --- lisp/vc/diff-mode.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 2f0d949f108..b4389de8a7b 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -201,8 +201,9 @@ The default \"-b\" means to ignore whitespace-only changes, (defvar-keymap diff-mode-shared-map :doc "Bindings for read-only `diff-mode' buffers. These bindings are also available with an ESC prefix -(i.e. a \\=`M-' prefix) in read-write `diff-mode' buffers, -and with a `diff-minor-mode-prefix' prefix in `diff-minor-mode'. +(i.e. a \\=`M-' prefix) in all `diff-mode' buffers, including in +particular read-write `diff-mode' buffers, and with a +`diff-minor-mode-prefix' prefix in `diff-minor-mode'. See also `diff-mode-read-only-map'." "n" #'diff-hunk-next "N" #'diff-file-next @@ -218,7 +219,6 @@ See also `diff-mode-read-only-map'." "" #'diff-goto-source "o" #'diff-goto-source ; other-window " " #'undo-ignore-read-only - "s" #'diff-split-hunk ;; The foregoing commands don't affect buffers beyond this one. ;; The following command is the only one that has a single-character @@ -235,15 +235,17 @@ See also `diff-mode-read-only-map'." :doc "Additional bindings for read-only `diff-mode' buffers. Most of the bindings for read-only `diff-mode' buffers are in `diff-mode-shared-map'. This map contains additional bindings for -read-only `diff-mode' buffers that are *not* available with an ESC -prefix (i.e. a \\=`M-' prefix) in read-write `diff-mode' buffers." +read-only `diff-mode' buffers that are *not* also available with an ESC +prefix (i.e. a \\=`M-' prefix) in read-write (nor read-only) `diff-mode' +buffers." ;; We don't want the following in read-write `diff-mode' buffers ;; because they hide useful `M-' global bindings when editing. "W" #'widen "w" #'diff-kill-ring-save "A" #'diff-ediff-patch "r" #'diff-restrict-view - "R" #'diff-reverse-direction) + "R" #'diff-reverse-direction + "s" #'diff-split-hunk) (defvar-keymap diff-mode-map :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'." From ccee1c0de6eb283482ab6fbcdff6043863edfa82 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 5 Feb 2026 11:46:01 +0000 Subject: [PATCH 086/191] ; Improve outgoing base command docstrings. --- lisp/vc/vc.el | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 14da03cda1d..3d85453a3b3 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3347,7 +3347,9 @@ Uncommitted changes are included in the diff. When unspecified, UPSTREAM-LOCATION is the outgoing base. For a trunk branch this is always the place \\[vc-push] would push to. -For a topic branch, query the backend for an appropriate outgoing base. +For a topic branch, see whether the branch matches one of +`vc-trunk-branch-regexps' or `vc-topic-branch-regexps', or else query +the backend for an appropriate outgoing base. See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding the difference between trunk and topic branches. @@ -3375,7 +3377,9 @@ Uncommitted changes are included in the diff. When unspecified, UPSTREAM-LOCATION is the outgoing base. For a trunk branch this is always the place \\[vc-push] would push to. -For a topic branch, query the backend for an appropriate outgoing base. +For a topic branch, see whether the branch matches one of +`vc-trunk-branch-regexps' or `vc-topic-branch-regexps', or else query +the backend for an appropriate outgoing base. See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding the difference between trunk and topic branches. @@ -3409,7 +3413,9 @@ working revision and UPSTREAM-LOCATION. When unspecified, UPSTREAM-LOCATION is the outgoing base. For a trunk branch this is always the place \\[vc-push] would push to. -For a topic branch, query the backend for an appropriate outgoing base. +For a topic branch, see whether the branch matches one of +`vc-trunk-branch-regexps' or `vc-topic-branch-regexps', or else query +the backend for an appropriate outgoing base. See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding the difference between trunk and topic branches. @@ -3441,7 +3447,9 @@ working revision and UPSTREAM-LOCATION. When unspecified, UPSTREAM-LOCATION is the outgoing base. For a trunk branch this is always the place \\[vc-push] would push to. -For a topic branch, query the backend for an appropriate outgoing base. +For a topic branch, see whether the branch matches one of +`vc-trunk-branch-regexps' or `vc-topic-branch-regexps', or else query +the backend for an appropriate outgoing base. See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding the difference between trunk and topic branches. From 10aa35bab7d624fed2b267fc48ebb05e839da57c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 5 Feb 2026 11:49:28 +0000 Subject: [PATCH 087/191] Bind "u", "@" in diff-mode-read-only-map, not diff-mode-shared-map * lisp/vc/diff-mode.el (diff-mode-shared-map): Move bindings for "u" and "@" from here ... (diff-mode-read-only-map): ... to here. --- lisp/vc/diff-mode.el | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index b4389de8a7b..0b6d2af517a 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -218,15 +218,7 @@ See also `diff-mode-read-only-map'." "RET" #'diff-goto-source "" #'diff-goto-source "o" #'diff-goto-source ; other-window - " " #'undo-ignore-read-only - - ;; The foregoing commands don't affect buffers beyond this one. - ;; The following command is the only one that has a single-character - ;; binding and which affects buffers beyond this one. - ;; However, the following command asks for confirmation by default, - ;; so that seems okay. --spwhitton - "u" #'diff-revert-and-kill-hunk - "@" #'diff-revert-and-kill-hunk) + " " #'undo-ignore-read-only) ;; Not `diff-read-only-mode-map' because there is no such mode ;; `diff-read-only-mode'; see comment above. @@ -245,7 +237,18 @@ buffers." "A" #'diff-ediff-patch "r" #'diff-restrict-view "R" #'diff-reverse-direction - "s" #'diff-split-hunk) + "s" #'diff-split-hunk + + ;; The foregoing commands in `diff-mode-shared-map' and + ;; `diff-mode-read-only-map' don't affect buffers beyond this one. + ;; The following command is the only one that has a single-character + ;; binding and which affects buffers beyond this one. However, the + ;; following command asks for confirmation by default, so that seems + ;; okay. --spwhitton + "u" #'diff-revert-and-kill-hunk + ;; `diff-revert-and-kill-hunk' is the `diff-mode' analogue of what '@' + ;; does in VC-Dir, so give it the same short binding. + "@" #'diff-revert-and-kill-hunk) (defvar-keymap diff-mode-map :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'." From dda572a2fad925d72fa19ee5724472d490d6cdb5 Mon Sep 17 00:00:00 2001 From: Protesilaos Stavrou Date: Sat, 10 Jan 2026 08:13:12 +0200 Subject: [PATCH 088/191] New minibuffer history for vc-user-edit-command (bug#80169) * lisp/vc/vc-dispatcher.el (vc-user-edit-command-history): New variable. (vc-user-edit-command): Use it (bug#80169). * etc/NEWS: Announce it. --- etc/NEWS | 5 +++++ lisp/vc/vc-dispatcher.el | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 3a9d5ef6f8f..9e5ac796697 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2885,6 +2885,11 @@ This command is Diff mode's specialized 'narrow-to-region'. consistency, 'diff-restrict-view' is now too. To enable it again, use 'M-x enable-command'. +--- +*** 'C-x v !' has its own input history. +This is shared with the input history of 'C-x v P' for certain backends +which use the same mechanism as 'C-x v !'. + ** Package +++ diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index dc17b582ed7..374ae778d55 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -384,6 +384,9 @@ the man pages for \"torsocks\" for more details about Tor." :version "27.1" :group 'vc) +(defvar vc-user-edit-command-history nil + "Minibuffer history for `vc-user-edit-command'.") + (defun vc-user-edit-command (command file-or-list flags) "Prompt the user to edit VC command COMMAND and FLAGS. Intended to be used as the value of `vc-filter-command-function'." @@ -398,7 +401,8 @@ Intended to be used as the value of `vc-filter-command-function'." (cons command (remq nil (if files-separator-p (butlast flags) flags)))) - " "))))) + " ") + 'vc-user-edit-command-history)))) (list (car edited) file-or-list (nconc (cdr edited) (and files-separator-p '("--")))))) From e2f9e6ba7dc9094d54ace1dc125f73c05b6abc5e Mon Sep 17 00:00:00 2001 From: Visuwesh Date: Thu, 5 Feb 2026 12:11:53 +0000 Subject: [PATCH 089/191] vc-git--mailinfo: Use file-local-name (bug#80295, bug#80320) * lisp/vc/vc-git.el (vc-git--mailinfo): Use file-local-name (bug#80295, bug#80320). --- lisp/vc/vc-git.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index d6a7145b34e..9c97fcad97d 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1472,7 +1472,9 @@ line of the commit message in an entry with key \"Subject\"." (if (eq system-type 'windows-nt) locale-coding-system coding-system-for-write))) - (vc-git--call input-file t "mailinfo" msg-file patch-file)) + (vc-git--call input-file t "mailinfo" + (file-local-name msg-file) + (file-local-name patch-file))) (goto-char (point-min)) ;; git-mailinfo joins up any header continuation lines for us. (while (re-search-forward "^\\([^\t\n\s:]+\\):\\(.*\\)$" nil t) From 3863449a0a62fd3d3e234c16f44c147637772af5 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 5 Feb 2026 12:18:54 +0000 Subject: [PATCH 090/191] ; * lisp/window.el (window--frame-landscape-p): Tweak wording. --- lisp/window.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/window.el b/lisp/window.el index 3a1ebd16fa6..2327ffcd5f2 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -7586,7 +7586,7 @@ strategy." (defun window--frame-landscape-p (&optional frame) "Non-nil if FRAME is wider than it is tall. -This means actually wider on the screen, not character-wise. +This means actually wider on the screen, not wider character-wise. On text frames, use the heuristic that characters are roughtly twice as tall as they are wide." (if (display-graphic-p frame) From a06cddec20d79b92a11172c201fa8cec54a28ffb Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Thu, 5 Feb 2026 12:24:05 +0000 Subject: [PATCH 091/191] ; diff--revert-kill-hunks: Hoist binding inhibit-read-only. --- lisp/vc/diff-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 0b6d2af517a..559310ff770 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2332,10 +2332,10 @@ If REVERTP is non-nil, reverse-apply hunks before killing them." (setq beg (copy-marker beg) end (point-marker)) (unwind-protect (cl-loop initially (goto-char beg) + with inhibit-read-only = t for (hunk-beg hunk-end) = (diff-bounds-of-hunk) for file-bounds = (ignore-errors (diff-bounds-of-file)) for (file-beg file-end) = file-bounds - for inhibit-read-only = t if (and file-bounds (progn (goto-char file-beg) From 893e0783c98528906001e4091230395006476489 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 5 Feb 2026 15:03:51 +0100 Subject: [PATCH 092/191] ; * lisp/subr.el (take-while): bytecode micro-optimisation --- lisp/subr.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index fcf03dd4f67..6f2dcb8c16d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1148,8 +1148,8 @@ side-effects, and the argument LIST is not modified." (make-symbol "f"))) (r (make-symbol "r"))) `(let (,@(and f `((,f ,pred))) - (,tail ,list) - (,r nil)) + (,r nil) + (,tail ,list)) (while (and ,tail (funcall ,(or f pred) (car ,tail))) (push (car ,tail) ,r) (setq ,tail (cdr ,tail))) From 4169720313cc9786f5b68c2ffdc94ae94e6293ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 5 Feb 2026 16:26:42 +0100 Subject: [PATCH 093/191] ; * test/lisp/vc/ediff-mult-tests.el: use ert-with-temp-directory Suggested by Pip Cet. --- test/lisp/vc/ediff-mult-tests.el | 44 +++++++++++++++----------------- 1 file changed, 20 insertions(+), 24 deletions(-) diff --git a/test/lisp/vc/ediff-mult-tests.el b/test/lisp/vc/ediff-mult-tests.el index 4d7f3f35859..7887ae086fe 100644 --- a/test/lisp/vc/ediff-mult-tests.el +++ b/test/lisp/vc/ediff-mult-tests.el @@ -20,38 +20,34 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ediff-mult) (ert-deftest ediff-test-bug3348 () "After saving `ediff-meta-diff-buffer' to a file, we should not reuse it." - (let ((test-dir - (expand-file-name "bug-3348-testdir" temporary-file-directory))) - (make-directory test-dir t) - (unwind-protect - (progn - (cd test-dir) + (ert-with-temp-directory test-dir + (cd test-dir) - (make-directory "dir-a" t) - (make-directory "dir-b" t) + (make-directory "dir-a" t) + (make-directory "dir-b" t) - (with-temp-file "dir-a/file" - (insert "aaa\n")) - (with-temp-file "dir-b/file" - (insert "bbb\n")) + (with-temp-file "dir-a/file" + (insert "aaa\n")) + (with-temp-file "dir-b/file" + (insert "bbb\n")) - (ediff-directories "dir-a" "dir-b" nil) - (switch-to-buffer "*Ediff Session Group Panel*") + (ediff-directories "dir-a" "dir-b" nil) + (switch-to-buffer "*Ediff Session Group Panel*") - (ediff-next-meta-item 1) - (ediff-mark-for-operation-at-pos nil) - (ediff-collect-custom-diffs) + (ediff-next-meta-item 1) + (ediff-mark-for-operation-at-pos nil) + (ediff-collect-custom-diffs) - (with-current-buffer "*Ediff Multifile Diffs*" - (write-file "foo.patch")) + (with-current-buffer "*Ediff Multifile Diffs*" + (write-file "foo.patch")) - (with-temp-file "dir-b/file" - (insert "BBB\n")) - (ediff-collect-custom-diffs) + (with-temp-file "dir-b/file" + (insert "BBB\n")) + (ediff-collect-custom-diffs) - (should-not (equal ediff-meta-diff-buffer (get-buffer "foo.patch")))) - (delete-directory test-dir t)))) + (should-not (equal ediff-meta-diff-buffer (get-buffer "foo.patch"))))) From ec5479f0b5a9622be9a0f7eb923c7ea738fe8b4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Thu, 5 Feb 2026 22:39:19 +0000 Subject: [PATCH 094/191] Eglot: fix thinko in eglot--async-request Just because a specific request of a specific "hint" is cancelled doesn't mean we can cancel the other's too. Also eglot-advertise-cancellation = nil was subtly broken. This manifested itself mostly in Eglot semantic tokens. * lisp/progmodes/eglot.el (eglot--async-request): Fix thinkos. --- lisp/progmodes/eglot.el | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 28ee14c67cb..89fbdec131f 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2030,21 +2030,25 @@ according to `eglot-advertise-cancellation'.") (timeout-fn nil timeout-fn-supplied-p) (timeout nil timeout-supplied-p) hint - &aux moreargs - id (buf (current-buffer))) + &aux moreargs id + (buf (current-buffer)) + (inflight eglot--inflight-async-requests)) "Like `jsonrpc-async-request', but for Eglot LSP requests. SUCCESS-FN, ERROR-FN and TIMEOUT-FN run in buffer of call site. HINT argument is a symbol passed as DEFERRED to `jsonrpc-async-request' and also used as a hint of the request cancellation mechanism (see `eglot-advertise-cancellation')." (cl-labels - ((clearing-fn (fn) + ((wrapfn (fn) (lambda (&rest args) (eglot--when-live-buffer buf - (when (and - fn (memq id (cl-getf eglot--inflight-async-requests hint))) - (apply fn args)) - (cl-remf eglot--inflight-async-requests hint))))) + (cond (eglot-advertise-cancellation + (when-let* ((tail (and fn (plist-member inflight hint)))) + (when (memq id (cadr tail)) + (apply fn args)) + (setf (cadr tail) (delete id (cadr tail))))) + (t + (apply fn args))))))) (eglot--cancel-inflight-async-requests (list hint)) (when timeout-supplied-p (setq moreargs (nconc `(:timeout ,timeout) moreargs))) @@ -2053,13 +2057,12 @@ and also used as a hint of the request cancellation mechanism (see (setq id (car (apply #'jsonrpc-async-request server method params - :success-fn (clearing-fn success-fn) - :error-fn (clearing-fn error-fn) - :timeout-fn (clearing-fn timeout-fn) + :success-fn (wrapfn success-fn) + :error-fn (wrapfn error-fn) + :timeout-fn (wrapfn timeout-fn) moreargs))) (when (and hint eglot-advertise-cancellation) - (push id - (plist-get eglot--inflight-async-requests hint))) + (push id (plist-get inflight hint))) id)) (cl-defun eglot--delete-overlays (&optional (prop 'eglot--overlays)) From 90d3fdaffcc9b13103d6a4fa0afa972ae214739c Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Fri, 6 Feb 2026 05:56:31 +0200 Subject: [PATCH 095/191] Allow using xref-find-references without visiting a tags table * lisp/progmodes/xref.el (xref-find-backend): Allow returning nil (bug#43086). (xref-backend-definitions, xref-backend-apropos): Signal user-error when no backend is available. The error text suggests a few built-in Xref backends. (xref-backend-identifier-completion-table): Default to nil. (xref--no-backend-available): New helper function. * lisp/progmodes/etags.el (etags--xref-backend): Return nil when no tags table is visited. --- etc/NEWS | 5 +++++ lisp/progmodes/etags.el | 4 +++- lisp/progmodes/xref.el | 23 ++++++++++++++--------- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 9e5ac796697..3795913d99c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3701,6 +3701,11 @@ So now it is even more important that any calls to 'with-help-window' (recommended) to 'with-output-to-temp-buffer' are done after. It was the recommended way to use it previously as well, but less critically so. +** Xref commands don't automatically suggest to visit a tags table anymore. +When no tags file is loaded, symbol completion just won't provide any +suggestions. So the 'M-?' command now works without a tags table. And +the 'M-.' will show a message describing the several built-in options +that will provide an Xref backend when used. * Lisp Changes in Emacs 31.1 diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 79cfb91caa9..aa83022fe47 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2115,7 +2115,9 @@ file name, add `tag-partial-file-name-match-p' to the list value.") :version "28.1") ;;;###autoload -(defun etags--xref-backend () 'etags) +(defun etags--xref-backend () + (when (or tags-table-list tags-file-name) + 'etags)) (cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'etags))) (find-tag--default)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 84a3fa4dfba..1e51b23eaff 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -247,11 +247,9 @@ generic functions.") ;;;###autoload (defun xref-find-backend () - (or - (run-hook-with-args-until-success 'xref-backend-functions) - (user-error "No Xref backend available"))) + (run-hook-with-args-until-success 'xref-backend-functions)) -(cl-defgeneric xref-backend-definitions (backend identifier) +(cl-defgeneric xref-backend-definitions (_backend _identifier) "Find definitions of IDENTIFIER. The result must be a list of xref objects. If IDENTIFIER @@ -264,7 +262,8 @@ IDENTIFIER can be any string returned by `xref-backend-identifier-at-point', or from the table returned by `xref-backend-identifier-completion-table'. -To create an xref object, call `xref-make'.") +To create an xref object, call `xref-make'." + (xref--no-backend-available)) (cl-defgeneric xref-backend-references (_backend identifier) "Find references of IDENTIFIER. @@ -285,12 +284,13 @@ The default implementation uses `xref-references-in-directory'." (xref--project-root pr) (project-external-roots pr)))))) -(cl-defgeneric xref-backend-apropos (backend pattern) +(cl-defgeneric xref-backend-apropos (_backend _pattern) "Find all symbols that match PATTERN string. The second argument has the same meaning as in `apropos'. If BACKEND is implemented in Lisp, it can use -`xref-apropos-regexp' to convert the pattern to regexp.") +`xref-apropos-regexp' to convert the pattern to regexp." + (xref--no-backend-available)) (cl-defgeneric xref-backend-identifier-at-point (_backend) "Return the relevant identifier at point. @@ -306,8 +306,9 @@ recognize and then delegate the work to an external process." (let ((thing (thing-at-point 'symbol))) (and thing (substring-no-properties thing)))) -(cl-defgeneric xref-backend-identifier-completion-table (backend) - "Return the completion table for identifiers.") +(cl-defgeneric xref-backend-identifier-completion-table (_backend) + "Return the completion table for identifiers." + nil) (cl-defgeneric xref-backend-identifier-completion-ignore-case (_backend) "Return t if case is not significant in identifier completion." @@ -329,6 +330,10 @@ KEY extracts the key from an element." (cl-loop for key being hash-keys of table using (hash-values value) collect (cons key (nreverse value))))) +(defun xref--no-backend-available () + (user-error + "No Xref backend. Try `M-x eglot', `M-x visit-tags-table', or `M-x etags-regen-mode'.")) + (defun xref--insert-propertized (props &rest strings) "Insert STRINGS with text properties PROPS." (let ((start (point))) From c6e550c24eb25a72cdef2d691649a3754feb75d8 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 6 Feb 2026 14:06:36 +0000 Subject: [PATCH 096/191] Separate input histories for 'C-x v !' and Git pulling & pushing * lisp/vc/vc-dispatcher.el (vc-user-edit-command-history): Use this as a dynamically bound variable, not a minibuffer history. (vc-user-edit-command): Pass its value to read-shell-command. * lisp/vc/vc-git.el (vc-git--pushpull): * lisp/vc/vc.el (vc-edit-next-command): Bind it. (vc-edit-next-command-history): New variable. * etc/NEWS: Document the change. --- etc/NEWS | 6 ++++-- lisp/vc/vc-dispatcher.el | 4 ++-- lisp/vc/vc-git.el | 4 +++- lisp/vc/vc.el | 6 +++++- 4 files changed, 14 insertions(+), 6 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 3795913d99c..6e8763a678d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2887,8 +2887,10 @@ To enable it again, use 'M-x enable-command'. --- *** 'C-x v !' has its own input history. -This is shared with the input history of 'C-x v P' for certain backends -which use the same mechanism as 'C-x v !'. + +--- +*** 'C-u C-x v +' and 'C-u C-x v P' for Git have an input history. +This was already in place for Mercurial. ** Package diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 374ae778d55..2015e7540ae 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -385,7 +385,7 @@ the man pages for \"torsocks\" for more details about Tor." :group 'vc) (defvar vc-user-edit-command-history nil - "Minibuffer history for `vc-user-edit-command'.") + "Name of minibuffer history variable for `vc-user-edit-command'.") (defun vc-user-edit-command (command file-or-list flags) "Prompt the user to edit VC command COMMAND and FLAGS. @@ -402,7 +402,7 @@ Intended to be used as the value of `vc-filter-command-function'." (butlast flags) flags)))) " ") - 'vc-user-edit-command-history)))) + vc-user-edit-command-history)))) (list (car edited) file-or-list (nconc (cdr edited) (and files-separator-p '("--")))))) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 9c97fcad97d..85e90bfc25a 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1614,7 +1614,9 @@ If PROMPT is non-nil, prompt for the Git command to run." (vc-filter-command-function (if prompt (lambda (&rest args) - (cl-destructuring-bind (&whole args git _ flags) + (cl-destructuring-bind + (&whole args git _ flags + &aux (vc-user-edit-command-history 'vc-git-history)) (apply #'vc-user-edit-command args) (setq git-program git command (car flags) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 3d85453a3b3..88324a2a444 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -5026,6 +5026,9 @@ log entries should be gathered." (defvar vc-filter-command-function) +(defvar vc-edit-next-command-history nil + "Minibuffer history for `vc-edit-next-command'.") + ;;;###autoload (defun vc-edit-next-command () "Request editing the next VC shell command before execution. @@ -5049,7 +5052,8 @@ immediately after this one." (add-hook 'prefix-command-echo-keystrokes-functions echofun) (setq vc-filter-command-function (lambda (&rest args) - (apply #'vc-user-edit-command (apply old args)))))) + (let ((vc-user-edit-command-history 'vc-edit-next-command-history)) + (apply #'vc-user-edit-command (apply old args))))))) ;; This is used in .dir-locals.el in the Emacs source tree. ;;;###autoload (put 'vc-prepare-patches-separately 'safe-local-variable 'booleanp) From 66d307aa0896acf7a74de6ec606f5c2997d24f2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Fri, 6 Feb 2026 17:07:06 +0100 Subject: [PATCH 097/191] ; * etc/NEWS (help-setup-xref): slight polish (bug#80276) --- etc/NEWS | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 6e8763a678d..a7d2a0b8004 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3697,11 +3697,12 @@ display time or even cause Emacs to hang trying to display such a face. Affected APIs include 'defface', 'set-face-attribute', their callers, and other similar functions. -** 'help-setup-xref' re-enables the major mode of the Help buffer. +--- +** 'help-setup-xref' now re-enables the major mode of the Help buffer. As a result, in many cases the buffer will be read-only afterwards. -So now it is even more important that any calls to 'with-help-window' -(recommended) to 'with-output-to-temp-buffer' are done after. It was the -recommended way to use it previously as well, but less critically so. +This should not cause any trouble as long as the actual buffer +modification takes place inside 'with-help-window' or +'with-output-to-temp-buffer' after the call to 'help-setup-xref'. ** Xref commands don't automatically suggest to visit a tags table anymore. When no tags file is loaded, symbol completion just won't provide any From ae673183625aa76fb5d7160730c92eda659b10ee Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 21:14:23 +0100 Subject: [PATCH 098/191] Enable 'package-autosuggest-mode' at startup * lisp/emacs-lisp/package.el (package-autosuggest-style) (package-autosuggest-mode, package--autosuggest-suggested) (package--suggestion-applies-p, package--autosuggest-database) (package--autosuggest-find-candidates) (package--autosugest-line-format, package-autosuggest-face) (package--autosuggest-after-change-mode, package-autosuggest): Remove definitions needed to recognise suggestions from here. * lisp/emacs-lisp/package-activate.el (package-autosuggest-style) (package--autosuggest-database, package--autosuggest-suggested) (package--suggestion-applies-p) (package--autosuggest-find-candidates) (package--autosugest-line-format, package-autosuggest) (package--autosuggest-after-change-mode) (package-autosuggest-mode): Move definitions from package.el. (package--activated, package-installed-p, package-get-version) (package-activate-all, package-activate-all): Remove unnecessary autoloads. * lisp/loadup.el: Load "package-activate.el". --- lisp/emacs-lisp/package-activate.el | 146 ++++++++++++++++++++++++-- lisp/emacs-lisp/package.el | 155 ++-------------------------- lisp/loadup.el | 1 + 3 files changed, 151 insertions(+), 151 deletions(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index e130304be5c..3d62c6f085e 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -209,7 +209,6 @@ loaded and/or activated, customize `package-load-list'.") ;;;; Public interfaces for accessing built-in package info -;;;###autoload (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") @@ -425,12 +424,9 @@ Newer versions are always activated, regardless of FORCE." ;;;; Unpacking -;;;###autoload (defvar package--activated nil "Non-nil if `package-activate-all' has been run.") -;;;###autoload -(progn ;; Make the function usable without loading `package.el'. (defun package-activate-all () "Activate all installed packages. The variable `package-load-list' controls which packages to load." @@ -459,7 +455,7 @@ The variable `package-load-list' controls which packages to load." ;; `declare-function' is currently not scoped, so if we use ;; it here, we end up with a redefinition warning instead :-) (with-no-warnings - (package--activate-all))))))) + (package--activate-all)))))) (defun package--activate-all () (dolist (elt (package--alist)) @@ -473,7 +469,6 @@ The variable `package-load-list' controls which packages to load." (declare-function lm-package-version "lisp-mnt" (&optional file)) -;;;###autoload (defun package-installed-p (package &optional min-version) "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. If PACKAGE is a symbol, it is the package name and MIN-VERSION @@ -503,7 +498,6 @@ If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." ;; Also check built-in packages. (package-built-in-p package min-version))))) -;;;###autoload (defun package-get-version () "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory @@ -534,5 +528,143 @@ the `Version:' header." (require 'lisp-mnt) (lm-package-version mainfile))))))) + +;;;; Package suggestions system + +;; Note that only the definitions necessary to recognise package +;; suggestions are defined here. The user interface to select and act +;; on package suggestions is to be found in package.el. + +(defcustom package-autosuggest-style 'mode-line + "How to draw attention to `package-autosuggest-mode' suggestions. +You can set this value to `mode-line' (default) to indicate the +availability of a package suggestion in the minor mode, `always' to +prompt the user in the minibuffer every time a suggestion is available +in a `fundamental-mode' buffer, `once' to do only prompt the user once +for each suggestion or `message' to just display a message hinting at +the existence of a suggestion." + :type '(choice (const :tag "Indicate in mode line" mode-line) + (const :tag "Always prompt" always) + (const :tag "Prompt only once" once) + (const :tag "Indicate with message" message)) + :group 'package) + +(defvar package--autosuggest-database 'unset + "A list of package suggestions. +Each entry in the list is of a form suitable to for +`package--suggestion-applies-p', which see. The special value `unset' +is used to indicate that `package--autosuggest-find-candidates' should +load the database into memory.") + +(defvar package--autosuggest-suggested '() + "List of packages that have already been suggested. +Suggestions found in this list will not count as suggestions (e.g. if +`package-autosuggest-style' is set to `mode-line', a suggestion found in +here will inhibit `package-autosuggest-mode' from displaying a hint in +the mode line).") + +(defun package--suggestion-applies-p (sug) + "Check if a suggestion SUG is applicable to the current buffer. +Each suggestion has the form (PACKAGE TYPE DATA), where PACKAGE is a +symbol denoting the package and major-mode the suggestion applies to, +TYPE is one of `auto-mode-alist', `magic-mode-alist' or +`interpreter-mode-alist' indicating the type of check to be made and +DATA is the value to check against TYPE in the intuitive way (e.g. for +`auto-mode-alist' DATA is a regular expression matching a file name that +PACKAGE should be suggested for). If the package name and the major +mode name differ, then an optional forth element MAJOR-MODE can indicate +what command to invoke to enable the package." + (pcase sug + ((or (guard (not (eq major-mode 'fundamental-mode))) + (guard (and (memq package-autosuggest-style '(once mode-line)) + (not (memq (car sug) package--autosuggest-suggested)))) + `(,(pred package-installed-p) . ,_)) + nil) + (`(,_ auto-mode-alist ,ext . ,_) + (and (string-match-p ext (buffer-name)) t)) + (`(,_ magic-mode-alist ,mag . ,_) + (without-restriction + (save-excursion + (goto-char (point-min)) + (looking-at-p mag)))) + (`(,_ interpreter-mode-alist ,intr . ,_) + (without-restriction + (save-excursion + (goto-char (point-min)) + (and (looking-at auto-mode-interpreter-regexp) + (string-match-p + (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") + intr))))))) + +(defun package--autosuggest-find-candidates () + "Return a list of suggestions that might be interesting the current buffer. +The elements of the returned list will have the form described in +`package--suggestion-applies-p'." + (and (eq major-mode 'fundamental-mode) + (let ((suggetions '())) + (when (eq package--autosuggest-database 'unset) + (setq package--autosuggest-database + (with-temp-buffer + (insert-file-contents + (expand-file-name "package-autosuggest.eld" + data-directory)) + (read (current-buffer))))) + (dolist (sug package--autosuggest-database) + (when (package--suggestion-applies-p sug) + (push sug suggetions))) + suggetions))) + +(defvar package--autosugest-line-format + '(:eval (package--autosugest-line-format))) +(put 'package--autosugest-line-format 'risky-local-variable t) + +(defun package--autosugest-line-format () + "Generate a mode-line string to indicate a suggested package." + `(,@(and-let* (((not (null package-autosuggest-mode))) + ((eq package-autosuggest-style 'mode-line)) + (avail (package--autosuggest-find-candidates))) + (propertize + (format " Install %s?" + (mapconcat + #'symbol-name + (delete-dups (mapcar #'car avail)) + ", ")) + 'face 'mode-line-emphasismode-line- + 'mouse-face 'mode-line-highlight + 'help-echo "Click to install suggested package." + 'keymap (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] #'package-autosuggest) + map))))) + +(declare-function package-autosuggest "package" (&optional candidates)) + +(defun package--autosuggest-after-change-mode () + "Display package suggestions for the current buffer. +This function should be added to `after-change-major-mode-hook'." + (when-let* ((avail (package--autosuggest-find-candidates)) + (pkgs (mapconcat #'symbol-name + (delete-dups (mapcar #'car avail)) + ", "))) + (pcase-exhaustive package-autosuggest-style + ('mode-line + (setq mode-name (append (ensure-list mode-name) + '((package-autosuggest-mode + package--autosugest-line-format)))) + (force-mode-line-update t)) + ((or 'once 'always) + (package-autosuggest avail)) + ('message + (message + (substitute-command-keys + (format "Found suggested packages: %s. Install using \\[package-autosuggest]" + pkgs))))))) + +(define-minor-mode package-autosuggest-mode + "Enable the automatic suggestion and installation of packages." + :global t :init-value t :group 'package + (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) + 'after-change-major-mode-hook + #'package--autosuggest-after-change-mode)) + (provide 'package-activate) ;;; package-activate.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index bf7e08580f9..94e1dc99b3f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4530,97 +4530,7 @@ The list is displayed in a buffer named `*Packages*'." (list-packages t)) -;;;; Autosuggest - -(defcustom package-autosuggest-style 'mode-line - "How to draw attention to `package-autosuggest-mode' suggestions. -You can set this value to `mode-line' (default) to indicate the -availability of a package suggestion in the minor mode, `always' to -prompt the user in the minibuffer every time a suggestion is available -in a `fundamental-mode' buffer, `once' to do only prompt the user once -for each suggestion or `message' to just display a message hinting at -the existence of a suggestion." - :type '(choice (const :tag "Indicate in mode line" mode-line) - (const :tag "Always prompt" always) - (const :tag "Prompt only once" once) - (const :tag "Indicate with message" message))) - -;;;###autoload -(define-minor-mode package-autosuggest-mode - "Enable the automatic suggestion and installation of packages." - :global t :init-value t - (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) - 'after-change-major-mode-hook - #'package--autosuggest-after-change-mode)) - -(defvar package--autosuggest-suggested '() - "List of packages that have already been suggested. -Suggestions found in this list will not count as suggestions (e.g. if -`package-autosuggest-style' is set to `mode-line', a suggestion found in -here will inhibit `package-autosuggest-mode' from displaying a hint in -the mode line).") - -(defun package--suggestion-applies-p (sug) - "Check if a suggestion SUG is applicable to the current buffer. -Each suggestion has the form (PACKAGE TYPE DATA), where PACKAGE is a -symbol denoting the package and major-mode the suggestion applies to, -TYPE is one of `auto-mode-alist', `magic-mode-alist' or -`interpreter-mode-alist' indicating the type of check to be made and -DATA is the value to check against TYPE in the intuitive way (e.g. for -`auto-mode-alist' DATA is a regular expression matching a file name that -PACKAGE should be suggested for). If the package name and the major -mode name differ, then an optional forth element MAJOR-MODE can indicate -what command to invoke to enable the package." - (pcase sug - ((or (guard (not (eq major-mode 'fundamental-mode))) - `(,(pred package-installed-p) . ,_)) - nil) - ((or `(,_ auto-mode-alist ,ext ,_) - `(,_ auto-mode-alist ,ext)) - (and (string-match-p ext (buffer-name)) t)) - ((or `(,_ magic-mode-alist ,mag ,_) - `(,_ magic-mode-alist ,mag)) - (without-restriction - (save-excursion - (goto-char (point-min)) - (looking-at-p mag)))) - ((or `(,_ interpreter-mode-alist ,intr ,_) - `(,_ interpreter-mode-alist ,intr)) - (without-restriction - (save-excursion - (goto-char (point-min)) - (and (looking-at auto-mode-interpreter-regexp) - (string-match-p - (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") - intr))))))) - -(defvar package--autosuggest-database 'unset - "A list of package suggestions. -Each entry in the list is of a form suitable to for -`package--suggestion-applies-p', which see. The special value `unset' -is used to indicate that `package--autosuggest-find-candidates' should -load the database into memory.") - -(defun package--autosuggest-find-candidates () - "Return a list of suggestions that might be interesting the current buffer. -The elements of the returned list will have the form described in -`package--suggestion-applies-p'." - (and (eq major-mode 'fundamental-mode) - (let ((suggetions '())) - (when (eq package--autosuggest-database 'unset) - (setq package--autosuggest-database - (with-temp-buffer - (insert-file-contents - (expand-file-name "package-autosuggest.eld" - data-directory)) - (read (current-buffer))))) - (dolist (sug package--autosuggest-database) - (when (and (package--suggestion-applies-p sug) - (if (eq package-autosuggest-style 'once) - (not (memq (car sug) package--autosuggest-suggested)) - t)) - (push sug suggetions))) - suggetions))) +;;;; Package Suggestions (defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. @@ -4638,33 +4548,6 @@ SUG should be of the form as described in `package--suggestion-applies-p'." (with-current-buffer buf (funcall-interactively (or (cadddr sug) (car sug))))))))) -(defvar package--autosugest-line-format - '(:eval (package--autosugest-line-format))) -(put 'package--autosugest-line-format 'risky-local-variable t) - -(defface package-autosuggest-face - '((t :inherit (success))) - "Face to use in the mode line to highlight suggested packages." - :version "30.1") - -(defun package--autosugest-line-format () - "Generate a mode-line string to indicate a suggested package." - `(,@(and-let* (((not (null package-autosuggest-mode))) - ((eq package-autosuggest-style 'mode-line)) - (avail (package--autosuggest-find-candidates))) - (propertize - (format " Install %s?" - (mapconcat - #'symbol-name - (delete-dups (mapcar #'car avail)) - ", ")) - 'face 'package-autosuggest-face - 'mouse-face 'mode-line-highlight - 'help-echo "Click to install suggested package." - 'keymap (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] #'package-autosuggest) - map))))) - (defun package--autosugest-prompt (packages) "Query the user whether to install PACKAGES or not. PACKAGES is a list of package suggestions in the form as described in @@ -4736,33 +4619,17 @@ so you have to select which to install!)" nl)) (set-window-dedicated-p win t) (set-window-point win (point-min)))))) -(defun package--autosuggest-after-change-mode () - "Display package suggestions for the current buffer. -This function should be added to `after-change-major-mode-hook'." - (when-let* ((avail (package--autosuggest-find-candidates)) - (pkgs (mapconcat #'symbol-name - (delete-dups (mapcar #'car avail)) - ", "))) - (pcase-exhaustive package-autosuggest-style - ('mode-line - (setq mode-name (append (ensure-list mode-name) - '((package-autosuggest-mode - package--autosugest-line-format)))) - (force-mode-line-update t)) - ((or 'once 'always) - (package--autosugest-prompt avail)) - ('message - (message - (substitute-command-keys - (format "Found suggested packages: %s. Install using \\[package-autosuggest]" - pkgs))))))) - -(defun package-autosuggest () - "Prompt the user to install the suggested packages." +;;;###autoload +(defun package-autosuggest (&optional candidates) + "Prompt the user to install the suggested packages. +The optional argument CANDIDATES may be a list of packages that match +for form described in `package--suggestion-applies-p'. If omitted, the +list of candidates will be computed from the database." (interactive) - (let ((avail (or (package--autosuggest-find-candidates) - (user-error "No package suggestions found")))) - (package--autosugest-prompt avail))) + (package--autosugest-prompt + (or candidates + (package--autosuggest-find-candidates) + (user-error "No package suggestions found")))) (defun package-reset-suggestions () "Forget previous package suggestions. diff --git a/lisp/loadup.el b/lisp/loadup.el index 665aeb4a595..24b54275778 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -383,6 +383,7 @@ (load "uniquify") (load "electric") (load "paren") +(load "emacs-lisp/package-activate") (load "emacs-lisp/shorthands") From 4a1e4a6edcaa0300d62f26126e212e8e273fd15d Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:15:06 +0100 Subject: [PATCH 099/191] ; * lisp/emacs-lisp/package-activate.el: Add note on preloading --- lisp/emacs-lisp/package-activate.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 3d62c6f085e..40456b54dee 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -30,6 +30,8 @@ ;; activate packages at startup, as well as other functions that are ;; useful without having to load the entirety of package.el. +;; Note that the contents of this file are preloaded! + ;;; Code: (eval-when-compile (require 'cl-lib)) From f64430fbadb655e43d818b1cbcd91bf56cbc0d5b Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:15:49 +0100 Subject: [PATCH 100/191] ; Fix typo * lisp/emacs-lisp/package-activate.el (package--autosugest-line-format): Use actually existing face symbol. --- lisp/emacs-lisp/package-activate.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 40456b54dee..6934ba91361 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -631,7 +631,7 @@ The elements of the returned list will have the form described in #'symbol-name (delete-dups (mapcar #'car avail)) ", ")) - 'face 'mode-line-emphasismode-line- + 'face 'mode-line-emphasis 'mouse-face 'mode-line-highlight 'help-echo "Click to install suggested package." 'keymap (let ((map (make-sparse-keymap))) From 5808909d1e31dc77b4dac358599ee9a0e1d3fbf7 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:24:09 +0100 Subject: [PATCH 101/191] ; Properly initialize 'package-autosuggest-mode' * lisp/emacs-lisp/package-activate.el (package-autosuggest-mode): Add :initialize property to minor mode definition as recommended in (elisp) Variable Definitions. --- lisp/emacs-lisp/package-activate.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 6934ba91361..f00831c9ba2 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -664,6 +664,7 @@ This function should be added to `after-change-major-mode-hook'." (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." :global t :init-value t :group 'package + :initialize #'custom-initialize-delay (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) From f561eed4d654345dba68d38bf47ab7637db536fb Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:31:30 +0100 Subject: [PATCH 102/191] Add separate user option to prevent repetitive package suggestions * lisp/emacs-lisp/package-activate.el (package-autosuggest-style): Remove option 'once' and defer to new user option. (package-autosuggest-once): Add new option. (package--suggestion-applies-p) (package--autosuggest-after-change-mode): Respect new user option. --- lisp/emacs-lisp/package-activate.el | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index f00831c9ba2..cc73860708d 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -542,15 +542,20 @@ the `Version:' header." You can set this value to `mode-line' (default) to indicate the availability of a package suggestion in the minor mode, `always' to prompt the user in the minibuffer every time a suggestion is available -in a `fundamental-mode' buffer, `once' to do only prompt the user once -for each suggestion or `message' to just display a message hinting at -the existence of a suggestion." +in a `fundamental-mode' buffer, or `message' to just display a message +hinting at the existence of a suggestion. If you only wish to be +reminded of package suggestions once every session, consider customizing +the `package-autosuggest-once' user option." :type '(choice (const :tag "Indicate in mode line" mode-line) (const :tag "Always prompt" always) - (const :tag "Prompt only once" once) (const :tag "Indicate with message" message)) :group 'package) +(defcustom package-autosuggest-once nil + "Non-nil means not to repeat package suggestions." + :type 'boolean + :group 'package) + (defvar package--autosuggest-database 'unset "A list of package suggestions. Each entry in the list is of a form suitable to for @@ -578,7 +583,7 @@ mode name differ, then an optional forth element MAJOR-MODE can indicate what command to invoke to enable the package." (pcase sug ((or (guard (not (eq major-mode 'fundamental-mode))) - (guard (and (memq package-autosuggest-style '(once mode-line)) + (guard (and package-autosuggest-once (not (memq (car sug) package--autosuggest-suggested)))) `(,(pred package-installed-p) . ,_)) nil) @@ -653,13 +658,15 @@ This function should be added to `after-change-major-mode-hook'." '((package-autosuggest-mode package--autosugest-line-format)))) (force-mode-line-update t)) - ((or 'once 'always) + ('always (package-autosuggest avail)) ('message (message (substitute-command-keys (format "Found suggested packages: %s. Install using \\[package-autosuggest]" - pkgs))))))) + pkgs))) + (dolist (rec avail) + (add-to-list 'package--autosuggest-suggested (car rec))))))) (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." From 6314c08c6b0aeed078061d1adb97ce80a7355964 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:36:29 +0100 Subject: [PATCH 103/191] Link to "Major Mode" node in manual when suggesting packges * lisp/emacs-lisp/package.el (package--autosugest-prompt): Add another button. --- lisp/emacs-lisp/package.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 94e1dc99b3f..1315cd6fbed 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4605,6 +4605,8 @@ so you have to select which to install!)" nl)) nlnl "To learn more about package management, read " (buttonize "(emacs) Packages" (lambda (_) (info "(emacs) Packages"))) + ", and to learn more about how Emacs supports specific languages, read " + (buttonize "(emacs) Major modes" (lambda (_) (info "(emacs) Major modes"))) ".") (fill-region (point-min) (point-max)) From bc413b3507c19a376af08808c4e00c3e5842d4b7 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Fri, 6 Feb 2026 22:50:49 +0100 Subject: [PATCH 104/191] Use 'buffer-file-name' when matching 'auto-mode-alist' * lisp/emacs-lisp/package-activate.el (package--suggestion-applies-p): The file name associated with a buffer is a better match for entries in 'auto-mode-alist', so we use that instead of the buffer name that can have additional noise to make the name unique. --- lisp/emacs-lisp/package-activate.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index cc73860708d..3965906f5d8 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -588,7 +588,7 @@ what command to invoke to enable the package." `(,(pred package-installed-p) . ,_)) nil) (`(,_ auto-mode-alist ,ext . ,_) - (and (string-match-p ext (buffer-name)) t)) + (and (buffer-file-name) (string-match-p ext (buffer-file-name)) t)) (`(,_ magic-mode-alist ,mag . ,_) (without-restriction (save-excursion From b37711a25f78a915a10245a6330c3b2b4434b2e5 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 7 Feb 2026 00:01:56 +0200 Subject: [PATCH 105/191] Some manual updates for the recent change * doc/emacs/maintaining.texi (Looking Up Identifiers): Mention that 'M-.' can signal an error. (Xref): Recommend using 'etags-regen-mode' (bug#43086). * etc/NEWS: Add updated marks. --- doc/emacs/maintaining.texi | 16 ++++++++++------ etc/NEWS | 1 + 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index aebe31b478e..aafa5395239 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2569,12 +2569,13 @@ files, and build a database of these references. A backend can then access this database whenever it needs to list or look up references. The Emacs distribution includes @command{etags}, a command for tagging identifier definitions in programs, which supports many programming -languages and other major modes, such as HTML, by extracting -references into @dfn{tags tables}. @xref{Create Tags Table}. Major -modes for languages supported by @command{etags} can use tags tables -as basis for their backend. (One disadvantage of this kind of backend -is that tags tables need to be kept reasonably up to date, by -rebuilding them from time to time.) +languages and other major modes, such as HTML, by extracting references +into @dfn{tags tables}. Major modes for languages supported by +@command{etags} can use tags tables as basis for their backend. Enable +@code{etags-regen-mode} to have tags generated across the current +project for supported file types and updated automatically on edit. Or +build the table manually to control the set of files and when it is +updated, see @xref{Create Tags Table}. @end enumerate @menu @@ -2648,6 +2649,9 @@ to always prompt, customize @code{xref-prompt-for-identifier} to usual minibuffer completion commands (@pxref{Completion}), with the known identifier names being the completion candidates. + It uses the current Xref backend, and will signal an error when there +is none configured, with some recommendations. + @kindex C-x 4 . @findex xref-find-definitions-other-window @kindex C-x 5 . diff --git a/etc/NEWS b/etc/NEWS index a7d2a0b8004..093e525fa81 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3704,6 +3704,7 @@ This should not cause any trouble as long as the actual buffer modification takes place inside 'with-help-window' or 'with-output-to-temp-buffer' after the call to 'help-setup-xref'. +--- ** Xref commands don't automatically suggest to visit a tags table anymore. When no tags file is loaded, symbol completion just won't provide any suggestions. So the 'M-?' command now works without a tags table. And From cc9fea52a3cd8d3e7c264cc54b724cf691b4d280 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 7 Feb 2026 02:06:52 +0200 Subject: [PATCH 106/191] etags--xref-backend: Move the definition to autoloads * lisp/progmodes/etags.el (etags--xref-backend): Move the definition to autoloads, so that etags.el doesn't have to be loaded before it really is used. --- lisp/progmodes/etags.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index aa83022fe47..f7532fce6b1 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2114,7 +2114,11 @@ file name, add `tag-partial-file-name-match-p' to the list value.") :type 'boolean :version "28.1") -;;;###autoload +;;;###autoload (defun etags--xref-backend () +;;;###autoload (when (or tags-table-list tags-file-name) +;;;###autoload (load "etags") +;;;###autoload 'etags)) + (defun etags--xref-backend () (when (or tags-table-list tags-file-name) 'etags)) From df517aa958b418ec1c1d714f8801b2b716ba4a40 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 7 Feb 2026 02:07:30 +0200 Subject: [PATCH 107/191] etags-regen--build-program-options: Expand the error message text * lisp/progmodes/etags-regen.el (etags-regen--build-program-options): Expand the error message text. --- lisp/progmodes/etags-regen.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/etags-regen.el b/lisp/progmodes/etags-regen.el index b6adca8af7a..3d3ddc0521f 100644 --- a/lisp/progmodes/etags-regen.el +++ b/lisp/progmodes/etags-regen.el @@ -348,7 +348,7 @@ File extensions to generate the tags for." (defun etags-regen--build-program-options (ctags-p) (when (and etags-regen-regexp-alist ctags-p) - (user-error "etags-regen-regexp-alist is not supported with Ctags")) + (user-error "etags-regen-regexp-alist not supported with Ctags; to use this option, customize `etags-regen-program'")) (nconc (mapcan (lambda (group) From cdc390d992246e3489b483835014030a7f5db43a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 7 Feb 2026 09:12:42 +0200 Subject: [PATCH 108/191] ; Improve documentation of 'etags-regen-mode' * doc/emacs/maintaining.texi (Xref, Tags Tables) (Create Tags Table, Select Tags Table): Improve documentation and cross-references for 'etags-regen-mode'. --- doc/emacs/maintaining.texi | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index aafa5395239..305487b4e6d 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2572,10 +2572,10 @@ identifier definitions in programs, which supports many programming languages and other major modes, such as HTML, by extracting references into @dfn{tags tables}. Major modes for languages supported by @command{etags} can use tags tables as basis for their backend. Enable -@code{etags-regen-mode} to have tags generated across the current -project for supported file types and updated automatically on edit. Or -build the table manually to control the set of files and when it is -updated, see @xref{Create Tags Table}. +@code{etags-regen-mode} to have tags tables generated across the current +project for supported file types and updated automatically upon edit. +Alternatively, you can build the table manually to control the set of +files and when it is updated, see @ref{Create Tags Table}. @end enumerate @menu @@ -3032,7 +3032,9 @@ writes the tags to a @dfn{tags table file}, or @dfn{tags file} in short. The conventional name for a tags file is @file{TAGS}@. @xref{Create Tags Table}. (It is also possible to create a tags table by using one of the commands from other packages that can produce such -tables in the same format.) +tables in the same format.) If you enable the @code{etags-regen-mode} +global minor mode, Emacs will generate and update the tags tables +automatically as needed. Emacs uses the tags tables via the @code{etags} package as one of the supported backends for @code{xref}. Because tags tables are @@ -3314,6 +3316,10 @@ You should update a tags table when you define new tags that you want to have listed, or when you move tag definitions from one file to another, or when changes become substantial. + If the @code{etags-regen-mode} minor mode, described below, is +enabled, Emacs will automatically keep the tags tables up-to-date as +needed. + You can make a tags table @dfn{include} another tags table, by passing the @samp{--include=@var{file}} option to @command{etags}. It then covers all the files covered by the included tags file, as well @@ -3422,11 +3428,11 @@ Command-line options to pass to the program which regenerates tags tables. @item etags-regen-ignores -List of glob patterns which specify files to ignore when regenerating -tags tables. +List of glob wildcard patterns which specify files to ignore when +regenerating tags tables. @end vtable -@cindex tags-reset-tags-tables +@findex tags-reset-tags-tables If you select a tags table manually, with @kbd{M-x visit-tags-table} (@pxref{Select Tags Table}), @code{etags-regen-mode} effectively disables itself: it will no longer automatically create and update @@ -3611,6 +3617,12 @@ to the first directory that contains a file named @file{TAGS} encountered when recursively searching upward from the default directory. + If you enable the @code{etags-regen-mode} global minor mode, it will +automatically find and visit the tags table file when needed. If you +then invoke @code{visit-tags-table} manually to select a tags table, +@code{etags-regen-mode} will disable automatic regeneration of the tags +table. @xref{Create Tags Table}. + @vindex tags-file-name Emacs does not actually read in the tags table contents until you try to use them; all @code{visit-tags-table} does is store the file From c31e7ef4d5a2164f6b3c60d79239659069c965c8 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sat, 7 Feb 2026 09:25:27 +0100 Subject: [PATCH 109/191] Revert "Enable 'package-autosuggest-mode' at startup" This reverts commit ae673183625aa76fb5d7160730c92eda659b10ee. --- lisp/emacs-lisp/package-activate.el | 9 +- lisp/emacs-lisp/package.el | 154 ++++++++++++++++++++++++++-- lisp/loadup.el | 1 - 3 files changed, 152 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 3965906f5d8..24d168c5d05 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -211,6 +211,7 @@ loaded and/or activated, customize `package-load-list'.") ;;;; Public interfaces for accessing built-in package info +;;;###autoload (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") @@ -426,9 +427,12 @@ Newer versions are always activated, regardless of FORCE." ;;;; Unpacking +;;;###autoload (defvar package--activated nil "Non-nil if `package-activate-all' has been run.") +;;;###autoload +(progn ;; Make the function usable without loading `package.el'. (defun package-activate-all () "Activate all installed packages. The variable `package-load-list' controls which packages to load." @@ -457,7 +461,7 @@ The variable `package-load-list' controls which packages to load." ;; `declare-function' is currently not scoped, so if we use ;; it here, we end up with a redefinition warning instead :-) (with-no-warnings - (package--activate-all)))))) + (package--activate-all))))))) (defun package--activate-all () (dolist (elt (package--alist)) @@ -471,6 +475,7 @@ The variable `package-load-list' controls which packages to load." (declare-function lm-package-version "lisp-mnt" (&optional file)) +;;;###autoload (defun package-installed-p (package &optional min-version) "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. If PACKAGE is a symbol, it is the package name and MIN-VERSION @@ -500,6 +505,7 @@ If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." ;; Also check built-in packages. (package-built-in-p package min-version))))) +;;;###autoload (defun package-get-version () "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory @@ -668,6 +674,7 @@ This function should be added to `after-change-major-mode-hook'." (dolist (rec avail) (add-to-list 'package--autosuggest-suggested (car rec))))))) +;;;###autoload (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." :global t :init-value t :group 'package diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1315cd6fbed..9b23655430d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4530,7 +4530,97 @@ The list is displayed in a buffer named `*Packages*'." (list-packages t)) -;;;; Package Suggestions +;;;; Autosuggest + +(defcustom package-autosuggest-style 'mode-line + "How to draw attention to `package-autosuggest-mode' suggestions. +You can set this value to `mode-line' (default) to indicate the +availability of a package suggestion in the minor mode, `always' to +prompt the user in the minibuffer every time a suggestion is available +in a `fundamental-mode' buffer, `once' to do only prompt the user once +for each suggestion or `message' to just display a message hinting at +the existence of a suggestion." + :type '(choice (const :tag "Indicate in mode line" mode-line) + (const :tag "Always prompt" always) + (const :tag "Prompt only once" once) + (const :tag "Indicate with message" message))) + +;;;###autoload +(define-minor-mode package-autosuggest-mode + "Enable the automatic suggestion and installation of packages." + :global t :init-value t + (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) + 'after-change-major-mode-hook + #'package--autosuggest-after-change-mode)) + +(defvar package--autosuggest-suggested '() + "List of packages that have already been suggested. +Suggestions found in this list will not count as suggestions (e.g. if +`package-autosuggest-style' is set to `mode-line', a suggestion found in +here will inhibit `package-autosuggest-mode' from displaying a hint in +the mode line).") + +(defun package--suggestion-applies-p (sug) + "Check if a suggestion SUG is applicable to the current buffer. +Each suggestion has the form (PACKAGE TYPE DATA), where PACKAGE is a +symbol denoting the package and major-mode the suggestion applies to, +TYPE is one of `auto-mode-alist', `magic-mode-alist' or +`interpreter-mode-alist' indicating the type of check to be made and +DATA is the value to check against TYPE in the intuitive way (e.g. for +`auto-mode-alist' DATA is a regular expression matching a file name that +PACKAGE should be suggested for). If the package name and the major +mode name differ, then an optional forth element MAJOR-MODE can indicate +what command to invoke to enable the package." + (pcase sug + ((or (guard (not (eq major-mode 'fundamental-mode))) + `(,(pred package-installed-p) . ,_)) + nil) + ((or `(,_ auto-mode-alist ,ext ,_) + `(,_ auto-mode-alist ,ext)) + (and (string-match-p ext (buffer-name)) t)) + ((or `(,_ magic-mode-alist ,mag ,_) + `(,_ magic-mode-alist ,mag)) + (without-restriction + (save-excursion + (goto-char (point-min)) + (looking-at-p mag)))) + ((or `(,_ interpreter-mode-alist ,intr ,_) + `(,_ interpreter-mode-alist ,intr)) + (without-restriction + (save-excursion + (goto-char (point-min)) + (and (looking-at auto-mode-interpreter-regexp) + (string-match-p + (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") + intr))))))) + +(defvar package--autosuggest-database 'unset + "A list of package suggestions. +Each entry in the list is of a form suitable to for +`package--suggestion-applies-p', which see. The special value `unset' +is used to indicate that `package--autosuggest-find-candidates' should +load the database into memory.") + +(defun package--autosuggest-find-candidates () + "Return a list of suggestions that might be interesting the current buffer. +The elements of the returned list will have the form described in +`package--suggestion-applies-p'." + (and (eq major-mode 'fundamental-mode) + (let ((suggetions '())) + (when (eq package--autosuggest-database 'unset) + (setq package--autosuggest-database + (with-temp-buffer + (insert-file-contents + (expand-file-name "package-autosuggest.eld" + data-directory)) + (read (current-buffer))))) + (dolist (sug package--autosuggest-database) + (when (and (package--suggestion-applies-p sug) + (if (eq package-autosuggest-style 'once) + (not (memq (car sug) package--autosuggest-suggested)) + t)) + (push sug suggetions))) + suggetions))) (defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. @@ -4548,6 +4638,33 @@ SUG should be of the form as described in `package--suggestion-applies-p'." (with-current-buffer buf (funcall-interactively (or (cadddr sug) (car sug))))))))) +(defvar package--autosugest-line-format + '(:eval (package--autosugest-line-format))) +(put 'package--autosugest-line-format 'risky-local-variable t) + +(defface package-autosuggest-face + '((t :inherit (success))) + "Face to use in the mode line to highlight suggested packages." + :version "30.1") + +(defun package--autosugest-line-format () + "Generate a mode-line string to indicate a suggested package." + `(,@(and-let* (((not (null package-autosuggest-mode))) + ((eq package-autosuggest-style 'mode-line)) + (avail (package--autosuggest-find-candidates))) + (propertize + (format " Install %s?" + (mapconcat + #'symbol-name + (delete-dups (mapcar #'car avail)) + ", ")) + 'face 'package-autosuggest-face + 'mouse-face 'mode-line-highlight + 'help-echo "Click to install suggested package." + 'keymap (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] #'package-autosuggest) + map))))) + (defun package--autosugest-prompt (packages) "Query the user whether to install PACKAGES or not. PACKAGES is a list of package suggestions in the form as described in @@ -4621,17 +4738,34 @@ so you have to select which to install!)" nl)) (set-window-dedicated-p win t) (set-window-point win (point-min)))))) +(defun package--autosuggest-after-change-mode () + "Display package suggestions for the current buffer. +This function should be added to `after-change-major-mode-hook'." + (when-let* ((avail (package--autosuggest-find-candidates)) + (pkgs (mapconcat #'symbol-name + (delete-dups (mapcar #'car avail)) + ", "))) + (pcase-exhaustive package-autosuggest-style + ('mode-line + (setq mode-name (append (ensure-list mode-name) + '((package-autosuggest-mode + package--autosugest-line-format)))) + (force-mode-line-update t)) + ((or 'once 'always) + (package--autosugest-prompt avail)) + ('message + (message + (substitute-command-keys + (format "Found suggested packages: %s. Install using \\[package-autosuggest]" + pkgs))))))) + ;;;###autoload -(defun package-autosuggest (&optional candidates) - "Prompt the user to install the suggested packages. -The optional argument CANDIDATES may be a list of packages that match -for form described in `package--suggestion-applies-p'. If omitted, the -list of candidates will be computed from the database." +(defun package-autosuggest () + "Prompt the user to install the suggested packages." (interactive) - (package--autosugest-prompt - (or candidates - (package--autosuggest-find-candidates) - (user-error "No package suggestions found")))) + (let ((avail (or (package--autosuggest-find-candidates) + (user-error "No package suggestions found")))) + (package--autosugest-prompt avail))) (defun package-reset-suggestions () "Forget previous package suggestions. diff --git a/lisp/loadup.el b/lisp/loadup.el index 24b54275778..665aeb4a595 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -383,7 +383,6 @@ (load "uniquify") (load "electric") (load "paren") -(load "emacs-lisp/package-activate") (load "emacs-lisp/shorthands") From e1524740bef6cee52e138a086e43988a16ed703e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 7 Feb 2026 11:45:00 +0200 Subject: [PATCH 110/191] ; Fix documentation of widget commands * doc/misc/widget.texi (Widgets and the Buffer): Fix the signatures of 'widget-forward' and 'widget-backward'. Reported by Tim Landscheidt . * lisp/wid-edit.el (widget-forward, widget-backward) (widget-move): Doc fixes. --- doc/misc/widget.texi | 14 ++++++++++---- lisp/wid-edit.el | 22 +++++++++++----------- 2 files changed, 21 insertions(+), 15 deletions(-) diff --git a/doc/misc/widget.texi b/doc/misc/widget.texi index 1cdeab5bbaa..b7ce3f7a262 100644 --- a/doc/misc/widget.texi +++ b/doc/misc/widget.texi @@ -785,13 +785,19 @@ The following navigation commands are available: @table @kbd @item @key{TAB} -@deffn Command widget-forward &optional count -Move point @var{count} buttons or editing fields forward. +@deffn Command widget-forward count &optional suppress-echo +Move point @var{count} buttons or editing fields forward. The optional +@var{suppress-echo} argument suppresses showing in the echo-area the +help-echo text, if any, for the final position after the move; it is +always @code{nil} in interactive invocations. @end deffn @item M-@key{TAB} @itemx S-@key{TAB} -@deffn Command widget-backward &optional count -Move point @var{count} buttons or editing fields backward. +@deffn Command widget-backward count &optional suppress-echo +Move point @var{count} buttons or editing fields backward. The optional +@var{suppress-echo} argument suppresses showing in the echo-area the +help-echo text, if any, for the final position after the move; it is +always @code{nil} in interactive invocations. @end deffn @end table diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 6d576a10b73..353d546fce4 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1334,10 +1334,10 @@ POS defaults to the value of (point). If user option This is much faster.") (defun widget-move (arg &optional suppress-echo) - "Move point to the ARG next field or button. + "Move point to the ARGth next field or button. ARG may be negative to move backward. -When the second optional argument is non-nil, -nothing is shown in the echo area." +If the optional argument SUPPRESS-ECHO is non-nil, suppress showing +in the echo area the help-echo, if any, for the final position." (let* ((wrapped 0) (number arg) (fwd (> arg 0)) ; widget-forward is caller. @@ -1384,19 +1384,19 @@ nothing is shown in the echo area." (run-hooks 'widget-move-hook)) (defun widget-forward (arg &optional suppress-echo) - "Move point to the next field or button. -With optional ARG, move across that many fields. -When the second optional argument is non-nil, -nothing is shown in the echo area." + "Move point forward across ARG fields or buttons. +Interactively, ARG is the prefix numeric argument and defaults to 1. +If the optional argument SUPPRESS-ECHO is non-nil, suppress showing +in the echo area the help-echo, if any, for the final position." (interactive "p") (run-hooks 'widget-forward-hook) (widget-move arg suppress-echo)) (defun widget-backward (arg &optional suppress-echo) - "Move point to the previous field or button. -With optional ARG, move across that many fields. -When the second optional argument is non-nil, -nothing is shown in the echo area." + "Move point back across ARG fields or buttons. +Interactively, ARG is the prefix numeric argument and defaults to 1. +If the optional argument SUPPRESS-ECHO is non-nil, suppress showing +in the echo area the help-echo, if any, for the final position." (interactive "p") (run-hooks 'widget-backward-hook) (widget-move (- arg) suppress-echo)) From 1aabe135e644a5f8703cd6d6eac0402b728c9cd3 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sat, 7 Feb 2026 11:02:19 +0100 Subject: [PATCH 111/191] ; Fix partial revert from c31e7ef4d5a * lisp/emacs-lisp/package.el (package-autosuggest-style) (package-autosuggest-mode, package--autosuggest-suggested) (package--suggestion-applies-p, package--autosuggest-database) (package--autosuggest-find-candidates) (package--autosugest-line-format, package-autosuggest-face) (package--autosuggest-after-change-mode, package-autosuggest): Remove definitions that were kept in package-activate.el. --- lisp/emacs-lisp/package.el | 154 +++---------------------------------- 1 file changed, 10 insertions(+), 144 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 9b23655430d..1315cd6fbed 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4530,97 +4530,7 @@ The list is displayed in a buffer named `*Packages*'." (list-packages t)) -;;;; Autosuggest - -(defcustom package-autosuggest-style 'mode-line - "How to draw attention to `package-autosuggest-mode' suggestions. -You can set this value to `mode-line' (default) to indicate the -availability of a package suggestion in the minor mode, `always' to -prompt the user in the minibuffer every time a suggestion is available -in a `fundamental-mode' buffer, `once' to do only prompt the user once -for each suggestion or `message' to just display a message hinting at -the existence of a suggestion." - :type '(choice (const :tag "Indicate in mode line" mode-line) - (const :tag "Always prompt" always) - (const :tag "Prompt only once" once) - (const :tag "Indicate with message" message))) - -;;;###autoload -(define-minor-mode package-autosuggest-mode - "Enable the automatic suggestion and installation of packages." - :global t :init-value t - (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) - 'after-change-major-mode-hook - #'package--autosuggest-after-change-mode)) - -(defvar package--autosuggest-suggested '() - "List of packages that have already been suggested. -Suggestions found in this list will not count as suggestions (e.g. if -`package-autosuggest-style' is set to `mode-line', a suggestion found in -here will inhibit `package-autosuggest-mode' from displaying a hint in -the mode line).") - -(defun package--suggestion-applies-p (sug) - "Check if a suggestion SUG is applicable to the current buffer. -Each suggestion has the form (PACKAGE TYPE DATA), where PACKAGE is a -symbol denoting the package and major-mode the suggestion applies to, -TYPE is one of `auto-mode-alist', `magic-mode-alist' or -`interpreter-mode-alist' indicating the type of check to be made and -DATA is the value to check against TYPE in the intuitive way (e.g. for -`auto-mode-alist' DATA is a regular expression matching a file name that -PACKAGE should be suggested for). If the package name and the major -mode name differ, then an optional forth element MAJOR-MODE can indicate -what command to invoke to enable the package." - (pcase sug - ((or (guard (not (eq major-mode 'fundamental-mode))) - `(,(pred package-installed-p) . ,_)) - nil) - ((or `(,_ auto-mode-alist ,ext ,_) - `(,_ auto-mode-alist ,ext)) - (and (string-match-p ext (buffer-name)) t)) - ((or `(,_ magic-mode-alist ,mag ,_) - `(,_ magic-mode-alist ,mag)) - (without-restriction - (save-excursion - (goto-char (point-min)) - (looking-at-p mag)))) - ((or `(,_ interpreter-mode-alist ,intr ,_) - `(,_ interpreter-mode-alist ,intr)) - (without-restriction - (save-excursion - (goto-char (point-min)) - (and (looking-at auto-mode-interpreter-regexp) - (string-match-p - (concat "\\`" (file-name-nondirectory (match-string 2)) "\\'") - intr))))))) - -(defvar package--autosuggest-database 'unset - "A list of package suggestions. -Each entry in the list is of a form suitable to for -`package--suggestion-applies-p', which see. The special value `unset' -is used to indicate that `package--autosuggest-find-candidates' should -load the database into memory.") - -(defun package--autosuggest-find-candidates () - "Return a list of suggestions that might be interesting the current buffer. -The elements of the returned list will have the form described in -`package--suggestion-applies-p'." - (and (eq major-mode 'fundamental-mode) - (let ((suggetions '())) - (when (eq package--autosuggest-database 'unset) - (setq package--autosuggest-database - (with-temp-buffer - (insert-file-contents - (expand-file-name "package-autosuggest.eld" - data-directory)) - (read (current-buffer))))) - (dolist (sug package--autosuggest-database) - (when (and (package--suggestion-applies-p sug) - (if (eq package-autosuggest-style 'once) - (not (memq (car sug) package--autosuggest-suggested)) - t)) - (push sug suggetions))) - suggetions))) +;;;; Package Suggestions (defun package--autosuggest-install-and-enable (sug) "Install and enable a package suggestion PKG-ENT. @@ -4638,33 +4548,6 @@ SUG should be of the form as described in `package--suggestion-applies-p'." (with-current-buffer buf (funcall-interactively (or (cadddr sug) (car sug))))))))) -(defvar package--autosugest-line-format - '(:eval (package--autosugest-line-format))) -(put 'package--autosugest-line-format 'risky-local-variable t) - -(defface package-autosuggest-face - '((t :inherit (success))) - "Face to use in the mode line to highlight suggested packages." - :version "30.1") - -(defun package--autosugest-line-format () - "Generate a mode-line string to indicate a suggested package." - `(,@(and-let* (((not (null package-autosuggest-mode))) - ((eq package-autosuggest-style 'mode-line)) - (avail (package--autosuggest-find-candidates))) - (propertize - (format " Install %s?" - (mapconcat - #'symbol-name - (delete-dups (mapcar #'car avail)) - ", ")) - 'face 'package-autosuggest-face - 'mouse-face 'mode-line-highlight - 'help-echo "Click to install suggested package." - 'keymap (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] #'package-autosuggest) - map))))) - (defun package--autosugest-prompt (packages) "Query the user whether to install PACKAGES or not. PACKAGES is a list of package suggestions in the form as described in @@ -4738,34 +4621,17 @@ so you have to select which to install!)" nl)) (set-window-dedicated-p win t) (set-window-point win (point-min)))))) -(defun package--autosuggest-after-change-mode () - "Display package suggestions for the current buffer. -This function should be added to `after-change-major-mode-hook'." - (when-let* ((avail (package--autosuggest-find-candidates)) - (pkgs (mapconcat #'symbol-name - (delete-dups (mapcar #'car avail)) - ", "))) - (pcase-exhaustive package-autosuggest-style - ('mode-line - (setq mode-name (append (ensure-list mode-name) - '((package-autosuggest-mode - package--autosugest-line-format)))) - (force-mode-line-update t)) - ((or 'once 'always) - (package--autosugest-prompt avail)) - ('message - (message - (substitute-command-keys - (format "Found suggested packages: %s. Install using \\[package-autosuggest]" - pkgs))))))) - ;;;###autoload -(defun package-autosuggest () - "Prompt the user to install the suggested packages." +(defun package-autosuggest (&optional candidates) + "Prompt the user to install the suggested packages. +The optional argument CANDIDATES may be a list of packages that match +for form described in `package--suggestion-applies-p'. If omitted, the +list of candidates will be computed from the database." (interactive) - (let ((avail (or (package--autosuggest-find-candidates) - (user-error "No package suggestions found")))) - (package--autosugest-prompt avail))) + (package--autosugest-prompt + (or candidates + (package--autosuggest-find-candidates) + (user-error "No package suggestions found")))) (defun package-reset-suggestions () "Forget previous package suggestions. From 89209a83b60c87d97f0c05dbf6cb29ff3cdf3d5a Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 7 Feb 2026 11:32:54 +0100 Subject: [PATCH 112/191] Support D-Bus file descriptor manipulation * doc/misc/dbus.texi (Synchronous Methods): Adapt `dbus-call-method'. (Asynchronous Methods): Adapt `dbus-call-method-asynchronously'. (File Descriptors): New chapter, replaces Inhibitor Locks. * etc/NEWS: Replace "New D-Bus functions to support systemd inhibitor locks" by "Support D-Bus file descriptor manipulation". Presentational fixes and improvements. * lisp/net/dbus.el (dbus-call-method) (dbus-call-method-asynchronously): Adapt docstring. (dbus-list-hash-table): Return (nreverse result). (dbus-monitor-goto-serial): Declare `completion'. * src/dbusbind.c (Fdbus_message_internal, xd_read_message_1): Handle `:keep-fd'. (xd_registered_inhibitor_locks, Fdbus_make_inhibitor_lock) (Fdbus_close_inhibitor_lock, Fdbus_registered_inhibitor_locks): Delete. (xd_registered_fds): New variable. (Fdbus__fd_open, Fdbus__fd_close, Fdbus__registered_fds): New DEFUNs. (Bug#79963) (syms_of_dbusbind_for_pdumper): Initialize `xd_registered_fds'. (syms_of_dbusbind): Remove subroutines `Sdbus_make_inhibitor_lock', `Sdbus_close_inhibitor_lock' and `Sdbus_registered_inhibitor_locks'. Remove symbol `Qdbus_call_method'. Declare subroutines `Sdbus__fd_open', `Sdbus__fd_close' and `Sdbus__registered_fds'. Declare symbol `QCkeep_fd'. staticpro `xd_registered_fds'. * test/lisp/net/dbus-tests.el (dbus-test10-inhibitor-locks): Delete. (dbus-test10-keep-fd, dbus-test10-open-close-fd): New tests. --- doc/misc/dbus.texi | 151 ++++++++++++++--------------- etc/NEWS | 24 ++--- lisp/net/dbus.el | 12 ++- src/dbusbind.c | 186 ++++++++++++++++++++---------------- test/lisp/net/dbus-tests.el | 165 ++++++++++++++++++++++---------- 5 files changed, 315 insertions(+), 223 deletions(-) diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 59685087ae8..5b302c883ad 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -64,7 +64,7 @@ another. An overview of D-Bus can be found at * Alternative Buses:: Alternative buses and environments. * Errors and Events:: Errors and events. * Monitoring Messages:: Monitoring messages. -* Inhibitor Locks:: Inhibit system shutdowns and sleep states. +* File Descriptors:: Handle file descriptors. * Index:: Index including concepts, functions, variables. * GNU Free Documentation License:: The license for this documentation. @@ -1212,7 +1212,7 @@ which carries the input parameters to the object owning the method to be called, and a reply message returning the resulting output parameters from the object. -@defun dbus-call-method bus service path interface method &optional :timeout timeout :authorizable auth &rest args +@defun dbus-call-method bus service path interface method &optional :timeout timeout :authorizable auth :keep-fd &rest args @anchor{dbus-call-method} This function calls @var{method} on the D-Bus @var{bus}. @var{bus} is either the keyword @code{:system} or the keyword @code{:session}. @@ -1245,6 +1245,11 @@ running): @result{} "/org/freedesktop/systemd1/job/17508" @end lisp +If the parameter @code{:keep-fd} is given, and the return message has a +first argument with a D-Bus type @code{:unix-fd}, the returned file +descriptor is kept internally, and can be used in a later call of +@code{dbus--close-fd} (@pxref{File Descriptors}). + The remaining arguments @var{args} are passed to @var{method} as arguments. They are converted into D-Bus types as described in @ref{Type Conversion}. @@ -1324,7 +1329,7 @@ emulate the @code{lshal} command on GNU/Linux systems: @cindex method calls, asynchronous @cindex asynchronous method calls -@defun dbus-call-method-asynchronously bus service path interface method handler &optional :timeout timeout :authorizable auth &rest args +@defun dbus-call-method-asynchronously bus service path interface method handler &optional :timeout timeout :authorizable auth :keep-fd &rest args This function calls @var{method} on the D-Bus @var{bus} asynchronously. @var{bus} is either the keyword @code{:system} or the keyword @code{:session}. @@ -1347,6 +1352,11 @@ If the parameter @code{:authorizable} is given and the following @var{auth} is non-@code{nil}, the invoked method may interactively prompt the user for authorization. The default is @code{nil}. +If the parameter @code{:keep-fd} is given, and the return message has a +first argument with a D-Bus type @code{:unix-fd}, the returned file +descriptor is kept internally, and can be used in a later call of +@code{dbus--close-fd} (@pxref{File Descriptors}). + The remaining arguments @var{args} are passed to @var{method} as arguments. They are converted into D-Bus types as described in @ref{Type Conversion}. @@ -2205,109 +2215,90 @@ switches to the monitor buffer. @end deffn -@node Inhibitor Locks -@chapter Inhibit system shutdowns and sleep states +@node File Descriptors +@chapter Handle file descriptors -@uref{https://systemd.io/INHIBITOR_LOCKS/, Systemd} includes a logic to -inhibit system shutdowns and sleep states. It can be controlled by a -D-Bus API@footnote{@uref{https://www.freedesktop.org/software/systemd/man/latest/org.freedesktop.login1.html}}. -Because this API includes handling of file descriptors, not all -functions can be implemented by simple D-Bus method calls. Therefore, -the following functions are provided. +Methods offered by the D-Bus API could return a file descriptor, which +must be handled further. This is indicated by the @code{:keep-fd} +parameter when calling the method (@pxref{dbus-call-method}). -@defun dbus-make-inhibitor-lock what why &optional block -This function creates an inhibitor for system shutdowns and sleep states. - -@var{what} is a colon-separated string of lock types: @samp{shutdown}, -@samp{sleep}, @samp{idle}, @samp{handle-power-key}, -@samp{handle-suspend-key}, @samp{handle-hibernate-key}, -@samp{handle-lid-switch}. Example: @samp{shutdown:idle}. - -@c@var{who} is a descriptive string of who is taking the lock. If it is -@c@code{nil}, it defaults to @samp{Emacs}. - -@var{why} is a descriptive string of why the lock is taken. Example: -@samp{Package Update in Progress}. - -The optional @var{block} is the mode of the inhibitor lock, either -@samp{block} (@var{block} is non-@code{nil}), or @samp{delay}. - -Note, that the @code{who} argument of the inhibitor lock object of the -systemd manager is always set to the string @samp{Emacs}. - -It returns a file descriptor or @code{nil}, if the lock cannot be -acquired. If there is already an inhibitor lock for the triple -@code{(WHAT WHY BLOCK)}, this lock is returned. Example: +For example, @uref{https://systemd.io/INHIBITOR_LOCKS/, Systemd} +includes a logic to inhibit system shutdowns and sleep states. It can +be controlled by a the method @samp{Inhibit} of interface +@samp{org.freedesktop.login1.Manager}@footnote{@uref{https://www.freedesktop.org/software/systemd/man/latest/org.freedesktop.login1.html}}. +This function returns a file descriptor, which must be used to unlock +the locked resource, some of which lock the system. In order to keep +this file descriptor internally, the respective D-Bus method call looks +like (@var{what}, @var{who}, @var{why} and @var{mode} are +method-specific string arguments) @lisp -(dbus-make-inhibitor-lock "sleep" "Test") +(dbus-call-method + :system + "org.freedesktop.login1" "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" "Inhibit" + :keep-fd WHAT WHO WHY MODE) @result{} 25 @end lisp -@end defun -@defun dbus-registered-inhibitor-locks -Return registered inhibitor locks, an alist. -This allows to check, whether other packages of the running Emacs -instance have acquired an inhibitor lock as well. +The inhibition lock is unlocked, when the returned file descriptor is +removed from the file system. This cannot be achieved on Lisp level. +Therefore, there is the function @code{dbus--fd-close} to performs this +task (see below). -An entry in this list is a list @code{(@var{fd} @var{what} @var{why} -@var{block})}. The car of the list is the file descriptor retrieved -from a @code{dbus-make-inhibitor-lock} call. The cdr of the list -represents the three arguments @code{dbus-make-inhibitor-lock} was -called with. Example: +@strong{Note}: When the Emacs process itself dies, all such locks are +released. + +@strong{Note}: The following functions are internal to the D-Bus +implementation of Emacs. Use them with care. + +@defun dbus--fd-open filename +Open @var{filename} and return the respective read-only file descriptor. +This is another function to keep a file descriptor internally. The +returned file descriptor can be closed by @code{dbus--fd-close}. +Example: @lisp -(dbus-registered-inhibitor-locks) +(dbus--fd-open "~/.emacs") -@result{} ((25 "sleep" "Test" nil)) +@result{} 20 @end lisp @end defun -@defun dbus-close-inhibitor-lock lock -Close inhibitor lock file descriptor. - -@var{lock}, a file descriptor, must be the result of a -@code{dbus-make-inhibitor-lock} call. It returns @code{t} in case of -success, or @code{nil} if it isn't be possible to close the lock, or if -the lock is closed already. Example: +@defun dbus--fd-close fd +Close file descriptor @var{fd}. +@var{fd} must be the result of a @code{dbus-call-method} or +@code{dbus--fd-open} call, see @code{dbus--registered-fds}. It returns +@code{t} in case of success, or @code{nil} if it isn’t be possible to +close the file descriptor, or if the file descriptor is closed already. +Example: @lisp -(dbus-close-inhibitor-lock 25) +(dbus--fd-close 25) @result{} t - @end lisp @end defun -A typical scenario for these functions is to register for the -D-Bus signal @samp{org.freedesktop.login1.Manager.PrepareForSleep}: +@defun dbus--registered-fds +Return registered file descriptors, an alist. +The key is an open file descriptor, retrieved via +@code{dbus-call-method} or @code{dbus--open-fd}. The value is a string +@var{object-path} or @var{filename}, which represents the arguments the +function was called with. Those values are not needed for further +operations; they are just shown for information. + +This alist allows to check, whether other packages of the running Emacs +instance have acquired a file descriptor as well. Example: @lisp -(defvar my-inhibitor-lock - (dbus-make-inhibitor-lock "sleep" "Test")) +(dbus--registered-fds) -(defun my-dbus-PrepareForSleep-handler (start) - (if start ;; The system goes down for sleep - (progn - @dots{} - ;; Release inhibitor lock. - (when (natnump my-inhibitor-lock) - (dbus-close-inhibitor-lock my-inhibitor-lock) - (setq my-inhibitor-lock nil))) - ;; Reacquire inhibitor lock. - (setq my-inhibitor-lock - (dbus-make-inhibitor-lock "sleep" "Test")))) - -(dbus-register-signal - :system "org.freedesktop.login1" "/org/freedesktop/login1" - "org.freedesktop.login1.Manager" "PrepareForSleep" - #'my-dbus-PrepareForSleep-handler) - -@result{} ((:signal :system "org.freedesktop.login1.Manager" "PrepareForSleep") - ("org.freedesktop.login1" "/org/freedesktop/login1" - my-dbus-PrepareForSleep-handler)) +@result{} ((20 . "/home/user/.emacs") + (25 . "/org/freedesktop/login1")) @end lisp +@end defun @node Index diff --git a/etc/NEWS b/etc/NEWS index 093e525fa81..1d6929f97e2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -84,9 +84,9 @@ other directory on your system. You can also invoke the +++ ** 'line-spacing' now supports specifying spacing above the line. -Previously, only spacing below the line could be specified. The variable -can now be set to a cons cell to specify spacing both above and below -the line, which allows for vertically centering text. +Previously, only spacing below the line could be specified. The user +option can now be set to a cons cell to specify spacing both above and +below the line, which allows for vertically centering text. +++ ** 'prettify-symbols-mode' attempts to ignore undisplayable characters. @@ -1410,7 +1410,7 @@ is non-nil, this suffix is fontified using 'font-lock-type-face'. --- *** New user option 'yaml-ts-mode-yamllint-options'. -Additional options for 'yamllint' the command used for Flymake's YAML +Additional options for 'yamllint', the command used for Flymake's YAML support. ** EIEIO @@ -2629,7 +2629,7 @@ When the argument is non-nil, the function switches to a buffer visiting the directory into which the repository was cloned. +++ -*** 'vc-revert' is now bound to '@' in VC-Dir. +*** 'vc-revert' is now bound to '@' in VC Directory. +++ *** 'vc-revert' is now additionally bound to 'C-x v @'. @@ -2771,7 +2771,7 @@ base with the remote branch, including uncommitted changes. ('vc-root-log-outgoing-base') show the corresponding revision logs. These are useful to view all outstanding (unmerged, unpushed) changes on the current branch. They are also available as 'T =', 'T D', 'T l' and -'T L' in VC-Dir buffers. +'T L' in VC Directory buffers. +++ *** New user option 'vc-use-incoming-outgoing-prefixes'. @@ -3858,11 +3858,13 @@ and 'dbus-call-method-asynchronously' to allow the user to interactively authorize the invoked D-Bus method (for example via polkit). +++ -*** New D-Bus functions to support systemd inhibitor locks. -The functions 'dbus-make-inhibitor-lock', 'dbus-close-inhibitor-lock' -and 'dbus-registered-inhibitor-locks' implement acquiring and releasing -systemd inhibitor locks. See the Info node "(dbus) Inhibitor Locks" for -details. +*** Support D-Bus file descriptor manipulation. +A new ':keep-fd' parameter has been added to 'dbus-call-method' and +'dbus-call-method-asynchronously' to instruct D-Bus to keep a file +descriptor, which has been returned by a method call, internally. The +functions 'dbus--fd-open', 'dbus--fd-close' and 'dbus--registered-fds' +implement managing these file descriptors. See the Info node "(dbus) +File Descriptors" for details. ** The customization group 'wp' has been removed. It has been obsolete since Emacs 26.1. Use the group 'text' instead. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 1c8f329fdd7..465de028725 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -319,6 +319,10 @@ If the parameter `:authorizable' is given and the following AUTH is non-nil, the invoked method may interactively prompt the user for authorization. The default is nil. +If the parameter `:keep-fd' is given, and the return message has a first +argument with a D-Bus type `:unix-fd', the returned file desriptor is +kept internally, and can be used in a later `dbus--close-fd' call. + All other arguments ARGS are passed to METHOD as arguments. They are converted into D-Bus types via the following rules: @@ -453,6 +457,10 @@ If the parameter `:authorizable' is given and the following AUTH is non-nil, the invoked method may interactively prompt the user for authorization. The default is nil. +If the parameter `:keep-fd' is given, and the return message has a first +argument with a D-Bus type `:unix-fd', the returned file desriptor is +kept internally, and can be used in a later `dbus--close-fd' call. + All other arguments ARGS are passed to METHOD as arguments. They are converted into D-Bus types via the following rules: @@ -604,6 +612,7 @@ This is an internal function, it shall not be used outside dbus.el." ;;; Hash table of registered functions. +;; Seems to be unused. Dow we want to keep it? (defun dbus-list-hash-table () "Return all registered member registrations to D-Bus. The return value is a list, with elements of kind (KEY . VALUE). @@ -613,7 +622,7 @@ hash table." (maphash (lambda (key value) (push (cons key value) result)) dbus-registered-objects-table) - result)) + (nreverse result))) (defun dbus-setenv (bus variable value) "Set the value of the BUS environment variable named VARIABLE to VALUE. @@ -2098,6 +2107,7 @@ either a method name, a signal name, or an error name." (defun dbus-monitor-goto-serial () "Goto D-Bus message with the same serial number." + (declare (completion ignore)) (interactive) (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) (when-let* ((point (get-text-property (point) 'dbus-serial))) diff --git a/src/dbusbind.c b/src/dbusbind.c index 3cf3ec9897e..98adebfb2d4 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -128,6 +128,8 @@ static bool xd_in_read_queued_messages = 0; #endif /* Check whether TYPE is a basic DBusType. */ +/* TODO: Shouldn't we assume, that recent D-Bus implementations carry + HAVE_DBUS_TYPE_IS_VALID and DBUS_TYPE_UNIX_FD? See configure.ac. */ #ifdef HAVE_DBUS_TYPE_IS_VALID #define XD_BASIC_DBUS_TYPE(type) \ (dbus_type_is_valid (type) && dbus_type_is_basic (type)) @@ -309,6 +311,8 @@ XD_OBJECT_TO_STRING (Lisp_Object object) } \ } while (0) +/* TODO: Shouldn't we assume, that recent D-Bus implementations carry + HAVE_DBUS_VALIDATE_*? See configure.ac. */ #if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH \ || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER) #define XD_DBUS_VALIDATE_OBJECT(object, func) \ @@ -1034,6 +1038,8 @@ xd_get_connection_address (Lisp_Object bus) } /* Return the file descriptor for WATCH, -1 if not found. */ +/* TODO: Shouldn't we assume, that recent D-Bus implementations carry + HAVE_DBUS_WATCH_GET_UNIX_FD? See configure.ac. */ static int xd_find_watch_fd (DBusWatch *watch) { @@ -1349,6 +1355,7 @@ usage: (dbus-message-internal &rest REST) */) dbus_uint32_t serial = 0; unsigned int ui_serial; int timeout = -1; + dbus_bool_t keepfd = FALSE; ptrdiff_t count, count0; char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; @@ -1525,6 +1532,7 @@ usage: (dbus-message-internal &rest REST) */) timeout = min (XFIXNAT (args[count+1]), INT_MAX); count = count + 2; } + /* Check for authorizable parameter. */ else if (EQ (args[count], QCauthorizable)) { @@ -1542,6 +1550,24 @@ usage: (dbus-message-internal &rest REST) */) count = count + 2; } + + /* Check for keepfd parameter. */ + else if (EQ (args[count], QCkeep_fd)) + { + if (mtype != DBUS_MESSAGE_TYPE_METHOD_CALL) + XD_SIGNAL1 + (build_string (":keep-fd is only supported on method calls")); + + /* Ignore this keyword if unsupported. */ +#ifdef DBUS_TYPE_UNIX_FD + keepfd = TRUE; +#else + XD_DEBUG_MESSAGE (":keep-fd not supported"); +#endif + + ++count; + } + else break; } @@ -1595,7 +1621,8 @@ usage: (dbus-message-internal &rest REST) */) result = list3 (QCserial, bus, INT_TO_INTEGER (serial)); /* Create a hash table entry. */ - Fputhash (result, handler, Vdbus_registered_objects_table); + Fputhash (result, keepfd ? Fcons (handler, path) : handler, + Vdbus_registered_objects_table); } else { @@ -1617,106 +1644,81 @@ usage: (dbus-message-internal &rest REST) */) return result; } -/* Alist of registered inhibitor locks for D-Bus. - An entry in this list is a list (FD WHAT WHY BLOCK). - The car of the list is a file descriptor retrieved from a - 'dbus-make-inhibitor-lock` call. The cdr of the list represents the - three arguments 'dbus-make-inhibitor-lock` was called with. */ -static Lisp_Object xd_registered_inhibitor_locks; +/* Alist of registered file descriptors for D-Bus. + The key is an open file descriptor, retrieved via `dbus-call-method' + or `dbus--open-fd'. The value is a string OBJECT-PATH or FILENAME, + which represents the arguments the function was called with. Those + values are not needed for further operations; they are just shown for + information. */ +static Lisp_Object xd_registered_fds; -DEFUN ("dbus-make-inhibitor-lock", Fdbus_make_inhibitor_lock, - Sdbus_make_inhibitor_lock, - 2, 3, 0, - doc: /* Inhibit system shutdowns and sleep states. - -WHAT is a colon-separated string of lock types, i.e. "shutdown", -"sleep", "idle", "handle-power-key", "handle-suspend-key", -"handle-hibernate-key", "handle-lid-switch". Example: "shutdown:idle". - -WHY is a descriptive string of why the lock is taken. Example: "Package -Update in Progress". - -The optional BLOCK is the mode of the inhibitor lock, either "block" -(BLOCK is non-nil), or "delay". - -It returns a file descriptor or nil, if the lock cannot be acquired. If -there is already an inhibitor lock for the triple (WHAT WHY BLOCK), this -lock is returned. - -For details of the arguments, see Info node `(dbus)Inhibitor Locks'. */) - (Lisp_Object what, Lisp_Object why, Lisp_Object block) +DEFUN ("dbus--fd-open", Fdbus__fd_open, Sdbus__fd_open, 1, 1, 0, + doc: /* Open FILENAME and return the respective read-only file descriptor. */) + (Lisp_Object filename) { - CHECK_STRING (what); - CHECK_STRING (why); - if (!NILP (block)) - block = Qt; - Lisp_Object who = build_string ("Emacs"); - Lisp_Object mode = - (NILP (block)) ? build_string ("delay") : build_string ("block"); + CHECK_STRING (filename); + filename = Fexpand_file_name (filename, Qnil); + filename = ENCODE_FILE (filename); /* Check, whether it is registered already. */ - Lisp_Object triple = list3 (what, why, block); - Lisp_Object registered = Frassoc (triple, xd_registered_inhibitor_locks); + Lisp_Object registered = Frassoc (filename, xd_registered_fds); if (!NILP (registered)) return CAR_SAFE (registered); - /* Register lock. */ - Lisp_Object lock = - calln (Qdbus_call_method, QCsystem, - build_string ("org.freedesktop.login1"), - build_string ("/org/freedesktop/login1"), - build_string ("org.freedesktop.login1.Manager"), - build_string ("Inhibit"), what, who, why, mode); + /* Open file descriptor. */ + int fd = emacs_open (SSDATA (filename), O_RDONLY, 0); - xd_registered_inhibitor_locks = - Fcons (Fcons (lock, triple), xd_registered_inhibitor_locks); - return lock; + if (fd <= 0) + XD_SIGNAL2 (build_string ("Cannot open file"), filename); + + /* Register file descriptor. */ + xd_registered_fds = + Fcons (Fcons (INT_TO_INTEGER (fd), filename), xd_registered_fds); + return INT_TO_INTEGER (fd); } -DEFUN ("dbus-close-inhibitor-lock", Fdbus_close_inhibitor_lock, - Sdbus_close_inhibitor_lock, - 1, 1, 0, - doc: /* Close inhibitor lock file descriptor. - -LOCK, a file descriptor, must be the result of a `dbus-make-inhibitor-lock' -call. It returns t in case of success, or nil if it isn't be possible -to close the lock, or if the lock is closed already. - -For details, see Info node `(dbus)Inhibitor Locks'. */) - (Lisp_Object lock) +DEFUN ("dbus--fd-close", Fdbus__fd_close, Sdbus__fd_close, 1, 1, 0, + doc: /* Close file descriptor FD. +FD must be the result of a `dbus-call-method' or `dbus--fd-open' call, +see `dbus--registered-fds'. It returns t in case of success, or nil if +it isn't be possible to close the file descriptor, or if the file +descriptor is closed already. */) + (Lisp_Object fd) { - CHECK_FIXNUM (lock); + CHECK_FIXNUM (fd); /* Check, whether it is registered. */ - Lisp_Object registered = assoc_no_quit (lock, xd_registered_inhibitor_locks); + Lisp_Object registered = assoc_no_quit (fd, xd_registered_fds); if (NILP (registered)) return Qnil; else { - xd_registered_inhibitor_locks = - Fdelete (registered, xd_registered_inhibitor_locks); - return (emacs_close (XFIXNAT (lock)) == 0) ? Qt : Qnil; + xd_registered_fds = Fdelete (registered, xd_registered_fds); + return (emacs_close (XFIXNAT (fd)) == 0) ? Qt : Qnil; } } -DEFUN ("dbus-registered-inhibitor-locks", Fdbus_registered_inhibitor_locks, - Sdbus_registered_inhibitor_locks, +DEFUN ("dbus--registered-fds", Fdbus__registered_fds, Sdbus__registered_fds, 0, 0, 0, - doc: /* Return registered inhibitor locks, an alist. -This allows to check, whether other packages of the running Emacs -instance have acquired an inhibitor lock as well. -An entry in this list is a list (FD WHAT WHY BLOCK). -The car of the list is the file descriptor retrieved from a -'dbus-make-inhibitor-lock` call. The cdr of the list represents the -three arguments 'dbus-make-inhibitor-lock` was called with. */) + doc: /* Return registered file descriptors, an alist. +The key is an open file descriptor, retrieved via `dbus-call-method' or +`dbus--open-fd'. The value is a string OBJECT-PATH or FILENAME, which +represents the arguments the function was called with. Those values are +not needed for further operations; they are just shown for information. + +This alist allows to check, whether other packages of the running Emacs +instance have acquired a file descriptor as well. */) (void) { - /* We return a copy of xd_registered_inhibitor_locks, in order to - protect it against malicious manipulation. */ - Lisp_Object registered = xd_registered_inhibitor_locks; + /* We return a copy of xd_registered_fds, in order to protect it + against malicious manipulation. */ + Lisp_Object registered = xd_registered_fds; Lisp_Object result = Qnil; for (; !NILP (registered); registered = CDR_SAFE (registered)) - result = Fcons (Fcopy_sequence (CAR_SAFE (registered)), result); + { + Lisp_Object tem = CAR_SAFE (registered); + result = Fcons (Fcons (CAR_SAFE (tem), CDR_SAFE (tem)), result); + } return Fnreverse (result); } @@ -1836,7 +1838,22 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) Fremhash (key, Vdbus_registered_objects_table); /* Store the event. */ - xd_store_event (value, args, event_args); + xd_store_event (CONSP (value) ? CAR_SAFE (value) : value, args, event_args); + +#ifdef DBUS_TYPE_UNIX_FD + /* Check, whether there is a file descriptor to be kept. + value is (handler . path) + args is ((:unix-fd NN) ...) */ + if (CONSP (value) + && CONSP (CAR_SAFE (args)) + && EQ (CAR_SAFE (CAR_SAFE (args)), QCunix_fd)) + { + xd_registered_fds = + Fcons (Fcons (CAR_SAFE (CDR_SAFE (CAR_SAFE (args))), + CDR_SAFE (value)), + xd_registered_fds); + } +#endif } else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ @@ -1972,7 +1989,7 @@ static void syms_of_dbusbind_for_pdumper (void) { xd_registered_buses = Qnil; - xd_registered_inhibitor_locks = Qnil; + xd_registered_fds = Qnil; } void @@ -1980,9 +1997,9 @@ syms_of_dbusbind (void) { defsubr (&Sdbus__init_bus); defsubr (&Sdbus_get_unique_name); - defsubr (&Sdbus_make_inhibitor_lock); - defsubr (&Sdbus_close_inhibitor_lock); - defsubr (&Sdbus_registered_inhibitor_locks); + defsubr (&Sdbus__fd_open); + defsubr (&Sdbus__fd_close); + defsubr (&Sdbus__registered_fds); DEFSYM (Qdbus_message_internal, "dbus-message-internal"); defsubr (&Sdbus_message_internal); @@ -2007,6 +2024,11 @@ syms_of_dbusbind (void) /* Lisp symbol for method interactive authorization. */ DEFSYM (QCauthorizable, ":authorizable"); + /* Lisp symbol for file descriptor kept. */ +#ifdef DBUS_TYPE_UNIX_FD + DEFSYM (QCkeep_fd, ":keep-fd"); +#endif + /* Lisp symbols of D-Bus types. */ DEFSYM (QCbyte, ":byte"); DEFSYM (QCboolean, ":boolean"); @@ -2143,7 +2165,7 @@ be called when the D-Bus reply message arrives. */); /* Initialize internal objects. */ pdumper_do_now_and_after_load (syms_of_dbusbind_for_pdumper); staticpro (&xd_registered_buses); - staticpro (&xd_registered_inhibitor_locks); + staticpro (&xd_registered_fds); Fprovide (intern_c_string ("dbusbind"), Qnil); } diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 53ce1929cad..f4dd9e3796b 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -2308,89 +2308,156 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) -(ert-deftest dbus-test10-inhibitor-locks () - "Check `dbus-*-inhibitor-locks'." +(ert-deftest dbus-test10-keep-fd () + "Check D-Bus `:keep-fd' argument." :tags '(:expensive-test) (skip-unless dbus--test-enabled-system-bus) (skip-unless (dbus-ping :system dbus--test-systemd-service 1000)) - (let (lock1 lock2) + (let ((what "sleep") + (who "Emacs test user") + (why "Test delay") + (mode "delay") + (fd-directory (format "/proc/%d/fd" (emacs-pid))) + lock1 lock2) ;; Create inhibitor lock. - (setq lock1 (dbus-make-inhibitor-lock "sleep" "Test delay")) + (setq lock1 + (dbus-call-method + :system dbus--test-systemd-service dbus--test-systemd-path + dbus--test-systemd-manager-interface "Inhibit" + what who why mode)) (should (natnump lock1)) ;; The lock is reported by systemd. (should (member - (list "sleep" "Emacs" "Test delay" "delay" (user-uid) (emacs-pid)) + (list what who why mode (user-uid) (emacs-pid)) (dbus-call-method :system dbus--test-systemd-service dbus--test-systemd-path dbus--test-systemd-manager-interface "ListInhibitors"))) - ;; The lock is registered internally. - (should - (member - (list lock1 "sleep" "Test delay" nil) - (dbus-registered-inhibitor-locks))) + ;; The lock is not registered internally. + (should-not (assoc lock1 (dbus--registered-fds))) ;; There exist a file descriptor. - (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) - (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) + (when (file-directory-p fd-directory) + (should + (file-symlink-p + (expand-file-name (number-to-string lock1) fd-directory)))) - ;; It is not possible to modify registered inhibitor locks on Lisp level. - (setcar (assoc lock1 (dbus-registered-inhibitor-locks)) 'malicious) - (should (assoc lock1 (dbus-registered-inhibitor-locks))) - (should-not (assoc 'malicious (dbus-registered-inhibitor-locks))) - - ;; Creating it again returns the same inhibitor lock. - (should (= lock1 (dbus-make-inhibitor-lock "sleep" "Test delay"))) - - ;; Create another inhibitor lock. - (setq lock2 (dbus-make-inhibitor-lock "sleep" "Test block" 'block)) + ;; Create another inhibitor lock. Keep the file descriptor. + (setq lock2 + (dbus-call-method + :system dbus--test-systemd-service dbus--test-systemd-path + dbus--test-systemd-manager-interface "Inhibit" :keep-fd + what who why mode)) (should (natnump lock2)) (should-not (= lock1 lock2)) ;; The lock is reported by systemd. (should (member - (list "sleep" "Emacs" "Test block" "block" (user-uid) (emacs-pid)) + (list what who why mode (user-uid) (emacs-pid)) (dbus-call-method :system dbus--test-systemd-service dbus--test-systemd-path dbus--test-systemd-manager-interface "ListInhibitors"))) ;; The lock is registered internally. (should (member - (list lock2 "sleep" "Test block" t) - (dbus-registered-inhibitor-locks))) + (cons lock2 dbus--test-systemd-path) + (dbus--registered-fds))) ;; There exist a file descriptor. - (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) - (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock2)))) + (when (file-directory-p fd-directory) + (should + (file-symlink-p + (expand-file-name (number-to-string lock2) fd-directory)))) - ;; Close the first inhibitor lock. - (should (dbus-close-inhibitor-lock lock1)) - ;; The internal registration has gone. - (should-not - (member - (list lock1 "sleep" "Test delay" nil) - (dbus-registered-inhibitor-locks))) - ;; The file descriptor has been deleted. - (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) - (should-not (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) - - ;; Closing it again is a noop. - (should-not (dbus-close-inhibitor-lock lock1)) - - ;; Creating it again returns (another?) inhibitor lock. - (setq lock1 (dbus-make-inhibitor-lock "sleep" "Test delay")) + ;; Create another inhibitor lock via + ;; `dbus-call-method-asynchronously'. Keep the file descriptor. + (setq lock1 nil) + (dbus-call-method-asynchronously + :system dbus--test-systemd-service dbus--test-systemd-path + dbus--test-systemd-manager-interface "Inhibit" + (lambda (lock) (setq lock1 lock)) :keep-fd + what who why mode) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null lock1) (read-event nil nil 0.1))) (should (natnump lock1)) + (should-not (= lock1 lock2)) ;; The lock is registered internally. (should (member - (list lock1 "sleep" "Test delay" nil) - (dbus-registered-inhibitor-locks))) + (cons lock1 dbus--test-systemd-path) + (dbus--registered-fds))) ;; There exist a file descriptor. - (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) - (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) + (when (file-directory-p fd-directory) + (should + (file-symlink-p + (expand-file-name (number-to-string lock1) fd-directory)))) + + ;; It is not possible to modify registered inhibitor locks on Lisp level. + (setcar (assoc lock1 (dbus--registered-fds)) 'malicious) + (should (assoc lock1 (dbus--registered-fds))) + (should-not (assoc 'malicious (dbus--registered-fds))) ;; Close the inhibitor locks. - (should (dbus-close-inhibitor-lock lock1)) - (should (dbus-close-inhibitor-lock lock2)))) + (should (dbus--fd-close lock1)) + (should (dbus--fd-close lock2)) + ;; The internal registration has gone. + (should-not + (member + (cons lock1 dbus--test-systemd-path) + (dbus--registered-fds))) + (should-not + (member + (cons lock2 dbus--test-systemd-path) + (dbus--registered-fds))) + ;; The file descriptors have been deleted. + (when (file-directory-p fd-directory) + (should-not + (file-exists-p (expand-file-name (number-to-string lock1) fd-directory))) + (should-not + (file-exists-p (expand-file-name (number-to-string lock2) fd-directory)))) + + ;; Closing them again is a noop. + (should-not (dbus--fd-close lock1)) + (should-not (dbus--fd-close lock2)))) + +(ert-deftest dbus-test10-open-close-fd () + "Check D-Bus open/close a file descriptor." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-system-bus) + (skip-unless (dbus-ping :system dbus--test-systemd-service 1000)) + + (ert-with-temp-file tmpfile + (let ((fd-directory (format "/proc/%d/fd" (emacs-pid))) + fd) + ;; Create file descriptor. + (setq fd (dbus--fd-open tmpfile)) + (should (natnump fd)) + ;; The file descriptor is registered internally. + (should (member (cons fd tmpfile) (dbus--registered-fds))) + ;; There exist a file descriptor file. + (when (file-directory-p fd-directory) + (should + (file-symlink-p (expand-file-name (number-to-string fd) fd-directory))) + (should + (string-equal + (file-truename (expand-file-name (number-to-string fd) fd-directory)) + tmpfile))) + + ;; It is not possible to modify registered file descriptors on Lisp level. + (setcar (assoc fd (dbus--registered-fds)) 'malicious) + (should (assoc fd (dbus--registered-fds))) + (should-not (assoc 'malicious (dbus--registered-fds))) + + ;; Close the file descriptor. + (should (dbus--fd-close fd)) + ;; The internal registration has gone. + (should-not (member (cons fd tmpfile) (dbus--registered-fds))) + ;; The file descriptor file has been deleted. + (when (file-directory-p fd-directory) + (should-not + (file-exists-p (expand-file-name (number-to-string fd) fd-directory)))) + + ;; Closing it again is a noop. + (should-not (dbus--fd-close fd))))) (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." From 04bb557d7efe46cb6a6a6ebd4a2d8ebcfbd97c74 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 7 Feb 2026 11:33:14 +0100 Subject: [PATCH 113/191] ; * lisp/doc-view.el (doc-view-mode-p): Fix docstring. --- lisp/doc-view.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 30311e1a8ed..4e28dd400ce 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -955,7 +955,7 @@ It's a subdirectory of `doc-view-cache-directory'." (defun doc-view-mode-p (type) "Return non-nil if document type TYPE is available for `doc-view'. Document types are symbols like `dvi', `ps', `pdf', `epub', -`cbz', `fb2', `xps', `oxps', or`odf' (any OpenDocument format)." +`cbz', `fb2', `xps', `oxps', or `odf' (any OpenDocument format)." (and (display-graphic-p) (image-type-available-p 'png) (cond From 419ac8148f1fffd7755f3545137a0321914441d9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 7 Feb 2026 14:22:12 +0200 Subject: [PATCH 114/191] ; Document creation of strings from copies of other strings * doc/lispref/strings.texi (Creating Strings): Document how to create a string from N copies of another string. (Bug#80256) --- doc/lispref/strings.texi | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 44be529d562..d073d3ffe2f 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -281,6 +281,17 @@ another string, alter a constant string in the program, or even raise an error. To obtain a string that you can safely mutate, use @code{copy-sequence} on the result. +If you need to create a string made from @var{n} copies of a given +source string @var{source}, you can use @code{concat} as follows: + +@lisp + (apply #'concat (make-list @var{n} @var{source})) +@end lisp + +@noindent +This uses the fact that @code{concat} can take any kind of sequence as +its arguments. + For information about other concatenation functions, see the description of @code{mapconcat} in @ref{Mapping Functions}, @code{vconcat} in @ref{Vector Functions}, and @code{append} in @ref{Building From 3d7e78b810b11b71b95a87ffabf2995dd8fe2fe9 Mon Sep 17 00:00:00 2001 From: kobarity Date: Sat, 31 Jan 2026 23:10:03 +0900 Subject: [PATCH 115/191] Revert "Performance improvement of 'python-shell-get-process'" This reverts commit 83b4f1ba26844c178e57ecb93ea8db36e8e6fa89. We concluded that it is better to use 'project-name-cached'. (Bug#80045) --- lisp/progmodes/python.el | 21 +-------------------- 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index b6981c9156c..9fa2b1aaf19 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -3816,16 +3816,6 @@ variable. (compilation-shell-minor-mode 1) (python-pdbtrack-setup-tracking)) -(defvar-local python-shell--process-cache) -(defvar-local python-shell--process-cache-valid) - -(defun python-shell--invalidate-process-cache () - "Invalidate process cache." - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (setq python-shell--process-cache nil - python-shell--process-cache-valid nil)))) - (defun python-shell-make-comint (cmd proc-name &optional show internal) "Create a Python shell comint buffer. CMD is the Python command to be executed and PROC-NAME is the @@ -3842,7 +3832,6 @@ killed." (let* ((proc-buffer-name (format (if (not internal) "*%s*" " *%s*") proc-name))) (when (not (comint-check-proc proc-buffer-name)) - (python-shell--invalidate-process-cache) (let* ((cmdlist (split-string-and-unquote cmd)) (interpreter (car cmdlist)) (args (cdr cmdlist)) @@ -3966,15 +3955,7 @@ If current buffer is in `inferior-python-mode', return it." (defun python-shell-get-process () "Return inferior Python process for current buffer." - (unless (and python-shell--process-cache-valid - (or (not python-shell--process-cache) - (and (process-live-p python-shell--process-cache) - (buffer-live-p - (process-buffer python-shell--process-cache))))) - (setq python-shell--process-cache - (get-buffer-process (python-shell-get-buffer)) - python-shell--process-cache-valid t)) - python-shell--process-cache) + (get-buffer-process (python-shell-get-buffer))) (defun python-shell-get-process-or-error (&optional interactivep) "Return inferior Python process for current buffer or signal error. From 482748592f61abed6f675e7b62b2d56e4e18a146 Mon Sep 17 00:00:00 2001 From: kobarity Date: Sat, 31 Jan 2026 23:11:04 +0900 Subject: [PATCH 116/191] Use 'project-name-cached' in 'python-shell-get-process-name' * lisp/progmodes/python.el (python-shell-get-project-name): New function. (python-shell-get-process-name): Use it. (Bug#80045) Co-authored-by: Liu Hui --- lisp/progmodes/python.el | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 9fa2b1aaf19..39ec97e1b86 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -3366,6 +3366,16 @@ from `python-shell-prompt-regexp', python-shell--prompt-calculated-output-regexp (funcall build-regexp output-prompts))))) +(defun python-shell-get-project-name () + "Return the project name for the current buffer. +Use `project-name-cached' if available." + (when (featurep 'project) + (if (fboundp 'project-name-cached) + (project-name-cached default-directory) + (when-let* ((proj (project-current))) + (file-name-nondirectory + (directory-file-name (project-root proj))))))) + (defun python-shell-get-process-name (dedicated) "Calculate the appropriate process name for inferior Python process. If DEDICATED is nil, this is simply `python-shell-buffer-name'. @@ -3374,11 +3384,8 @@ name respectively the current project name." (pcase dedicated ('nil python-shell-buffer-name) ('project - (if-let* ((proj (and (featurep 'project) - (project-current)))) - (format "%s[%s]" python-shell-buffer-name (file-name-nondirectory - (directory-file-name - (project-root proj)))) + (if-let* ((proj-name (python-shell-get-project-name))) + (format "%s[%s]" python-shell-buffer-name proj-name) python-shell-buffer-name)) (_ (format "%s[%s]" python-shell-buffer-name (buffer-name))))) From 3107c66c844355269c02dd3418e80275a33ed296 Mon Sep 17 00:00:00 2001 From: kobarity Date: Sat, 31 Jan 2026 23:12:05 +0900 Subject: [PATCH 117/191] Change the type of 'python-eldoc-function-timeout' to number * etc/NEWS: Announce the change. * lisp/progmodes/python.el (python-eldoc-function-timeout): Change the type. (Bug#80045) --- etc/NEWS | 6 ++++++ lisp/progmodes/python.el | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 1d6929f97e2..ce344283368 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2508,6 +2508,12 @@ When point is between indentation, the command deletes the text in the region and deactivates the mark if Transient Mark mode is enabled, the mark is active, and prefix argument is 1. +--- +*** 'python-eldoc-function-timeout' now accepts floating-point numbers. +To allow for finer-grained adjustment of timeout for +'python-eldoc-function', 'python-eldoc-function-timeout' now accepts +floating-point numbers as well as integers. + ** Tmm Menubar --- diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 39ec97e1b86..2a3035c95c5 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -5842,7 +5842,7 @@ Set to nil by `python-eldoc-function' if (defcustom python-eldoc-function-timeout 1 "Timeout for `python-eldoc-function' in seconds." - :type 'integer + :type 'number :version "25.1") (defcustom python-eldoc-function-timeout-permanent t From e0ce881be92f0cf26723c3714a3903a088912906 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Marks?= Date: Sat, 31 Jan 2026 21:19:48 -0500 Subject: [PATCH 118/191] ; Minor changes to 'truncate-string-pixelwise' (bug#80244) Fix two bugs and add tests for them. --- lisp/emacs-lisp/subr-x.el | 73 ++++++++++++++++++++------------------- test/lisp/misc-tests.el | 10 ++++++ 2 files changed, 47 insertions(+), 36 deletions(-) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index db854863b32..b36b14b9b50 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -419,44 +419,45 @@ can be used to avoid the cost of recomputing this for multiple calls to this function using the same ELLIPSIS." (declare (important-return-value t)) (if (zerop (length string)) - 0 + string ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. - (with-work-buffer - (work-buffer--prepare-pixelwise string buffer) - (set-window-buffer nil (current-buffer) 'keep-margins) - ;; Use a binary search to prune the number of calls to - ;; `window-text-pixel-size'. - ;; These are 1-based buffer indexes. - (let* ((low 1) - (high (1+ (length string))) - mid) - (when (> (car (window-text-pixel-size nil 1 high)) max-pixels) - (when (and ellipsis (not (stringp ellipsis))) - (setq ellipsis (truncate-string-ellipsis))) - (setq ellipsis-pixels (if ellipsis - (if ellipsis-pixels - ellipsis-pixels - (string-pixel-width ellipsis buffer)) - 0)) - (let ((adjusted-pixels - (if (> max-pixels ellipsis-pixels) - (- max-pixels ellipsis-pixels) - max-pixels))) - (while (<= low high) - (setq mid (floor (+ low high) 2)) - (if (<= (car (window-text-pixel-size nil 1 mid)) - adjusted-pixels) - (setq low (1+ mid)) - (setq high (1- mid)))))) - (set-window-buffer nil buffer 'keep-margins) - (if mid - ;; Binary search ran. - (if (and ellipsis (> max-pixels ellipsis-pixels)) - (concat (substring string 0 (1- high)) ellipsis) - (substring string 0 (1- high))) - ;; Fast path. - string))))) + (let ((original-buffer (or buffer (current-buffer)))) + (with-work-buffer + (work-buffer--prepare-pixelwise string buffer) + (set-window-buffer nil (current-buffer) 'keep-margins) + ;; Use a binary search to prune the number of calls to + ;; `window-text-pixel-size'. + ;; These are 1-based buffer indexes. + (let* ((low 1) + (high (1+ (length string))) + mid) + (when (> (car (window-text-pixel-size nil 1 high)) max-pixels) + (when (and ellipsis (not (stringp ellipsis))) + (setq ellipsis (truncate-string-ellipsis))) + (setq ellipsis-pixels (if ellipsis + (if ellipsis-pixels + ellipsis-pixels + (string-pixel-width ellipsis buffer)) + 0)) + (let ((adjusted-pixels + (if (> max-pixels ellipsis-pixels) + (- max-pixels ellipsis-pixels) + max-pixels))) + (while (<= low high) + (setq mid (floor (+ low high) 2)) + (if (<= (car (window-text-pixel-size nil 1 mid)) + adjusted-pixels) + (setq low (1+ mid)) + (setq high (1- mid)))))) + (set-window-buffer nil original-buffer 'keep-margins) + (if mid + ;; Binary search ran. + (if (and ellipsis (> max-pixels ellipsis-pixels)) + (concat (substring string 0 (1- high)) ellipsis) + (substring string 0 (1- high))) + ;; Fast path. + string)))))) ;;;###autoload (defun string-glyph-split (string) diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index 5d0b9ae0604..81ebe1a5869 100644 --- a/test/lisp/misc-tests.el +++ b/test/lisp/misc-tests.el @@ -249,6 +249,16 @@ ;; faces, and varying face heights and compare results to each ;; character's measured width. (ert-deftest misc-test-truncate-string-pixelwise () + ;; Test empty string without an explicit buffer. + (should (equal (truncate-string-pixelwise "" 123) "")) + ;; Test fast path without an explicit buffer. + (should (equal (truncate-string-pixelwise "123" 123) "123")) + (with-temp-buffer + ;; Test empty string with an explicit buffer. + (should (equal (truncate-string-pixelwise "" 123 (current-buffer)) "")) + ;; Test fast path with an explicit buffer. + (should (equal (truncate-string-pixelwise "123" 123 (current-buffer)) "123"))) + (dolist (c '(?W ?X ?y ?1)) (dolist (ellipsis `(nil "..." ,(truncate-string-ellipsis))) (dolist (face '(fixed-pitch variable-pitch)) From f430166f7d740573649319a2cae8c661b792f9de Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 8 Feb 2026 08:34:36 +0200 Subject: [PATCH 119/191] ; * doc/lispref/commands.texi (Special Events): Add cross-reference. --- doc/lispref/commands.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index bd31798d431..b907ba96bed 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -4062,7 +4062,8 @@ definition to find the actual event. user signals like @code{sigusr1} are normally handled in this way. The keymap which defines how to handle special events---and which events are special---is in the variable @code{special-event-map} -(@pxref{Controlling Active Maps}). +(@pxref{Controlling Active Maps}). @xref{Misc Events}, for more details +about these and other special events. @defun insert-special-event @cindex inserting special events From 78fc5e2833925d1065f8ce9590440e6fd3192a48 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Sat, 7 Feb 2026 14:50:35 -0500 Subject: [PATCH 120/191] Eglot: Add "static-ls" to Haskell LSP list This is an alternative language server for Haskell. Intended to be faster and not use as much memory as haskell-language-server. Making it a backup with lower precedence if both exist. * lisp/progmodes/eglot.el (eglot-server-programs): Add "static-ls". (Bug#80351) --- lisp/progmodes/eglot.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 89fbdec131f..4752b0100d9 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -282,7 +282,8 @@ automatically)." . ,(eglot-alternatives '(("solargraph" "socket" "--port" :autoport) "ruby-lsp"))) (haskell-mode - . ("haskell-language-server-wrapper" "--lsp")) + . ,(eglot-alternatives + '(("haskell-language-server-wrapper" "--lsp") "static-ls"))) (elm-mode . ("elm-language-server")) (mint-mode . ("mint" "ls")) ((kotlin-mode kotlin-ts-mode) . ("kotlin-language-server")) From 7586a5474cd6c1ea8510b5a8178c74160cc783d0 Mon Sep 17 00:00:00 2001 From: Andreas Schwab Date: Sun, 8 Feb 2026 12:34:02 +0100 Subject: [PATCH 121/191] Extend emacs server protocol for empty arguments An empty argument is represented by &0. On the receiving side, &0 is replaced by nothing. * lisp/server.el (server-unquote-arg): Replace "&0" by nothing. (server-quote-arg): Produce "&0" for an empty string. * lib-src/emacsclient.c (quote_argument): Produce "&0" for an empty string. (unquote_argument): Replace "&0" by nothing. (Bug#80356) --- lib-src/emacsclient.c | 6 +++++- lisp/server.el | 20 ++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 4f3215ea6b1..ba08d7dd6d3 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -867,8 +867,10 @@ send_to_emacs (HSOCKET s, const char *data) static void quote_argument (HSOCKET s, const char *str) { - char *copy = xmalloc (strlen (str) * 2 + 1); + char *copy = xmalloc (strlen (str) * 2 + 3); char *q = copy; + if (*str == '\0') + *q++ = '&', *q++ = '0'; if (*str == '-') *q++ = '&', *q++ = *str++; for (; *str; str++) @@ -910,6 +912,8 @@ unquote_argument (char *str) c = ' '; else if (c == 'n') c = '\n'; + else if (c == '0') + continue; } *q++ = c; } diff --git a/lisp/server.el b/lisp/server.el index fcfc6c01972..88b370d15a2 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -531,6 +531,7 @@ See `server-quote-arg' and `server-process-filter'." (?& "&") (?- "-") (?n "\n") + (?0 "") (_ " "))) arg t t)) @@ -538,16 +539,19 @@ See `server-quote-arg' and `server-process-filter'." "In ARG, insert a & before each &, each space, each newline, and -. Change spaces to underscores, too, so that the return value never contains a space. +An empty ARG is represented by &0. See `server-unquote-arg' and `server-process-filter'." - (replace-regexp-in-string - "[-&\n ]" (lambda (s) - (pcase (aref s 0) - (?& "&&") - (?- "&-") - (?\n "&n") - (?\s "&_"))) - arg t t)) + (if (equal arg "") + "&0" + (replace-regexp-in-string + "[-&\n ]" (lambda (s) + (pcase (aref s 0) + (?& "&&") + (?- "&-") + (?\n "&n") + (?\s "&_"))) + arg t t))) (defun server-send-string (proc string) "A wrapper around `process-send-string' for logging." From 51b883719b386e16988377446d6ae97676587363 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 8 Feb 2026 15:06:00 +0000 Subject: [PATCH 122/191] ; Fix some issues in core documentation for cond*. --- doc/lispref/control.texi | 51 +++++++++++++++++++----------------- lisp/emacs-lisp/cond-star.el | 23 +++++++++------- 2 files changed, 40 insertions(+), 34 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 7c3f29c7226..9b0d58876f8 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1493,25 +1493,27 @@ argument: @subsection The @code{cond*} macro @findex cond*@r{, a macro} - The @code{cond*} macro is an alternative to @code{pcase}, and supports -the same functionality, but using syntax that some might find less -cryptic. + You can use the @code{cond*} macro as an alternative to @code{pcase} +if you find @code{pcase}'s syntax too cryptic. In addition, +@code{cond*} offers some new forms of control flow that aren't related +to being an alternative to @code{pcase}. @defmac cond* &rest clauses The @code{cond*} macro is an extended form of the traditional @code{cond}. A @code{cond*} expression contains a series of -@var{clauses}, each of which can use @code{bind*} to specify binding -variables, use @code{match*} to specify matching a pattern as a -condition, or specify an expression as a condition to evaluate as a -test. +@var{clauses}, each of which can use @code{bind*} or @code{bind-and*} to +specify binding variables, use @code{match*} or @code{pcase*} to specify +matching a pattern as a condition, or specify an expression as a +condition to evaluate as a test. Each clause normally has the form @w{@code{(@var{condition} @var{body}@dots{})}}. @var{condition} can be a Lisp expression, as in @code{cond} (@pxref{Conditionals}). Or it can be @w{@code{(bind* -@var{bindings}@dots{})}} or @w{@code{(match* @var{pattern} -@var{datum})}}. +@var{bindings}@dots{})}}, @w{@code{(match* @var{pattern} @var{datum})}}, +@w{@code{(bind-and* @var{bindings}@dots{})}} or @w{@code{(pcase* +@var{pattern} @var{datum})}} @findex bind* @code{(bind* @var{bindings}@dots{})} means to bind @var{bindings} (like @@ -1522,10 +1524,10 @@ true if the first binding's value is non-@code{nil}. @findex bind-and* @code{(bind-and* @var{bindings}@dots{})} means to bind @var{bindings} (like the bindings list in @code{if-let*}, @pxref{Conditionals}) for -only the body of the clause. As a condition, it counts as true if none -of the bindings evaluate to @code{nil}. In addition, if any binding -evaluates to @code{nil}, the expressions for the values of subsequent -bindings are not evaluated. +only the body of the clause. It is always a non-exit clause. As a +condition, it counts as true if none of the bindings evaluate to +@code{nil}. In addition, if any binding evaluates to @code{nil}, the +expressions for the values of subsequent bindings are not evaluated. @findex match* @findex pcase* @@ -1536,23 +1538,24 @@ bind to the parts of @var{datum} that they match. @code{(pcase* @var{pattern} @var{datum})} works in the same way except it uses the Pcase syntax for @var{pattern}. -@code{bind*}, @code{match*}, and @code{pcase*} normally bind their bindings over -the execution of the whole containing clause. However, if the clause is -written to specify ``non-exit'', the clause's bindings cover the whole -rest of the @code{cond*}. +@code{match*}, and @code{pcase*} normally bind their bindings over the +execution of the whole containing clause. However, if the clause is +written to specify ``non-exit'' (see below), the clause's bindings cover +the whole rest of the @code{cond*}. When a clause's condition is true, and it exits the @code{cond*} or is the last clause, the value of the last expression in the clause's body becomes the return value of the @code{cond*} construct. -@subheading Non-exit clause +@subheading Non-exit clauses -If a clause has only one element, or if its first element is @code{t}, -or if it ends with the keyword @code{:non-exit}, then this clause never -exits the @code{cond*} construct. Instead, control falls through to the -next clause (if any). The bindings made in @var{condition} for the -@var{body} of the non-exit clause are passed along to the rest of the -clauses in this @code{cond*} construct. +If a clause has only one element, or if its first element is @code{t}, a +@code{bind*} or a @code{bind-and*} clause, or if it ends with the +keyword @code{:non-exit}, then this clause never exits the @code{cond*} +construct. Instead, control falls through to the next clause (if any). +Except for @code{bind-and*}, the bindings made in @var{condition} for +the @var{body} of the non-exit clause are passed along to the rest of +the clauses in this @code{cond*} construct. Note: @code{pcase*} does not support @code{:non-exit}, and when used in a non-exit clause, it follows the semantics of @code{pcase-let}, see diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index fc8e261339e..3bc3eff2935 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -58,7 +58,7 @@ normally has the form (CONDITION BODY...). CONDITION can be a Lisp expression, as in `cond'. Or it can be one of `(bind* BINDINGS...)', `(match* PATTERN DATUM)', -or `(pcase* PATTERN DATUM)', +`(bind-and* BINDINGS...)' or `(pcase* PATTERN DATUM)', `(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') for the body of the clause, and all subsequent clauses, since the `bind*' @@ -70,8 +70,9 @@ For its patterns, see `match*'. The condition counts as true if PATTERN matches DATUM. `(bind-and* BINDINGS...)' means to bind BINDINGS (as if they were in -`if-let*') for only the the body of the clause. If any expression -evaluates to nil, the condition counts as false. +`if-let*') for only the the body of the clause. It is always a non-exit +clause. If any expression evaluates to nil, the condition counts as +false. `(pcase* PATTERN DATUM)' means to match DATUM against the pattern PATTERN, using the same pattern syntax as `pcase'. @@ -81,15 +82,17 @@ When a clause's condition is true, and it exits the `cond*' or is the last clause, the value of the last expression in its body becomes the return value of the `cond*' construct. -Non-exit clause: +Non-exit clauses: -If a clause has only one element, or if its first element is -t or a `bind*' clause, this clause never exits the `cond*' construct. -Instead, control always falls through to the next clause (if any). -All bindings made in CONDITION for the BODY of the non-exit clause -are passed along to the rest of the clauses in this `cond*' construct. +If a clause has only one element, or if its first element is t, a +`bind*' clause or a `bind-and*' clause, then this clause never exits the +`cond*' construct. Instead, control always falls through to the next +clause (if any). Except for `bind-and*', all bindings made in CONDITION +for the BODY of the non-exit clause are passed along to the rest of the +clauses in this `cond*' construct. -\\[match*] for documentation of the patterns for use in `match*'." +See `match*' for documentation of the patterns for use in `match*' +conditions." ;; FIXME: Want an Edebug declaration. (cond*-convert clauses)) From 2437a45144915457d1f4ab1a1124aeaab7307ae7 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 8 Feb 2026 15:11:08 +0000 Subject: [PATCH 123/191] ; Further fixes to core documentation for cond*. --- doc/lispref/control.texi | 2 +- lisp/emacs-lisp/cond-star.el | 11 ++++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 9b0d58876f8..2b882763e06 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1550,7 +1550,7 @@ becomes the return value of the @code{cond*} construct. @subheading Non-exit clauses If a clause has only one element, or if its first element is @code{t}, a -@code{bind*} or a @code{bind-and*} clause, or if it ends with the +@code{bind*} form or a @code{bind-and*} form, or if it ends with the keyword @code{:non-exit}, then this clause never exits the @code{cond*} construct. Instead, control falls through to the next clause (if any). Except for @code{bind-and*}, the bindings made in @var{condition} for diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 3bc3eff2935..cd5a7f530e1 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -85,11 +85,12 @@ in its body becomes the return value of the `cond*' construct. Non-exit clauses: If a clause has only one element, or if its first element is t, a -`bind*' clause or a `bind-and*' clause, then this clause never exits the -`cond*' construct. Instead, control always falls through to the next -clause (if any). Except for `bind-and*', all bindings made in CONDITION -for the BODY of the non-exit clause are passed along to the rest of the -clauses in this `cond*' construct. +`bind*' form or a `bind-and*' form, or if it ends with the keyword +`:non-exit', then this clause never exits the `cond*' construct. +Instead, control always falls through to the next clause (if any). +Except for `bind-and*', all bindings made in CONDITION for the BODY of +the non-exit clause are passed along to the rest of the clauses in this +`cond*' construct. See `match*' for documentation of the patterns for use in `match*' conditions." From ec8d82f53b15e02246930ac111f80657d688faf4 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 8 Feb 2026 15:20:49 +0000 Subject: [PATCH 124/191] cond*: Fix handling bind-and* in two places * lisp/emacs-lisp/cond-star.el (cond*-non-exit-clause-p) (cond*-non-exit-clause-substance): Handle bind-and* the same as bind*. --- lisp/emacs-lisp/cond-star.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index cd5a7f530e1..6995f24eac3 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -197,16 +197,16 @@ CONDITION of a `cond*' clause. See `cond*' for details." (and (cdr-safe clause) ;; Starts with t. (or (eq (car clause) t) - ;; Starts with a `bind*' pseudo-form. + ;; Starts with a `bind*' or `bind-and*' pseudo-form. (and (consp (car clause)) - (eq (caar clause) 'bind*)))))) + (memq (caar clause) '(bind* bind-and*))))))) (defun cond*-non-exit-clause-substance (clause) "For a non-exit cond* clause CLAUSE, return its substance. This removes a final keyword if that's what makes CLAUSE non-exit." (cond ((or (null (cdr-safe clause)) ;; either clause has only one element - (and (consp (car clause)) ;; or it starts with `bind*' - (eq (caar clause) 'bind*))) + (and (consp (car clause)) ;; or it starts with `bind*'/`bind-and*' + (memq (caar clause) '(bind* bind-and*)))) clause) ;; Starts with t or a keyword. ;; Include t as the first element of the substance From 01d8abea0453fe4f0ffdf85c0a37f3fb33c7e1dd Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 8 Feb 2026 15:28:37 +0000 Subject: [PATCH 125/191] cond*: Fix handling of :non-exit keywords * lisp/emacs-lisp/cond-star.el (cond*-non-exit-clause-p): Don't return nil for clauses ending with ':non-exit'. (cond*-non-exit-clause-substance): Don't accept just any keyword, require ':non-exit'. --- lisp/emacs-lisp/cond-star.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 6995f24eac3..dfb08459506 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -199,7 +199,9 @@ CONDITION of a `cond*' clause. See `cond*' for details." (or (eq (car clause) t) ;; Starts with a `bind*' or `bind-and*' pseudo-form. (and (consp (car clause)) - (memq (caar clause) '(bind* bind-and*))))))) + (memq (caar clause) '(bind* bind-and*))))) + ;; Ends with keyword. + (eq (car (last clause)) :non-exit))) (defun cond*-non-exit-clause-substance (clause) "For a non-exit cond* clause CLAUSE, return its substance. @@ -218,7 +220,7 @@ This removes a final keyword if that's what makes CLAUSE non-exit." (cons t (cdr clause))) ;; Ends with keyword. - ((keywordp (car (last clause))) + ((eq (car (last clause)) :non-exit) ;; Do NOT include the final keyword. (butlast clause)))) From 7fd6fa4a8b71615fa21dc990503736d4405193c6 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 8 Feb 2026 16:52:12 +0000 Subject: [PATCH 126/191] Revert "Extend emacs server protocol for empty arguments" This reverts this change: Author: Andreas Schwab AuthorDate: Sun Feb 8 12:34:02 2026 +0100 Extend emacs server protocol for empty arguments An empty argument is represented by &0. On the receiving side, &0 is replaced by nothing. * lisp/server.el (server-unquote-arg): Replace "&0" by nothing. (server-quote-arg): Produce "&0" for an empty string. * lib-src/emacsclient.c (quote_argument): Produce "&0" for an empty string. (unquote_argument): Replace "&0" by nothing. (Bug#80356) The bug in question was already fixed by this change: Author: Sean Whitton AuthorDate: Fri Nov 7 12:33:21 2025 +0000 Don't discard empty string arguments from emacsclient * lisp/server.el (server--process-filter-1): Don't discard empty string arguments from emacsclient. (server-eval-args-left): * doc/emacs/misc.texi (emacsclient Options): * etc/NEWS: Document the change. --- lib-src/emacsclient.c | 6 +----- lisp/server.el | 20 ++++++++------------ 2 files changed, 9 insertions(+), 17 deletions(-) diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index ba08d7dd6d3..4f3215ea6b1 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -867,10 +867,8 @@ send_to_emacs (HSOCKET s, const char *data) static void quote_argument (HSOCKET s, const char *str) { - char *copy = xmalloc (strlen (str) * 2 + 3); + char *copy = xmalloc (strlen (str) * 2 + 1); char *q = copy; - if (*str == '\0') - *q++ = '&', *q++ = '0'; if (*str == '-') *q++ = '&', *q++ = *str++; for (; *str; str++) @@ -912,8 +910,6 @@ unquote_argument (char *str) c = ' '; else if (c == 'n') c = '\n'; - else if (c == '0') - continue; } *q++ = c; } diff --git a/lisp/server.el b/lisp/server.el index 88b370d15a2..fcfc6c01972 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -531,7 +531,6 @@ See `server-quote-arg' and `server-process-filter'." (?& "&") (?- "-") (?n "\n") - (?0 "") (_ " "))) arg t t)) @@ -539,19 +538,16 @@ See `server-quote-arg' and `server-process-filter'." "In ARG, insert a & before each &, each space, each newline, and -. Change spaces to underscores, too, so that the return value never contains a space. -An empty ARG is represented by &0. See `server-unquote-arg' and `server-process-filter'." - (if (equal arg "") - "&0" - (replace-regexp-in-string - "[-&\n ]" (lambda (s) - (pcase (aref s 0) - (?& "&&") - (?- "&-") - (?\n "&n") - (?\s "&_"))) - arg t t))) + (replace-regexp-in-string + "[-&\n ]" (lambda (s) + (pcase (aref s 0) + (?& "&&") + (?- "&-") + (?\n "&n") + (?\s "&_"))) + arg t t)) (defun server-send-string (proc string) "A wrapper around `process-send-string' for logging." From c86094057b0c391d6160ba8c37c6df9bb0370b16 Mon Sep 17 00:00:00 2001 From: Daniel Mendler Date: Sat, 31 Jan 2026 10:13:02 +0100 Subject: [PATCH 127/191] completing-read-multiple: Implement on top of completing-read Avoid code duplication during minibuffer setup. * lisp/emacs-lisp/crm.el (completing-read-multiple): Call `completing-read' instead of duplicating the setup code of `completing-read-default'. --- lisp/emacs-lisp/crm.el | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 6bd763d2ea2..a1c7175fc66 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -255,14 +255,11 @@ with empty strings removed." crm-local-must-match-map crm-local-completion-map)) (map (minibuffer-visible-completions--maybe-compose-map map)) - (buffer (current-buffer)) input) (minibuffer-with-setup-hook (lambda () (add-hook 'choose-completion-string-functions 'crm--choose-completion-string nil 'local) - (setq-local minibuffer-completion-table #'crm--collection-fn) - (setq-local minibuffer-completion-predicate predicate) (setq-local completion-list-insert-choice-function (lambda (_start _end choice) (let* ((beg (save-excursion @@ -276,14 +273,9 @@ with empty strings removed." (1- (point)) (point-max))))) (completion--replace beg end choice)))) - ;; see completing_read in src/minibuf.c - (setq-local minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (setq-local minibuffer--require-match require-match) - (setq-local minibuffer--original-buffer buffer) (setq-local crm-completion-table table) - (completions--start-eager-display)) - (setq input (read-from-minibuffer + (use-local-map map)) + (setq input (completing-read (format-spec crm-prompt (let* ((sep (or (get-text-property 0 'separator crm-separator) @@ -291,11 +283,8 @@ with empty strings removed." (desc (or (get-text-property 0 'description crm-separator) (concat "list separated by " sep)))) `((?s . ,sep) (?d . ,desc) (?p . ,prompt)))) - initial-input map nil hist def inherit-input-method))) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) + #'crm--collection-fn predicate + require-match initial-input hist def inherit-input-method))) ;; Remove empty strings in the list of read strings. (split-string input crm-separator t))) From 8ddf2d2925f7d679718eaf66b71030280738482c Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Mon, 9 Feb 2026 00:55:35 +0200 Subject: [PATCH 128/191] project--delete-zombie-projects: Handle "Tramp failed to connect" * lisp/progmodes/project.el (project--delete-zombie-projects): Handle file-error when DIR is remote and unreachable (bug#80340). --- lisp/progmodes/project.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 997c876b1fa..80f705f49c6 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -2417,7 +2417,12 @@ PREDICATE can be a function with 1 argument which determines which projects should be deleted." (dolist (proj (project-known-project-roots)) (when (and (funcall (or predicate #'identity) proj) - (not (file-exists-p proj))) + (condition-case-unless-debug nil + (not (file-exists-p proj)) + (file-error + (yes-or-no-p + (format "Forget unreachable project `%s'? " + proj))))) (project-forget-project proj)))) (defun project-forget-zombie-projects (&optional interactive) From 59eb80a03ae846383705a1cbe72a9bf2dd824c15 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sun, 8 Feb 2026 17:02:34 -0800 Subject: [PATCH 129/191] butttonTrans need not be extern * lwlib/lwlib-Xaw.c (buttonTrans) [USE_CAIRO || HAVE_XFT]: Now static. This pacifies gcc -Wmissing-variable-declarations. --- lwlib/lwlib-Xaw.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lwlib/lwlib-Xaw.c b/lwlib/lwlib-Xaw.c index 76b313e8402..0699410cc82 100644 --- a/lwlib/lwlib-Xaw.c +++ b/lwlib/lwlib-Xaw.c @@ -487,7 +487,7 @@ static XtActionsRec button_actions[] = { "my_reset", command_reset }, { "my_press", command_press }, }; -char buttonTrans[] = +static char buttonTrans[] = ": reset() my_reset()\n" ": set() my_press()\n" ": my_reset() notify() unset()\n"; From 1e7dae37b8aa8628b3b72314ae1568d67b5fe687 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 8 Feb 2026 23:39:13 -0500 Subject: [PATCH 130/191] lisp/calendar: Style changes Fix some misuses of `defconst` and `%s`, avoid uses of the old dynbound dialect of `eval`, delete redundant `:group` arguments, and prefer #' to quote function names. And stop creating alists for completion tables since lists of strings work just as well. * lisp/calendar/appt.el: Delete redundant `:group` arguments. Prefer #' to quote function names. * lisp/calendar/cal-hebrew.el (solar-time-string): Declare function. (calendar-hebrew-read-date, calendar-hebrew-list-yahrzeits): * lisp/calendar/cal-persia.el (calendar-persian-read-date): * lisp/calendar/cal-mayan.el (calendar-mayan-read-haab-date) (calendar-mayan-read-tzolkin-date): * lisp/calendar/cal-julian.el (calendar-julian-goto-date): * lisp/calendar/cal-islam.el (calendar-islamic-read-date): * lisp/calendar/cal-coptic.el (calendar-coptic-read-date): * lisp/calendar/cal-bahai.el (calendar-bahai-read-date): Completion tables can be lists of strings for decades. * lisp/calendar/cal-china.el: Delete redundant `:group` arguments. (calendar-chinese-zodiac-sign-on-or-after) (calendar-chinese-new-moon-on-or-after): Use lexical dialect also for `eval`. * lisp/calendar/cal-dst.el: Delete redundant `:group` arguments. Use lexical dialect also for `eval`. * lisp/calendar/cal-html.el: Delete redundant `:group` arguments. * lisp/calendar/cal-menu.el: Prefer #' to quote function names. * lisp/calendar/cal-tex.el: Delete redundant `:group` arguments. (cal-tex-weekly-common): Use lexical dialect also for `eval`. * lisp/calendar/calendar.el (calendar-mode-map): Prefer #' to quote function names. * lisp/calendar/diary-icalendar.el (di:rrule-sexp-to-recurrence) (di:other-sexp-to-recurrence): Use lexical dialect also for `eval`. * lisp/calendar/diary-lib.el: Delete redundant `:group` arguments. Prefer #' to quote function names. (diary-sexp-entry, diary-offset, diary-remind): Use lexical dialect also for `eval`. * lisp/calendar/icalendar-macs.el (ical:define-param): Fix misuse of `%s` in `format`. * lisp/calendar/icalendar-parser.el (ical:value-types) (ical:param-types, ical:property-types, ical:component-types): Don't use `defconst` on variables we mutate. * lisp/calendar/icalendar-recur.el (icr:current-tz-to-vtimezone) (icr:current-tz-to-vtimezone): Use lexical dialect also for `eval`. * lisp/calendar/icalendar.el: Delete redundant `:group` arguments. * lisp/calendar/lunar.el: Prefer #' to quote function names. * lisp/calendar/solar.el (solar-sunrise-sunset-string) (calendar-sunrise-sunset-month): Use lexical dialect also for `eval`. * lisp/calendar/timeclock.el: Prefer #' to quote function names. --- lisp/calendar/appt.el | 30 ++-- lisp/calendar/cal-bahai.el | 3 +- lisp/calendar/cal-china.el | 33 ++-- lisp/calendar/cal-coptic.el | 3 +- lisp/calendar/cal-dst.el | 43 ++--- lisp/calendar/cal-french.el | 2 +- lisp/calendar/cal-hebrew.el | 7 +- lisp/calendar/cal-html.el | 20 +-- lisp/calendar/cal-islam.el | 2 +- lisp/calendar/cal-julian.el | 2 +- lisp/calendar/cal-mayan.el | 6 +- lisp/calendar/cal-menu.el | 2 +- lisp/calendar/cal-persia.el | 3 +- lisp/calendar/cal-tex.el | 47 ++---- lisp/calendar/calendar.el | 268 +++++++++++++++--------------- lisp/calendar/diary-icalendar.el | 4 +- lisp/calendar/diary-lib.el | 93 ++++------- lisp/calendar/icalendar-macs.el | 2 +- lisp/calendar/icalendar-parser.el | 8 +- lisp/calendar/icalendar-recur.el | 4 +- lisp/calendar/icalendar.el | 46 ++--- lisp/calendar/lunar.el | 2 +- lisp/calendar/solar.el | 4 +- lisp/calendar/timeclock.el | 6 +- 24 files changed, 275 insertions(+), 365 deletions(-) diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index d6b8621d26b..df8e28319e5 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -81,8 +81,7 @@ (defcustom appt-message-warning-time 12 "Default time in minutes before an appointment that the warning begins. You probably want to make `appt-display-interval' a factor of this." - :type 'integer - :group 'appt) + :type 'integer) (defcustom appt-warning-time-regexp "warntime \\([0-9]+\\)" "Regexp matching a string giving the warning time for an appointment. @@ -92,13 +91,11 @@ You may want to put this inside a diary comment (see `diary-comment-start'). For example, to be warned 30 minutes in advance of an appointment: 2011/06/01 12:00 Do something ## warntime 30" :version "24.1" - :type 'regexp - :group 'appt) + :type 'regexp) (defcustom appt-audible t "Non-nil means beep to indicate appointment." - :type 'boolean - :group 'appt) + :type 'boolean) ;; TODO - add popup. (defcustom appt-display-format 'window @@ -112,7 +109,6 @@ See also `appt-audible' and `appt-display-mode-line'." (const :tag "Separate window" window) (const :tag "Echo-area" echo) (const :tag "No visible display" nil)) - :group 'appt :version "24.1") ; no longer inherit from deleted obsolete variables (defcustom appt-display-mode-line t @@ -120,21 +116,18 @@ See also `appt-audible' and `appt-display-mode-line'." This is in addition to any other display of appointment messages. The mode line updates every minute, independent of the value of `appt-display-interval'." - :type 'boolean - :group 'appt) + :type 'boolean) (defcustom appt-display-duration 10 "The number of seconds an appointment message is displayed. Only relevant if reminders are to be displayed in their own window." - :type 'integer - :group 'appt) + :type 'integer) (defcustom appt-display-diary t "Non-nil displays the diary when the appointment list is first initialized. This occurs when this package is first activated, and then at midnight when the appointment list updates." - :type 'boolean - :group 'appt) + :type 'boolean) (defcustom appt-display-interval 3 "Interval in minutes at which to display appointment reminders. @@ -146,8 +139,7 @@ a final message displayed precisely when the appointment is due. Note that this variable controls the interval at which `appt-display-message' is called. The mode line display (if active) always updates every minute." - :type 'integer - :group 'appt) + :type 'integer) (defcustom appt-disp-window-function #'appt-disp-window "Function called to display appointment window. @@ -156,14 +148,12 @@ It should take three string arguments: the number of minutes till the appointment, the current time, and the text of the appointment. Each argument may also be a list, if multiple appointments are relevant at any one time." - :type 'function - :group 'appt) + :type 'function) (defcustom appt-delete-window-function #'appt-delete-window "Function called to remove appointment window and buffer. Only relevant if reminders are being displayed in a window." - :type 'function - :group 'appt) + :type 'function) (defface appt-notification '((t :inherit mode-line-emphasis)) @@ -602,7 +592,7 @@ Any appointments made with `appt-add' are not affected by this function." (not (eq diary-number-of-entries 1)) (not (memq (car (last diary-list-entries-hook)) '(diary-sort-entries sort-diary-entries))) - (setq entry-list (sort entry-list 'diary-entry-compare))) + (setq entry-list (sort entry-list #'diary-entry-compare))) ;; Skip diary entries for dates before today. (while (and entry-list (calendar-date-compare diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index ad0379bb731..8afa4046c4e 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -368,8 +368,7 @@ Reads a year, month and day." (month (cdr (assoc (completing-read "Bahá’í calendar month name: " - (mapcar 'list - (append calendar-bahai-month-name-array nil)) + (append calendar-bahai-month-name-array nil) nil t) (calendar-make-alist calendar-bahai-month-name-array 1)))) diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index af470030499..cadbd6f937f 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -65,8 +65,7 @@ "Minutes difference between local standard time for Chinese calendar and UTC. Default is for Beijing. This is an expression in `year' since it changed at 1928-01-01 00:00:00 from UT+7:45:40 to UT+8." - :type 'sexp - :group 'calendar-chinese) + :type 'sexp) ;; It gets eval'd. ;;;###autoload @@ -75,8 +74,7 @@ Default is for Beijing. This is an expression in `year' since it changed at ;; FIXME unused. (defcustom calendar-chinese-location-name "Beijing" "Name of location used for calculation of Chinese calendar." - :type 'string - :group 'calendar-chinese) + :type 'string) (defcustom calendar-chinese-daylight-time-offset 0 ;; The correct value is as follows, but the Chinese calendrical @@ -84,8 +82,7 @@ Default is for Beijing. This is an expression in `year' since it changed at ;; 60 "Minutes difference between daylight saving and standard time. Default is for no daylight saving time." - :type 'integer - :group 'calendar-chinese) + :type 'integer) (defcustom calendar-chinese-standard-time-zone-name '(if (< year 1928) @@ -95,13 +92,11 @@ Default is for no daylight saving time." This is an expression depending on `year' because it changed at 1928-01-01 00:00:00 from `PMT' to `CST'." :type 'sexp - :risky t - :group 'calendar-chinese) + :risky t) (defcustom calendar-chinese-daylight-time-zone-name "CDT" "Abbreviated name of daylight saving time zone used for Chinese calendar." - :type 'string - :group 'calendar-chinese) + :type 'string) (defcustom calendar-chinese-daylight-saving-start nil ;; The correct value is as follows, but the Chinese calendrical @@ -113,8 +108,7 @@ at 1928-01-01 00:00:00 from `PMT' to `CST'." Default is for no daylight saving time. See documentation of `calendar-daylight-savings-starts'." :type 'sexp - :risky t - :group 'calendar-chinese) + :risky t) (defcustom calendar-chinese-daylight-saving-end nil ;; The correct value is as follows, but the Chinese calendrical @@ -124,25 +118,21 @@ Default is for no daylight saving time. See documentation of Default is for no daylight saving time. See documentation of `calendar-daylight-savings-ends'." :type 'sexp - :risky t - :group 'calendar-chinese) + :risky t) (defcustom calendar-chinese-daylight-saving-start-time 0 "Number of minutes after midnight that daylight saving time starts. Default is for no daylight saving time." - :type 'integer - :group 'calendar-chinese) + :type 'integer) (defcustom calendar-chinese-daylight-saving-end-time 0 "Number of minutes after midnight that daylight saving time ends. Default is for no daylight saving time." - :type 'integer - :group 'calendar-chinese) + :type 'integer) (defcustom calendar-chinese-celestial-stem ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"] "Prefixes used by `calendar-chinese-sexagesimal-name'." - :group 'calendar-chinese :type '(vector (string :tag "Jia") (string :tag "Yi") (string :tag "Bing") @@ -157,7 +147,6 @@ Default is for no daylight saving time." (defcustom calendar-chinese-terrestrial-branch ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"] "Suffixes used by `calendar-chinese-sexagesimal-name'." - :group 'calendar-chinese :type '(vector (string :tag "Zi") (string :tag "Chou") (string :tag "Yin") @@ -188,7 +177,7 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." (with-suppressed-warnings ((lexical year)) (defvar year)) (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) - (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year + (calendar-time-zone (eval calendar-chinese-time-zone t)) ; uses year (calendar-daylight-time-offset calendar-chinese-daylight-time-offset) (calendar-standard-time-zone-name @@ -212,7 +201,7 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." (with-suppressed-warnings ((lexical year)) (defvar year)) (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) - (calendar-time-zone (eval calendar-chinese-time-zone)) + (calendar-time-zone (eval calendar-chinese-time-zone t)) (calendar-daylight-time-offset calendar-chinese-daylight-time-offset) (calendar-standard-time-zone-name diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 9696a484224..2878c35bb7c 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -148,8 +148,7 @@ Reads a year, month, and day." (month (cdr (assoc-string (completing-read (format "%s calendar month name: " calendar-coptic-name) - (mapcar 'list - (append calendar-coptic-month-name-array nil)) + (append calendar-coptic-month-name-array nil) nil t) (calendar-make-alist calendar-coptic-month-name-array 1) diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 5476a59d38c..7681059f592 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -46,8 +46,7 @@ current date apply to all years. This is faster, but not always correct, since the dates of daylight saving transitions sometimes change." :type 'boolean - :version "22.1" - :group 'calendar-dst) + :version "22.1") ;;;###autoload (put 'calendar-daylight-savings-starts 'risky-local-variable t) @@ -68,8 +67,7 @@ If it starts on the first Sunday in April, you would set it to (calendar-nth-named-day 1 0 4 year) If the locale never uses daylight saving time, set this to nil." - :type 'sexp - :group 'calendar-dst) + :type 'sexp) ;;;###autoload (put 'calendar-daylight-savings-ends 'risky-local-variable t) @@ -85,8 +83,7 @@ For example, if daylight saving time ends on the last Sunday in October: (calendar-nth-named-day -1 0 10 year) If the locale never uses daylight saving time, set this to nil." - :type 'sexp - :group 'calendar-dst) + :type 'sexp) ;;; More defcustoms below. @@ -208,10 +205,12 @@ The result has the proper form for `calendar-daylight-savings-starts'." ;; we require an absolute date. The following is for efficiency. (setq date (cond ((eq (car rule) #'calendar-nth-named-day) (eval (cons #'calendar-nth-named-absday - (cdr rule)))) + (cdr rule)) + t)) ((eq (car rule) #'calendar-gregorian-from-absolute) - (eval (cadr rule))) - (t (calendar-absolute-from-gregorian (eval rule))))) + (eval (cadr rule) t)) + (t (calendar-absolute-from-gregorian + (eval rule t))))) (or (equal (current-time-zone (calendar-time-from-absolute date prevday-sec)) (current-time-zone @@ -341,15 +340,13 @@ it can't find." (defcustom calendar-time-zone (or (car calendar-current-time-zone-cache) -300) "Number of minutes difference between local standard time and UTC. For example, -300 for New York City, -480 for Los Angeles." - :type 'integer - :group 'calendar-dst) + :type 'integer) (defcustom calendar-daylight-time-offset (or (cadr calendar-current-time-zone-cache) 60) "Number of minutes difference between daylight saving and standard time. If the locale never uses daylight saving time, set this to 0." - :type 'integer - :group 'calendar-dst) + :type 'integer) (defcustom calendar-standard-time-zone-name (if (eq calendar-time-zone-style 'numeric) @@ -362,8 +359,7 @@ If the locale never uses daylight saving time, set this to 0." For example, \"-0500\" or \"EST\" in New York City." :type 'string :version "28.1" - :set-after '(calendar-time-zone-style) - :group 'calendar-dst) + :set-after '(calendar-time-zone-style)) (defcustom calendar-daylight-time-zone-name (if (eq calendar-time-zone-style 'numeric) @@ -376,21 +372,18 @@ For example, \"-0500\" or \"EST\" in New York City." For example, \"-0400\" or \"EDT\" in New York City." :type 'string :version "28.1" - :set-after '(calendar-time-zone-style) - :group 'calendar-dst) + :set-after '(calendar-time-zone-style)) (defcustom calendar-daylight-savings-starts-time (or (nth 6 calendar-current-time-zone-cache) 120) "Number of minutes after midnight that daylight saving time starts." - :type 'integer - :group 'calendar-dst) + :type 'integer) (defcustom calendar-daylight-savings-ends-time (or (nth 7 calendar-current-time-zone-cache) calendar-daylight-savings-starts-time) "Number of minutes after midnight that daylight saving time ends." - :type 'integer - :group 'calendar-dst) + :type 'integer) (defun calendar-dst-starts (year) @@ -400,7 +393,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (cadr (calendar-dst-find-startend year)) (nth 4 calendar-current-time-zone-cache)))) (calendar-dlet ((year year)) - (if expr (eval expr)))) + (if expr (eval expr t)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 2 0 3 year)))) @@ -412,7 +405,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (nth 2 (calendar-dst-find-startend year)) (nth 5 calendar-current-time-zone-cache)))) (calendar-dlet ((year year)) - (if expr (eval expr)))) + (if expr (eval expr t)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 1 0 11 year)))) @@ -423,8 +416,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." Fractional part of DATE is local standard time of day." (calendar-dlet ((year (calendar-extract-year (calendar-gregorian-from-absolute (floor date))))) - (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts)) - (dst-ends-gregorian (eval calendar-daylight-savings-ends)) + (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts t)) + (dst-ends-gregorian (eval calendar-daylight-savings-ends t)) (dst-starts (and dst-starts-gregorian (+ (calendar-absolute-from-gregorian dst-starts-gregorian) diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index 061ab4ebafa..28cb2515a86 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -344,7 +344,7 @@ Echo French Revolutionary date unless NOECHO is non-nil." (calendar-absolute-from-gregorian (calendar-current-date))))))) (month-list - (mapcar 'list + (mapcar #'list (append months (if (calendar-french-leap-year-p year) (mapcar #'calendar-french-trim-feast feasts) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 213afc1d3ba..714f18999fa 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -238,7 +238,7 @@ Reads a year, month, and day." (month (cdr (assoc-string (completing-read "Hebrew calendar month name: " - (mapcar 'list (append month-array nil)) + (append month-array nil) (if (= year 3761) (lambda (x) (let ((m (cdr @@ -691,7 +691,7 @@ from the cursor position." (month (cdr (assoc-string (completing-read "Month of death (name): " - (mapcar 'list (append month-array nil)) + (append month-array nil) nil t) (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year)) @@ -1123,6 +1123,7 @@ use when highlighting the day in the calendar." (declare-function solar-setup "solar" ()) (declare-function solar-sunrise-sunset "solar" (date)) +(declare-function solar-time-string "solar" (time time-zone)) (defvar calendar-latitude) (defvar calendar-longitude) (defvar calendar-time-zone) @@ -1145,7 +1146,7 @@ use when highlighting the day in the calendar." (if sunset (cons mark (format "%s Sabbath candle lighting" - (apply 'solar-time-string + (apply #'solar-time-string (cons (- (car sunset) (/ diary-hebrew-sabbath-candles-minutes 60.0)) diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el index 06729743243..6e5e42e8f7f 100644 --- a/lisp/calendar/cal-html.el +++ b/lisp/calendar/cal-html.el @@ -42,18 +42,15 @@ (defcustom cal-html-directory "~/public_html" "Directory for HTML pages generated by cal-html." - :type 'string - :group 'calendar-html) + :type 'string) (defcustom cal-html-print-day-number-flag nil "Non-nil means print the day-of-the-year number in the monthly cal-html page." - :type 'boolean - :group 'calendar-html) + :type 'boolean) (defcustom cal-html-year-index-cols 3 "Number of columns in the cal-html yearly index page." - :type 'integer - :group 'calendar-html) + :type 'integer) (defcustom cal-html-day-abbrev-array calendar-day-abbrev-array "Array of seven strings for abbreviated day names (starting with Sunday)." @@ -64,14 +61,12 @@ (string :tag "Wed") (string :tag "Thu") (string :tag "Fri") - (string :tag "Sat")) - :group 'calendar-html) + (string :tag "Sat"))) (defcustom cal-html-holidays t "If non-nil, include holidays as well as diary entries." :version "24.3" - :type 'boolean - :group 'calendar-html) + :type 'boolean) (defcustom cal-html-css-default (concat @@ -93,8 +88,7 @@ "\n\n") "Default cal-html css style. You can override this with a \"cal.css\" file." :type 'string - :version "24.3" ; added SPAN.HOLIDAY - :group 'calendar-html) + :version "24.3") ; Added SPAN.HOLIDAY. ;;; End customizable variables. @@ -317,7 +311,7 @@ There are 12/cols rows of COLS months each." Characters are replaced according to `cal-html-html-subst-list'." (if (stringp string) (replace-regexp-in-string - (regexp-opt (mapcar 'car cal-html-html-subst-list)) + (regexp-opt (mapcar #'car cal-html-html-subst-list)) (lambda (x) (cdr (assoc x cal-html-html-subst-list))) string) diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index 79cbad2c61a..49da71adac4 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -154,7 +154,7 @@ Reads a year, month, and day." (month (cdr (assoc-string (completing-read "Islamic calendar month name: " - (mapcar 'list (append month-array nil)) + (append month-array nil) nil t) (calendar-make-alist month-array 1) t))) (last (calendar-islamic-last-day-of-month month year)) diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 0977b14b2e6..7597f36b62f 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -107,7 +107,7 @@ Driven by the variable `calendar-date-display-form'." (month (cdr (assoc-string (completing-read "Julian calendar month name: " - (mapcar 'list (append month-array nil)) + (append month-array nil) nil t) (calendar-make-alist month-array 1) t))) (last diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index df4ebe873f9..886e92a859d 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -70,7 +70,7 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (defun calendar-mayan-long-count-to-string (mayan-long-count) "Convert MAYAN-LONG-COUNT into traditional written form." - (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) + (apply #'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) (defun calendar-mayan-string-from-long-count (str) "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers." @@ -144,7 +144,7 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (haab-month (cdr (assoc-string (completing-read "Haab uinal: " - (mapcar 'list haab-month-list) + haab-month-list nil t) (calendar-make-alist haab-month-list 1) t)))) (cons haab-day haab-month))) @@ -160,7 +160,7 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (tzolkin-name (cdr (assoc-string (completing-read "Tzolkin uinal: " - (mapcar 'list tzolkin-name-list) + tzolkin-name-list nil t) (calendar-make-alist tzolkin-name-list 1) t)))) (cons tzolkin-count tzolkin-name))) diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index 68c6abdd8d8..a95c1c882b4 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -206,7 +206,7 @@ is non-nil." (if holidays (list "--shadow-etched-in" "--shadow-etched-in")) (if diary-entries - (mapcar 'list (apply 'append diary-entries)) + (mapcar #'list (apply #'append diary-entries)) '("None"))))) (and selection (call-interactively selection)))) diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index 9f59a75f952..df0a11160fb 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -169,8 +169,7 @@ Reads a year, month, and day." (month (cdr (assoc (completing-read "Persian calendar month name: " - (mapcar 'list - (append calendar-persian-month-name-array nil)) + (append calendar-persian-month-name-array nil) nil t) (calendar-make-alist calendar-persian-month-name-array 1)))) diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el index bf0ff100be3..166aa4658e2 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el @@ -72,26 +72,22 @@ "The days of the week that are displayed on the portrait monthly calendar. Sunday is 0, Monday is 1, and so on. The default is to print from Sunday to Saturday. For example, (1 3 5) prints only Monday, Wednesday, Friday." - :type '(repeat integer) - :group 'calendar-tex) + :type '(repeat integer)) (defcustom cal-tex-holidays t "Non-nil means holidays are printed in the LaTeX calendars that support it. Setting this to nil may speed up calendar generation." - :type 'boolean - :group 'calendar-tex) + :type 'boolean) (defcustom cal-tex-diary nil "Non-nil means diary entries are printed in LaTeX calendars that support it. Setting this to nil may speed up calendar generation." - :type 'boolean - :group 'calendar-tex) + :type 'boolean) (defcustom cal-tex-rules nil "Non-nil means pages will be ruled in some LaTeX calendar styles. At present, this only affects the daily filofax calendar." - :type 'boolean - :group 'calendar-tex) + :type 'boolean) (defcustom cal-tex-daily-string '(let* ((year (calendar-extract-year date)) @@ -112,30 +108,25 @@ days remaining. As an example, setting this to (calendar-hebrew-date-string date) will put the Hebrew date at the bottom of each day." - :type 'sexp - :group 'calendar-tex) + :type 'sexp) (defcustom cal-tex-buffer "calendar.tex" "The name for the output LaTeX calendar buffer." - :type 'string - :group 'calendar-tex) + :type 'string) (defcustom cal-tex-24 nil "Non-nil means use a 24 hour clock in the daily calendar." - :type 'boolean - :group 'calendar-tex) + :type 'boolean) (defcustom cal-tex-daily-start 8 "The first hour of the daily LaTeX calendar page. At present, this only affects `cal-tex-cursor-day'." - :type 'integer - :group 'calendar-tex) + :type 'integer) (defcustom cal-tex-daily-end 20 "The last hour of the daily LaTeX calendar page. At present, this only affects `cal-tex-cursor-day'." - :type 'integer - :group 'calendar-tex) + :type 'integer) (defcustom cal-tex-preamble-extra nil "A string giving extra LaTeX commands to insert in the calendar preamble. @@ -144,7 +135,6 @@ For example, to include extra packages: :type '(choice (const nil) ;; An example to help people format things in custom. (string :value "\\usepackage{foo}\n\\usepackage{bar}\n")) - :group 'calendar-tex :version "22.1") (defcustom cal-tex-hook nil @@ -153,28 +143,23 @@ You can use this to do post-processing on the buffer. For example, to change characters with diacritical marks to their LaTeX equivalents, use (add-hook \\='cal-tex-hook (lambda () (iso-iso2tex (point-min) (point-max))))" - :type 'hook - :group 'calendar-tex) + :type 'hook) (defcustom cal-tex-year-hook nil "List of functions called after a LaTeX year calendar buffer is generated." - :type 'hook - :group 'calendar-tex) + :type 'hook) (defcustom cal-tex-month-hook nil "List of functions called after a LaTeX month calendar buffer is generated." - :type 'hook - :group 'calendar-tex) + :type 'hook) (defcustom cal-tex-week-hook nil "List of functions called after a LaTeX week calendar buffer is generated." - :type 'hook - :group 'calendar-tex) + :type 'hook) (defcustom cal-tex-daily-hook nil "List of functions called after a LaTeX daily calendar buffer is generated." - :type 'hook - :group 'calendar-tex) + :type 'hook) ;;; ;;; Definitions for LaTeX code @@ -1227,7 +1212,7 @@ shown are hard-coded to 8-12, 13-17." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (dotimes (_jdummy 2) @@ -1236,7 +1221,7 @@ shown are hard-coded to 8-12, 13-17." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (unless (= i (1- n)) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 67b40e27782..2e90d6e4639 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1662,143 +1662,143 @@ Otherwise, use the selected window of EVENT's frame." mark-defun mark-whole-buffer mark-page downcase-region upcase-region kill-region copy-region-as-kill capitalize-region write-region)) - (define-key map (vector 'remap c) 'calendar-not-implemented)) - (define-key map "<" 'calendar-scroll-right) - (define-key map "\C-x<" 'calendar-scroll-right) - (define-key map [S-wheel-up] 'calendar-scroll-right) - (define-key map [prior] 'calendar-scroll-right-three-months) - (define-key map "\ev" 'calendar-scroll-right-three-months) - (define-key map [wheel-up] 'calendar-scroll-right-three-months) - (define-key map [M-wheel-up] 'calendar-backward-year) - (define-key map ">" 'calendar-scroll-left) - (define-key map "\C-x>" 'calendar-scroll-left) - (define-key map [S-wheel-down] 'calendar-scroll-left) - (define-key map [next] 'calendar-scroll-left-three-months) - (define-key map "\C-v" 'calendar-scroll-left-three-months) - (define-key map [wheel-down] 'calendar-scroll-left-three-months) - (define-key map [M-wheel-down] 'calendar-forward-year) - (define-key map "\C-l" 'calendar-recenter) - (define-key map "\C-b" 'calendar-backward-day) - (define-key map "\C-p" 'calendar-backward-week) - (define-key map "\e{" 'calendar-backward-month) - (define-key map "{" 'calendar-backward-month) - (define-key map "\C-x[" 'calendar-backward-year) - (define-key map "[" 'calendar-backward-year) - (define-key map "\C-f" 'calendar-forward-day) - (define-key map "\C-n" 'calendar-forward-week) - (define-key map [left] 'calendar-backward-day) - (define-key map [up] 'calendar-backward-week) - (define-key map [right] 'calendar-forward-day) - (define-key map [down] 'calendar-forward-week) - (define-key map "\e}" 'calendar-forward-month) - (define-key map "}" 'calendar-forward-month) - (define-key map "\C-x]" 'calendar-forward-year) - (define-key map "]" 'calendar-forward-year) - (define-key map "\C-a" 'calendar-beginning-of-week) - (define-key map "\C-e" 'calendar-end-of-week) - (define-key map "\ea" 'calendar-beginning-of-month) - (define-key map "\ee" 'calendar-end-of-month) - (define-key map "\e<" 'calendar-beginning-of-year) - (define-key map "\e>" 'calendar-end-of-year) - (define-key map "\C-@" 'calendar-set-mark) + (define-key map (vector 'remap c) #'calendar-not-implemented)) + (define-key map "<" #'calendar-scroll-right) + (define-key map "\C-x<" #'calendar-scroll-right) + (define-key map [S-wheel-up] #'calendar-scroll-right) + (define-key map [prior] #'calendar-scroll-right-three-months) + (define-key map "\ev" #'calendar-scroll-right-three-months) + (define-key map [wheel-up] #'calendar-scroll-right-three-months) + (define-key map [M-wheel-up] #'calendar-backward-year) + (define-key map ">" #'calendar-scroll-left) + (define-key map "\C-x>" #'calendar-scroll-left) + (define-key map [S-wheel-down] #'calendar-scroll-left) + (define-key map [next] #'calendar-scroll-left-three-months) + (define-key map "\C-v" #'calendar-scroll-left-three-months) + (define-key map [wheel-down] #'calendar-scroll-left-three-months) + (define-key map [M-wheel-down] #'calendar-forward-year) + (define-key map "\C-l" #'calendar-recenter) + (define-key map "\C-b" #'calendar-backward-day) + (define-key map "\C-p" #'calendar-backward-week) + (define-key map "\e{" #'calendar-backward-month) + (define-key map "{" #'calendar-backward-month) + (define-key map "\C-x[" #'calendar-backward-year) + (define-key map "[" #'calendar-backward-year) + (define-key map "\C-f" #'calendar-forward-day) + (define-key map "\C-n" #'calendar-forward-week) + (define-key map [left] #'calendar-backward-day) + (define-key map [up] #'calendar-backward-week) + (define-key map [right] #'calendar-forward-day) + (define-key map [down] #'calendar-forward-week) + (define-key map "\e}" #'calendar-forward-month) + (define-key map "}" #'calendar-forward-month) + (define-key map "\C-x]" #'calendar-forward-year) + (define-key map "]" #'calendar-forward-year) + (define-key map "\C-a" #'calendar-beginning-of-week) + (define-key map "\C-e" #'calendar-end-of-week) + (define-key map "\ea" #'calendar-beginning-of-month) + (define-key map "\ee" #'calendar-end-of-month) + (define-key map "\e<" #'calendar-beginning-of-year) + (define-key map "\e>" #'calendar-end-of-year) + (define-key map "\C-@" #'calendar-set-mark) ;; Many people are used to typing C-SPC and getting C-@. - (define-key map [?\C-\s] 'calendar-set-mark) - (define-key map "\C-x\C-x" 'calendar-exchange-point-and-mark) - (define-key map "\e=" 'calendar-count-days-region) - (define-key map "gd" 'calendar-goto-date) - (define-key map "gD" 'calendar-goto-day-of-year) - (define-key map "gj" 'calendar-julian-goto-date) - (define-key map "ga" 'calendar-astro-goto-day-number) - (define-key map "gh" 'calendar-hebrew-goto-date) - (define-key map "gi" 'calendar-islamic-goto-date) - (define-key map "gb" 'calendar-bahai-goto-date) - (define-key map "gC" 'calendar-chinese-goto-date) - (define-key map "gk" 'calendar-coptic-goto-date) - (define-key map "ge" 'calendar-ethiopic-goto-date) - (define-key map "gp" 'calendar-persian-goto-date) - (define-key map "gc" 'calendar-iso-goto-date) - (define-key map "gw" 'calendar-iso-goto-week) - (define-key map "gf" 'calendar-french-goto-date) - (define-key map "gml" 'calendar-mayan-goto-long-count-date) - (define-key map "gmpc" 'calendar-mayan-previous-round-date) - (define-key map "gmnc" 'calendar-mayan-next-round-date) - (define-key map "gmph" 'calendar-mayan-previous-haab-date) - (define-key map "gmnh" 'calendar-mayan-next-haab-date) - (define-key map "gmpt" 'calendar-mayan-previous-tzolkin-date) - (define-key map "gmnt" 'calendar-mayan-next-tzolkin-date) - (define-key map "Aa" 'appt-add) + (define-key map [?\C-\s] #'calendar-set-mark) + (define-key map "\C-x\C-x" #'calendar-exchange-point-and-mark) + (define-key map "\e=" #'calendar-count-days-region) + (define-key map "gd" #'calendar-goto-date) + (define-key map "gD" #'calendar-goto-day-of-year) + (define-key map "gj" #'calendar-julian-goto-date) + (define-key map "ga" #'calendar-astro-goto-day-number) + (define-key map "gh" #'calendar-hebrew-goto-date) + (define-key map "gi" #'calendar-islamic-goto-date) + (define-key map "gb" #'calendar-bahai-goto-date) + (define-key map "gC" #'calendar-chinese-goto-date) + (define-key map "gk" #'calendar-coptic-goto-date) + (define-key map "ge" #'calendar-ethiopic-goto-date) + (define-key map "gp" #'calendar-persian-goto-date) + (define-key map "gc" #'calendar-iso-goto-date) + (define-key map "gw" #'calendar-iso-goto-week) + (define-key map "gf" #'calendar-french-goto-date) + (define-key map "gml" #'calendar-mayan-goto-long-count-date) + (define-key map "gmpc" #'calendar-mayan-previous-round-date) + (define-key map "gmnc" #'calendar-mayan-next-round-date) + (define-key map "gmph" #'calendar-mayan-previous-haab-date) + (define-key map "gmnh" #'calendar-mayan-next-haab-date) + (define-key map "gmpt" #'calendar-mayan-previous-tzolkin-date) + (define-key map "gmnt" #'calendar-mayan-next-tzolkin-date) + (define-key map "Aa" #'appt-add) (define-key map "Ad" 'appt-delete) - (define-key map "S" 'calendar-sunrise-sunset) - (define-key map "M" 'calendar-lunar-phases) - (define-key map " " 'scroll-other-window) - (define-key map [?\S-\ ] 'scroll-other-window-down) - (define-key map "\d" 'scroll-other-window-down) - (define-key map "\C-c\C-l" 'calendar-redraw) - (define-key map "." 'calendar-goto-today) - (define-key map "o" 'calendar-other-month) - (define-key map "q" 'calendar-exit) - (define-key map "a" 'calendar-list-holidays) - (define-key map "h" 'calendar-cursor-holidays) - (define-key map "x" 'calendar-mark-holidays) - (define-key map "u" 'calendar-unmark) - (define-key map "m" 'diary-mark-entries) - (define-key map "d" 'diary-view-entries) - (define-key map "D" 'diary-view-other-diary-entries) - (define-key map "s" 'diary-show-all-entries) - (define-key map "pd" 'calendar-print-day-of-year) - (define-key map "pC" 'calendar-chinese-print-date) - (define-key map "pk" 'calendar-coptic-print-date) - (define-key map "pe" 'calendar-ethiopic-print-date) - (define-key map "pp" 'calendar-persian-print-date) - (define-key map "pc" 'calendar-iso-print-date) - (define-key map "pj" 'calendar-julian-print-date) - (define-key map "pa" 'calendar-astro-print-day-number) - (define-key map "ph" 'calendar-hebrew-print-date) - (define-key map "pi" 'calendar-islamic-print-date) - (define-key map "pb" 'calendar-bahai-print-date) - (define-key map "pf" 'calendar-french-print-date) - (define-key map "pm" 'calendar-mayan-print-date) - (define-key map "po" 'calendar-print-other-dates) - (define-key map "id" 'diary-insert-entry) - (define-key map "iw" 'diary-insert-weekly-entry) - (define-key map "im" 'diary-insert-monthly-entry) - (define-key map "iy" 'diary-insert-yearly-entry) - (define-key map "ia" 'diary-insert-anniversary-entry) - (define-key map "ib" 'diary-insert-block-entry) - (define-key map "ic" 'diary-insert-cyclic-entry) - (define-key map "ihd" 'diary-hebrew-insert-entry) - (define-key map "ihm" 'diary-hebrew-insert-monthly-entry) - (define-key map "ihy" 'diary-hebrew-insert-yearly-entry) - (define-key map "iid" 'diary-islamic-insert-entry) - (define-key map "iim" 'diary-islamic-insert-monthly-entry) - (define-key map "iiy" 'diary-islamic-insert-yearly-entry) - (define-key map "iBd" 'diary-bahai-insert-entry) - (define-key map "iBm" 'diary-bahai-insert-monthly-entry) - (define-key map "iBy" 'diary-bahai-insert-yearly-entry) - (define-key map "iCd" 'diary-chinese-insert-entry) - (define-key map "iCm" 'diary-chinese-insert-monthly-entry) - (define-key map "iCy" 'diary-chinese-insert-yearly-entry) - (define-key map "iCa" 'diary-chinese-insert-anniversary-entry) - (define-key map "?" 'calendar-goto-info-node) - (define-key map "Hm" 'cal-html-cursor-month) - (define-key map "Hy" 'cal-html-cursor-year) - (define-key map "tm" 'cal-tex-cursor-month) - (define-key map "tM" 'cal-tex-cursor-month-landscape) - (define-key map "td" 'cal-tex-cursor-day) - (define-key map "tw1" 'cal-tex-cursor-week) - (define-key map "tw2" 'cal-tex-cursor-week2) - (define-key map "tw3" 'cal-tex-cursor-week-iso) ; FIXME twi ? - (define-key map "tw4" 'cal-tex-cursor-week-monday) ; twm ? - (define-key map "twW" 'cal-tex-cursor-week2-summary) - (define-key map "tfd" 'cal-tex-cursor-filofax-daily) - (define-key map "tfw" 'cal-tex-cursor-filofax-2week) - (define-key map "tfW" 'cal-tex-cursor-filofax-week) - (define-key map "tfy" 'cal-tex-cursor-filofax-year) - (define-key map "ty" 'cal-tex-cursor-year) - (define-key map "tY" 'cal-tex-cursor-year-landscape) + (define-key map "S" #'calendar-sunrise-sunset) + (define-key map "M" #'calendar-lunar-phases) + (define-key map " " #'scroll-other-window) + (define-key map [?\S-\ ] #'scroll-other-window-down) + (define-key map "\d" #'scroll-other-window-down) + (define-key map "\C-c\C-l" #'calendar-redraw) + (define-key map "." #'calendar-goto-today) + (define-key map "o" #'calendar-other-month) + (define-key map "q" #'calendar-exit) + (define-key map "a" #'calendar-list-holidays) + (define-key map "h" #'calendar-cursor-holidays) + (define-key map "x" #'calendar-mark-holidays) + (define-key map "u" #'calendar-unmark) + (define-key map "m" #'diary-mark-entries) + (define-key map "d" #'diary-view-entries) + (define-key map "D" #'diary-view-other-diary-entries) + (define-key map "s" #'diary-show-all-entries) + (define-key map "pd" #'calendar-print-day-of-year) + (define-key map "pC" #'calendar-chinese-print-date) + (define-key map "pk" #'calendar-coptic-print-date) + (define-key map "pe" #'calendar-ethiopic-print-date) + (define-key map "pp" #'calendar-persian-print-date) + (define-key map "pc" #'calendar-iso-print-date) + (define-key map "pj" #'calendar-julian-print-date) + (define-key map "pa" #'calendar-astro-print-day-number) + (define-key map "ph" #'calendar-hebrew-print-date) + (define-key map "pi" #'calendar-islamic-print-date) + (define-key map "pb" #'calendar-bahai-print-date) + (define-key map "pf" #'calendar-french-print-date) + (define-key map "pm" #'calendar-mayan-print-date) + (define-key map "po" #'calendar-print-other-dates) + (define-key map "id" #'diary-insert-entry) + (define-key map "iw" #'diary-insert-weekly-entry) + (define-key map "im" #'diary-insert-monthly-entry) + (define-key map "iy" #'diary-insert-yearly-entry) + (define-key map "ia" #'diary-insert-anniversary-entry) + (define-key map "ib" #'diary-insert-block-entry) + (define-key map "ic" #'diary-insert-cyclic-entry) + (define-key map "ihd" #'diary-hebrew-insert-entry) + (define-key map "ihm" #'diary-hebrew-insert-monthly-entry) + (define-key map "ihy" #'diary-hebrew-insert-yearly-entry) + (define-key map "iid" #'diary-islamic-insert-entry) + (define-key map "iim" #'diary-islamic-insert-monthly-entry) + (define-key map "iiy" #'diary-islamic-insert-yearly-entry) + (define-key map "iBd" #'diary-bahai-insert-entry) + (define-key map "iBm" #'diary-bahai-insert-monthly-entry) + (define-key map "iBy" #'diary-bahai-insert-yearly-entry) + (define-key map "iCd" #'diary-chinese-insert-entry) + (define-key map "iCm" #'diary-chinese-insert-monthly-entry) + (define-key map "iCy" #'diary-chinese-insert-yearly-entry) + (define-key map "iCa" #'diary-chinese-insert-anniversary-entry) + (define-key map "?" #'calendar-goto-info-node) + (define-key map "Hm" #'cal-html-cursor-month) + (define-key map "Hy" #'cal-html-cursor-year) + (define-key map "tm" #'cal-tex-cursor-month) + (define-key map "tM" #'cal-tex-cursor-month-landscape) + (define-key map "td" #'cal-tex-cursor-day) + (define-key map "tw1" #'cal-tex-cursor-week) + (define-key map "tw2" #'cal-tex-cursor-week2) + (define-key map "tw3" #'cal-tex-cursor-week-iso) ; FIXME twi ? + (define-key map "tw4" #'cal-tex-cursor-week-monday) ; twm ? + (define-key map "twW" #'cal-tex-cursor-week2-summary) + (define-key map "tfd" #'cal-tex-cursor-filofax-daily) + (define-key map "tfw" #'cal-tex-cursor-filofax-2week) + (define-key map "tfW" #'cal-tex-cursor-filofax-week) + (define-key map "tfy" #'cal-tex-cursor-filofax-year) + (define-key map "ty" #'cal-tex-cursor-year) + (define-key map "tY" #'cal-tex-cursor-year-landscape) - (define-key map [menu-bar edit] 'undefined) - (define-key map [menu-bar search] 'undefined) + (define-key map [menu-bar edit] #'undefined) + (define-key map [menu-bar search] #'undefined) (easy-menu-define nil map nil cal-menu-sunmoon-menu) (easy-menu-define nil map nil cal-menu-diary-menu) diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index c15e2cdbddf..4f1b9b4114a 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -2860,7 +2860,7 @@ times according to `diary-icalendar-time-zone-export-strategy'." (exdates (mapcar (lambda (dt) (di:convert-time-via-strategy dt vtimezone)) (if (eq 'quote (car excluded)) (eval excluded nil) excluded))) - (duration (eval (plist-get args :duration))) + (duration (eval (plist-get args :duration) t)) (dur-value (if (eq 'quote (car duration)) (eval duration nil) duration)) (tzid @@ -3030,7 +3030,7 @@ property and must be present even if the recurrence set is empty.)" dtstart rdates exdates) (dolist (absdate (number-sequence today end)) (calendar-dlet ((date (calendar-gregorian-from-absolute absdate))) - (when (eval sexp) + (when (eval sexp t) (push date rdates)))) (if rdates (progn diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index cd179439fae..a7ae6532287 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -38,15 +38,13 @@ (defcustom diary-include-string "#include" "The string indicating inclusion of another file of diary entries. See the documentation for the function `diary-include-other-diary-files'." - :type 'string - :group 'diary) + :type 'string) (defcustom diary-list-include-blanks nil "If nil, do not include days with no diary entry in the list of diary entries. Such days will then not be shown in the fancy diary buffer, even if they are holidays." - :type 'boolean - :group 'diary) + :type 'boolean) (defface diary-anniversary '((t :inherit font-lock-keyword-face)) "Face used for anniversaries in the fancy diary display." @@ -105,29 +103,24 @@ are: `string', `symbol', `int', `tnil', `stringtnil'." (const :value int :tag "An integer") (const :value tnil :tag "t or nil") (const :value stringtnil - :tag "A string, t, or nil")))) - :group 'diary) + :tag "A string, t, or nil"))))) (defcustom diary-glob-file-regexp-prefix "^#" "Regular expression prepended to `diary-face-attrs' for file-wide specifiers." - :type 'regexp - :group 'diary) + :type 'regexp) (defcustom diary-file-name-prefix nil "Non-nil means prefix each diary entry with the name of the file defining it." - :type 'boolean - :group 'diary) + :type 'boolean) (defcustom diary-file-name-prefix-function #'identity "The function that will take a diary file name and return the desired prefix." - :type 'function - :group 'diary) + :type 'function) (defcustom diary-sexp-entry-symbol "%%" "The string used to indicate a sexp diary entry in `diary-file'. See the documentation for the function `diary-list-sexp-entries'." - :type 'string - :group 'diary) + :type 'string) (defcustom diary-comment-start nil "String marking the start of a comment in the diary, or nil. @@ -138,24 +131,21 @@ for whatever you like, e.g. for meta-data that packages such as can be only one comment on any line. See also `diary-comment-end'." :version "24.1" - :type '(choice (const :tag "No comment" nil) string) - :group 'diary) + :type '(choice (const :tag "No comment" nil) string)) (defcustom diary-comment-end "" "String marking the end of a comment in the diary. The empty string means comments finish at the end of a line. See also `diary-comment-start'." :version "24.1" - :type 'string - :group 'diary) + :type 'string) (defcustom diary-hook nil "Hook run after displaying the diary. Used for example by the appointment package - see `appt-activate'. The variables `number' and `original-date' are dynamically bound around the call." - :type 'hook - :group 'diary) + :type 'hook) (defcustom diary-display-function #'diary-fancy-display "Function used to display the diary. @@ -171,10 +161,9 @@ holidays), or hard copy output." (const :tag "Basic display" diary-simple-display) (const :tag "No display" ignore) (function :tag "User-specified function")) - :initialize 'custom-initialize-default - :set 'diary-set-maybe-redraw - :version "23.2" ; simple->fancy - :group 'diary) + :initialize #'custom-initialize-default + :set #'diary-set-maybe-redraw + :version "23.2") ; simple->fancy (defcustom diary-list-entries-hook nil "Hook run after diary file is culled for relevant entries. @@ -201,8 +190,7 @@ So for example, to sort the complete list of diary entries you would use the list-entries hook, whereas to process e.g. Islamic entries in the main file and all included files, you would use the nongregorian hook." :type 'hook - :options '(diary-include-other-diary-files diary-sort-entries) - :group 'diary) + :options '(diary-include-other-diary-files diary-sort-entries)) (defcustom diary-mark-entries-hook nil "List of functions called after marking diary entries in the calendar. @@ -218,8 +206,7 @@ differ only if you are using included diary files. In that case, `displayed-year' and `displayed-month' are dynamically bound when this hook is called." :type 'hook - :options '(diary-mark-included-diary-files) - :group 'diary) + :options '(diary-mark-included-diary-files)) (defcustom diary-nongregorian-listing-hook nil "List of functions called for listing diary file and included files. @@ -236,8 +223,7 @@ use `diary-list-entries-hook', which runs only for the main diary file." :options '(diary-bahai-list-entries diary-hebrew-list-entries diary-islamic-list-entries - diary-chinese-list-entries) - :group 'diary) + diary-chinese-list-entries)) (defcustom diary-nongregorian-marking-hook nil "List of functions called for marking diary file and included files. @@ -254,8 +240,7 @@ use `diary-mark-entries-hook', which runs only for the main diary file." :options '(diary-bahai-mark-entries diary-hebrew-mark-entries diary-islamic-mark-entries - diary-chinese-mark-entries) - :group 'diary) + diary-chinese-mark-entries)) (defcustom diary-print-entries-hook #'lpr-buffer "Run by `diary-print-entries' after preparing a temporary diary buffer. @@ -264,8 +249,7 @@ diary buffer. The default just does the printing. Other uses might include, for example, rearranging the lines into order by day and time, saving the buffer instead of deleting it, or changing the function used to do the printing." - :type 'hook - :group 'diary) + :type 'hook) (defcustom diary-unknown-time -9999 "Value returned by `diary-entry-time' when no time is found. @@ -273,19 +257,16 @@ 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 after those with times." :type 'integer - :group 'diary :version "20.3") (defcustom diary-mail-addr (or (bound-and-true-p user-mail-address) "") "Email address that `diary-mail-entries' will send email to." - :group 'diary :type 'string :version "20.3") (defcustom diary-mail-days 7 "Default number of days for `diary-mail-entries' to check." - :group 'diary :type 'integer :version "20.3") @@ -302,8 +283,7 @@ Used by the function `diary-remind', a pseudo-pattern is a list of expressions that can involve the keywords `days' (a number), `date' \(a list of month, day, year), and `diary-entry' (a string)." :type 'sexp - :risky t - :group 'diary) + :risky t) (defcustom diary-abbreviated-year-flag t "Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. @@ -312,8 +292,7 @@ When the current century is added to a two-digit year, if the result is more than 50 years in the future, the previous century is assumed. If the result is more than 50 years in the past, the next century is assumed. If this variable is nil, years must be written in full." - :type 'boolean - :group 'diary) + :type 'boolean) (defun diary-outlook-format-1 (body) "Return a replace-match template for an element of `diary-outlook-formats'. @@ -378,8 +357,7 @@ template following the rules above." (string :tag "Template for entry") (function :tag "Unary function providing template"))) - :version "22.1" - :group 'diary) + :version "22.1") (defvar diary-header-line-flag) (defvar diary-header-line-format) @@ -401,10 +379,9 @@ template following the rules above." (defcustom diary-header-line-flag t "Non-nil means `diary-simple-display' will show a header line. The format of the header is specified by `diary-header-line-format'." - :group 'diary :type 'boolean - :initialize 'custom-initialize-default - :set 'diary-set-header + :initialize #'custom-initialize-default + :set #'diary-set-header :version "22.1") (defvar diary-selective-display nil @@ -418,11 +395,10 @@ The format of the header is specified by `diary-header-line-format'." ?\s (window-width))) "Format of the header line displayed by `diary-simple-display'. Only used if `diary-header-line-flag' is non-nil." - :group 'diary :type 'sexp :risky t - :initialize 'custom-initialize-default - :set 'diary-set-header + :initialize #'custom-initialize-default + :set #'diary-set-header :version "23.3") ; frame-width -> window-width ;; The first version of this also checked for diary-selective-display @@ -480,9 +456,8 @@ of days of diary entries displayed." (integer :tag "Thursday") (integer :tag "Friday") (integer :tag "Saturday"))) - :initialize 'custom-initialize-default - :set 'diary-set-maybe-redraw - :group 'diary) + :initialize #'custom-initialize-default + :set #'diary-set-maybe-redraw) ;;; More user options in calendar.el, holidays.el. @@ -1443,9 +1418,9 @@ marks. This is intended to deal with deleted diary entries." (entry entry)) (if calendar-debug-sexp (let ((debug-on-error t)) - (eval (car (read-from-string sexp)))) + (eval (car (read-from-string sexp)) t)) (condition-case err - (eval (car (read-from-string sexp))) + (eval (car (read-from-string sexp)) t) (error (display-warning 'diary @@ -1671,7 +1646,7 @@ be used instead of a colon (:) to separate the hour and minute parts." If you add this function to `diary-list-entries-hook', it should be the last item in the hook, in case earlier items add diary entries, or change the order." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) + (setq diary-entries-list (sort diary-entries-list #'diary-entry-compare))) (defun diary-list-sexp-entries (date) @@ -2027,7 +2002,7 @@ Entry applies if the date is DAYS days after another diary-sexp SEXP." (user-error "Days must be an integer")) (let ((date (calendar-gregorian-from-absolute (- (calendar-absolute-from-gregorian date) days)))) - (eval sexp))) + (eval sexp t))) (defun diary-day-of-year () "Day of year and number of days remaining in the year of date diary entry." @@ -2058,7 +2033,7 @@ calendar." (and (integerp days) (< days 0) (setq days (number-sequence 1 (- days)))) - (calendar-dlet ((diary-entry (eval sexp))) + (calendar-dlet ((diary-entry (eval sexp t))) (cond ;; Diary entry applies on date. ((and diary-entry @@ -2071,7 +2046,7 @@ calendar." ;; Adjust date, and re-evaluate. (let ((date (calendar-gregorian-from-absolute (+ (calendar-absolute-from-gregorian date) days)))) - (when (setq diary-entry (eval sexp)) + (when (setq diary-entry (eval sexp t)) ;; Discard any mark portion from diary-anniversary, etc. (if (consp diary-entry) (setq diary-entry (cdr diary-entry))) (calendar-dlet ((days days)) @@ -2300,7 +2275,7 @@ full month names." "") ;; With backup, last item is not part of date. (if (equal (car x) 'backup) - (concat "\\)" (eval (car (reverse x)))) + (concat "\\)" (eval (car (reverse x)) t)) "\\)")) '(1 'diary))) diary-date-forms))) diff --git a/lisp/calendar/icalendar-macs.el b/lisp/calendar/icalendar-macs.el index d46eca978a0..033fea94527 100644 --- a/lisp/calendar/icalendar-macs.el +++ b/lisp/calendar/icalendar-macs.el @@ -305,7 +305,7 @@ The following keyword arguments are accepted: "must be " (unless list-sep "a ") (when quoted "quoted ") (if (ical:value-type-symbol-p value) (format "`%s' value%s" (symbol-name value) s) - (format "string%s matching rx `%s'" s value)))) + (format "string%s matching rx `%S'" s value)))) (syntax-doc (format "Syntax: %s=%s\n%s" (or param-name "(NAME)") val-list val-doc)) (full-doc (concat header "\n\n" doc "\n\n" syntax-doc))) diff --git a/lisp/calendar/icalendar-parser.el b/lisp/calendar/icalendar-parser.el index bc213b413ad..a2ce4b2362f 100644 --- a/lisp/calendar/icalendar-parser.el +++ b/lisp/calendar/icalendar-parser.el @@ -737,7 +737,7 @@ other special requirements like quoting or escaping." ;; standard) because a few of them are already required for property ;; parameter definitions (section 3.2) below. -(defconst ical:value-types nil ;; populated by define-type +(defvar ical:value-types nil ;; populated by define-type "Alist mapping value type strings to type symbols. Value type strings are those which can appear in `icalendar-valuetypeparam' parameters and specify the type of a property's value.") @@ -1855,7 +1855,7 @@ with `decode-time' and related functions." ;;; Section 3.2: Property Parameters -(defconst ical:param-types nil ;; populated by ical:define-param +(defvar ical:param-types nil ;; populated by ical:define-param "Alist mapping printed parameter names to type symbols.") (defun ical:maybe-quote-param-value (s &optional always) @@ -2369,7 +2369,7 @@ interpreted." ;;; Properties: -(defconst ical:property-types nil ;; populated by ical:define-property +(defvar ical:property-types nil ;; populated by ical:define-property "Alist mapping printed property names to type symbols.") (defun ical:read-property-value (type s &optional params) @@ -3515,7 +3515,7 @@ facilitate parsing the `icalendar-request-status' property." ;;; Section 3.6: Calendar Components -(defconst ical:component-types nil ;; populated by ical:define-component +(defvar ical:component-types nil ;; populated by ical:define-component "Alist mapping printed component names to type symbols.") (defun ical:parse-component (limit) diff --git a/lisp/calendar/icalendar-recur.el b/lisp/calendar/icalendar-recur.el index 391f3b91a92..28a05aacf7c 100644 --- a/lisp/calendar/icalendar-recur.el +++ b/lisp/calendar/icalendar-recur.el @@ -2097,7 +2097,7 @@ to start the observances in the time zone. It defaults to 1970." (format "Unable to export DST rule for time zone: %s" dst-starts))))) (dst-start-date (calendar-dlet ((year (or start-year 1970))) - (eval dst-starts))) + (eval dst-starts t))) (dst-start (ical:date-to-date-time dst-start-date :hour (/ dst-start-minutes 60) @@ -2116,7 +2116,7 @@ to start the observances in the time zone. It defaults to 1970." (format "Unable to export DST rule for time zone: %s" dst-ends))))) (std-start-date (calendar-dlet ((year (1- (or start-year 1970)))) - (eval dst-ends))) + (eval dst-ends t))) (std-start (ical:date-to-date-time std-start-date :hour (/ dst-end-minutes 60) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 7bea2dde43c..4956dc82f09 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -112,8 +112,7 @@ argument. It must return a string. See `icalendar-import-format-sample' for an example." :type '(choice (string :tag "String") - (function :tag "Function")) - :group 'icalendar) + (function :tag "Function"))) (make-obsolete-variable 'icalendar-import-format @@ -126,8 +125,7 @@ formatting instead." "Format string defining how the summary element is formatted. This applies only if the summary is not empty! `%s' is replaced by the summary." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-summary @@ -140,8 +138,7 @@ formatting instead." "Format string defining how the description element is formatted. This applies only if the description is not empty! `%s' is replaced by the description." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-description @@ -154,8 +151,7 @@ formatting instead." "Format string defining how the location element is formatted. This applies only if the location is not empty! `%s' is replaced by the location." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-location @@ -168,8 +164,7 @@ formatting instead." "Format string defining how the organizer element is formatted. This applies only if the organizer is not empty! `%s' is replaced by the organizer." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-organizer @@ -182,8 +177,7 @@ formatting instead." "Format string defining how the URL element is formatted. This applies only if the URL is not empty! `%s' is replaced by the URL." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-url @@ -197,8 +191,7 @@ formatting instead." This applies only if the UID is not empty! `%s' is replaced by the UID." :type 'string - :version "24.3" - :group 'icalendar) + :version "24.3") (make-obsolete-variable 'icalendar-import-format-uid @@ -211,8 +204,7 @@ formatting instead." "Format string defining how the status element is formatted. This applies only if the status is not empty! `%s' is replaced by the status." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-status @@ -225,8 +217,7 @@ formatting instead." "Format string defining how the class element is formatted. This applies only if the class is not empty! `%s' is replaced by the class." - :type 'string - :group 'icalendar) + :type 'string) (make-obsolete-variable 'icalendar-import-format-class @@ -263,15 +254,13 @@ The following specifiers are available: For example, a value of \"%h%t@mydomain.com\" will generate a UID code for each entry composed of a hash of the event data, a creation timestamp, and your personal domain name." - :type 'string - :group 'icalendar) + :type 'string) (defcustom ical:vcalendar-prodid (format "-//gnu.org//GNU Emacs %s//EN" emacs-version) "The value of the `icalendar-prodid' property for VCALENDAR objects produced by this Emacs." - :type 'string - :group 'icalendar) + :type 'string) (defconst ical:vcalendar-version "2.0" "The current version of the VCALENDAR object, used in the @@ -305,8 +294,7 @@ RFC5545.") (list :tag "Email" (const email) (repeat :tag "Attendees" - (string :tag "Email")))))) - :group 'icalendar) + (string :tag "Email"))))))) (make-obsolete-variable 'icalendar-export-alarms @@ -318,8 +306,7 @@ RFC5545.") A value of 2 only logs errors. A value of 1 also logs warnings. A value of 0 also logs debugging information." - :type 'integer - :group 'icalendar) + :type 'integer) (defvar icalendar-debug nil "Enable icalendar debug messages.") @@ -523,7 +510,6 @@ see `compilation-error-regexp-alist'.") (define-compilation-mode ical:errors-mode "iCalendar Errors" "Mode for listing and visiting errors when processing iCalendar data." - :group 'icalendar (setq-local compilation-error-regexp-alist ical:error-regexp-alist)) ;; ====================================================================== @@ -687,7 +673,7 @@ mix of different line endings." (replace-match "\n" nil nil)))) (define-obsolete-function-alias 'icalendar--rris - 'replace-regexp-in-string "27.1") + #'replace-regexp-in-string "27.1") (defun icalendar--read-element (invalue inparams) "Recursively read the next iCalendar element in the current buffer. @@ -946,7 +932,7 @@ ALIST is a VTIMEZONE potentially containing historical records." (and (memq (car p) '(DTSTART RDATE)) (car (cddr p)))) n)) - 'string-greaterp)))) + #'string-greaterp)))) (a-recent (funcall get-recent (car (cddr a)))) (b-recent (funcall get-recent (car (cddr b))))) (string-greaterp a-recent b-recent)))))))) @@ -1597,7 +1583,7 @@ Returns an alist." (p-sta (or (string-match "%t" icalendar-import-format) -1)) (p-url (or (string-match "%u" icalendar-import-format) -1)) (p-uid (or (string-match "%U" icalendar-import-format) -1)) - (p-list (sort (list p-cla p-des p-loc p-org p-sta p-sum p-url p-uid) '<)) + (p-list (sort (list p-cla p-des p-loc p-org p-sta p-sum p-url p-uid) #'<)) (ct 0) pos-cla pos-des pos-loc pos-org pos-sta pos-url pos-uid) ;pos-sum (dotimes (i (length p-list)) diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index 1f7107b1037..e20cf52013e 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -150,7 +150,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (time (* 24 (- date (truncate date)))) (date (calendar-gregorian-from-absolute (truncate date))) (adj (dst-adjust-time date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase eclipse))) + (list (car adj) (apply #'solar-time-string (cdr adj)) phase eclipse))) ;; from "Astronomy with your Personal Computer", Subroutine Eclipse ;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990 diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index bb3d5cc1546..eeba372e69c 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -668,7 +668,7 @@ Optional NOLOCATION non-nil means do not print the location." (concat "sunset " (apply #'solar-time-string (cadr l))) "no sunset") (if nolocation "" - (format " at %s" (eval calendar-location-name))) + (format " at %s" (eval calendar-location-name t))) (nth 2 l)))) (defconst solar-data-list @@ -881,7 +881,7 @@ Accurate to a few seconds." (last (calendar-last-day-of-month month year)) (title (format "Sunrise/sunset times for %s %d at %s" (calendar-month-name month) year - (eval calendar-location-name)))) + (eval calendar-location-name t)))) (calendar-in-read-only-buffer solar-sunrises-buffer (calendar-set-mode-line title) (insert title ":\n\n") diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index 8afecb19cfa..acdf99f77ae 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -296,7 +296,7 @@ set before switching this mode on." `timeclock-use-display-time' to see timeclock information")) (add-hook 'display-time-hook #'timeclock-update-mode-line)) (setq timeclock-update-timer - (run-at-time nil 60 'timeclock-update-mode-line)))) + (run-at-time nil 60 #'timeclock-update-mode-line)))) (setq global-mode-string (delq 'timeclock-mode-string global-mode-string)) (remove-hook 'timeclock-event-hook #'timeclock-update-mode-line) @@ -513,8 +513,8 @@ non-nil, the amount returned will be relative to past time worked." (message "%s" string) string))) -(define-obsolete-function-alias 'timeclock-time-to-seconds 'float-time "26.1") -(define-obsolete-function-alias 'timeclock-seconds-to-time 'time-convert "26.1") +(define-obsolete-function-alias 'timeclock-time-to-seconds #'float-time "26.1") +(define-obsolete-function-alias 'timeclock-seconds-to-time #'time-convert "26.1") ;; Should today-only be removed in favor of timeclock-relative? - gm (defsubst timeclock-when-to-leave (&optional today-only) From ed158fb8fcac73e557706f6f24f584e1bd3e9102 Mon Sep 17 00:00:00 2001 From: Manuel Giraud Date: Fri, 6 Feb 2026 20:12:40 +0100 Subject: [PATCH 131/191] Add missing symbolic prefix keybinding * lisp/gnus/gnus-group.el (:keymap): Add symbolic prefix to group keymap. * etc/NEWS: Announce the change. --- etc/NEWS | 5 +++++ lisp/gnus/gnus-group.el | 1 + 2 files changed, 6 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 1b95bc37364..88235ce0de6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1782,6 +1782,11 @@ response. It is believed to no longer be useful as a method to fight spam. The 'spam-use-hashcash' hook is now obsolete and has no effect. +--- +*** Add 'M-i' keybinding as the symbolic prefix in the group keymap. +The symbolic prefix is another kind of universal prefix that is used in +Gnus, see "(gnus) Symbolic Prefixes" in the Gnus manual. + ** Sieve +++ diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 7214b440732..28c8c677d13 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -640,6 +640,7 @@ simple manner." "M-&" #'gnus-group-universal-argument "#" #'gnus-group-mark-group "M-#" #'gnus-group-unmark-group + "M-i" #'gnus-symbolic-argument "~" (define-keymap :prefix 'gnus-group-cloud-map "u" #'gnus-cloud-upload-all-data From 832580989619d3343f06cd9a9eeed9f22ddad376 Mon Sep 17 00:00:00 2001 From: Manuel Giraud Date: Fri, 6 Feb 2026 20:20:49 +0100 Subject: [PATCH 132/191] Fix selected group sort with topics (bug#80341) * lisp/gnus/gnus-topic.el (gnus-group-sort-selected-topic): New function to sort selected groups into topic. (gnus-topic-mode): Use it as sort selected function in topic mode. * etc/NEWS: Announce the change. --- etc/NEWS | 3 +++ lisp/gnus/gnus-topic.el | 28 ++++++++++++++++++++++++++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 88235ce0de6..fb78b3f7b5e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1787,6 +1787,9 @@ It is believed to no longer be useful as a method to fight spam. The The symbolic prefix is another kind of universal prefix that is used in Gnus, see "(gnus) Symbolic Prefixes" in the Gnus manual. +--- +*** Sorting selected groups is now possible with 'gnus-topic-mode'. + ** Sieve +++ diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 315f1a018c9..4fb796105e2 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -1158,7 +1158,8 @@ articles in the topic and its subtopics." #'gnus-topic-group-indentation) (setq-local gnus-group-update-group-function #'gnus-topic-update-topics-containing-group) - (setq-local gnus-group-sort-alist-function #'gnus-group-sort-topic) + (setq-local gnus-group-sort-alist-function #'gnus-group-sort-topic + gnus-group-sort-selected-function #'gnus-group-sort-selected-topic) (setq gnus-group-change-level-function #'gnus-topic-change-level) (setq gnus-goto-missing-group-function #'gnus-topic-goto-missing-group) (add-hook 'gnus-check-bogus-groups-hook #'gnus-topic-clean-alist @@ -1173,7 +1174,8 @@ articles in the topic and its subtopics." (setq gnus-group-change-level-function nil) (remove-hook 'gnus-check-bogus-groups-hook #'gnus-topic-clean-alist) (setq gnus-group-prepare-function #'gnus-group-prepare-flat) - (setq gnus-group-sort-alist-function #'gnus-group-sort-flat)) + (setq gnus-group-sort-alist-function #'gnus-group-sort-flat + gnus-group-sort-selected-function #'gnus-group-sort-selected-flat)) (when (called-interactively-p 'any) (gnus-group-list-groups)))) @@ -1651,6 +1653,28 @@ If performed on a topic, edit the topic parameters instead." (setcar alist (delete "dummy.group" (car alist))) (gnus-topic-sort-topic (pop alist) func reverse)))) +(defun gnus-group-sort-selected-topic (groups func reverse) + "Sort selected GROUPS in the topics according to FUNC and REVERSE." + (let ((alist gnus-topic-alist)) + (while alist + ;; !!!Sometimes nil elements sneak into the alist, + ;; for some reason or other. + (setcar alist (delq nil (car alist))) + (setcar alist (delete "dummy.group" (car alist))) + (let* ((topic (pop alist)) + (inter (seq-intersection groups (cdr topic)))) + ;; Do something only if there are some selected groups in this + ;; topic. + (when inter + (let ((sorted (mapcar #'gnus-info-group + (sort (mapcar #'gnus-get-info inter) func)))) + ;; Do the reversal, if necessary. + (when reverse + (setq sorted (nreverse (cdr sorted)))) + ;; Set the topic contents as the union of the sorted + ;; selected groups and its previous contents. + (setcdr topic (seq-union sorted (cdr topic))))))))) + (defun gnus-topic-sort-topic (topic func reverse) ;; Each topic only lists the name of the group, while ;; the sort predicates expect group infos as inputs. From 3c2351f2dc1fdc2d32592101cf1d5f5e66bef0b7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 9 Feb 2026 12:30:35 -0500 Subject: [PATCH 133/191] (loaddefs-generate--print-form): Fix bug#80222 * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate--print-form): Remove the "\\\n" hack we used to use together with `src/lread.c` code to avoid allocating heap space for docstrings that were going to be replaced by `Snarf-documentation`. We don't keep ELisp docstrings in DOC any more anyway. --- lisp/emacs-lisp/loaddefs-gen.el | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 60d250b564f..0dc0d873bcd 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -732,11 +732,8 @@ instead of just updating them with the new/changed autoloads." '(t (escape-newlines . t) (escape-control-characters . t))) (insert " ")) - (let ((start (point))) - (prin1 (pop def) (current-buffer) t) - (save-excursion - (goto-char (1+ start)) - (insert "\\\n"))) + (delete-char -1) (insert "\n") + (prin1 (pop def) (current-buffer) t) (while def (insert " ") (prin1 (pop def) (current-buffer) From c65a4e6a430a28323d6645d7e10f7c587adaccfa Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 9 Feb 2026 18:31:04 +0100 Subject: [PATCH 134/191] ; * doc/lispref/os.texi (Timers): Fix typo. --- doc/lispref/os.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index f5ca6efa21b..c5ba86dddee 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -2285,7 +2285,7 @@ be protected by wrapping the timer function body with @lisp @group -(ignore-error 'remote-file-error +(ignore-error remote-file-error @dots{}) @end group @end lisp From 4a3640c3f82142f115c6a7a7e64a4869700d1f64 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Mon, 9 Feb 2026 19:22:07 +0100 Subject: [PATCH 135/191] Detect more package suggestions * admin/scrape-elpa.el (scrape-elpa--safe-eval): Add new function. (scrape-elpa): Evaluate part of the matched expression to catch more entries. * etc/package-autosuggest.eld: Update database. --- admin/scrape-elpa.el | 60 ++++++++++++++++++++++++++++++++++--- etc/package-autosuggest.eld | 14 +++++++++ 2 files changed, 70 insertions(+), 4 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index f513dc36550..f3e9d7f8d0f 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -1,6 +1,6 @@ ;;; scrape-elpa.el --- Collect ELPA package suggestions -*- lexical-binding: t; -*- -;; Copyright (C) 2024 Free Software Foundation, Inc. +;; Copyright (C) 2024, 2026 Free Software Foundation, Inc. ;; Author: Philip Kaludercic ;; Keywords: tools @@ -25,6 +25,39 @@ ;;; Code: +(require 'rx) + +(defun scrape-elpa--safe-eval (exp &optional vars) + "Manually evaluate EXP without potentially dangerous side-effects. +The optional argument VARS may be an alist mapping symbols to values, +used when evaluating variables. The evaluation function is not meant to +be comprehensive, but just to handle the kinds of expressions that +`scrape-elpa' expects to encounter." + (pcase-exhaustive exp + ;; special handling for macros + (`(rx . ,body) (rx-to-string `(: . ,body) t)) + ;; quoting and quasi-quoting + (`',x x) + (`(purecopy ,x) x) + ((and (guard (eq '\` (car-safe exp))) (let `(,car . ,cdr) (cadr exp))) + (cons + (if (eq (car-safe car) '\,) (scrape-elpa--safe-eval (cadr car) vars) car) + (if (eq (car-safe cdr) '\,) (scrape-elpa--safe-eval (cadr cdr) vars) cdr))) + ;; supported functions + (`(cons ,car ,cdr) + (cons (scrape-elpa--safe-eval car vars) + (scrape-elpa--safe-eval cdr vars))) + (`(concat . ,args) + (apply #'concat (mapcar #'scrape-elpa--safe-eval args))) + ;; self-evaluating forms + ((pred macroexp-const-p) exp) + ;; variable evaluation + ((pred symbolp) + (let ((ent (assq exp vars))) + (if ent (cdr ent) (signal 'void-variable exp)))))) + +(scrape-elpa--safe-eval '(cons "\\.go\\'" 'go-mode)) + (defun scrape-elpa (&rest directories) "Scrape autoload files in DIRECTORIES for package suggestions. This file will automatically update \"package-autosuggest.eld\", but not @@ -57,6 +90,7 @@ Please review the results before updating the autosuggest database!" "Scraping files..." (and-let* (((string-match "/\\([^/]+?\\)-autoloads\\.el\\'" file)) (pkg (intern (match-string 1 file))) + (vars (list '(#:nihil))) (inhibit-message t)) (with-temp-buffer (insert-file-contents file) @@ -64,16 +98,34 @@ Please review the results before updating the autosuggest database!" (while t (dolist (exp (macroexp-unprogn (read (current-buffer)))) (pcase exp + (`(defconst ,(and (pred symbolp) var) ,val . ,_) + (catch 'ignore + (push + (cons var (condition-case err + (scrape-elpa--safe-eval val vars) + (t (message "Failed to evaluate %S: %S in %S" exp err vars) + (throw 'ignore nil)))) + vars))) (`(add-to-list ',(and (or 'interpreter-mode-alist 'magic-mode-alist 'auto-mode-alist) variable) - '(,(and (pred stringp) regexp) . - ,(and (pred symbolp) mode))) + ,(let `(,(and (pred stringp) regexp) . + ,(and (pred symbolp) mode)) + (condition-case err + (scrape-elpa--safe-eval _ vars) + (t (message "Failed to evaluate %S: %S in %S" exp err vars) + nil)))) (terpri) (prin1 (append (list pkg variable regexp) - (and (not (eq pkg mode)) (list mode)))))))) + (and (not (eq pkg mode)) (list mode))))) + (`(add-to-list + ',(or 'interpreter-mode-alist + 'magic-mode-alist + 'auto-mode-alist) + _) + (_ (message "Skipped over %S" exp)))))) (end-of-file nil)))))) (insert "\n)\n"))) diff --git a/etc/package-autosuggest.eld b/etc/package-autosuggest.eld index 987dc6a6e6b..257ad853b97 100644 --- a/etc/package-autosuggest.eld +++ b/etc/package-autosuggest.eld @@ -41,6 +41,7 @@ (gle-mode auto-mode-alist "\\.gle\\'") (gpr-mode auto-mode-alist "\\.gpr\\'") (html5-schema auto-mode-alist "\\.html?\\'" nxml-mode) +(idlwave auto-mode-alist "\\.pro\\'" idlwave-mode) (jgraph-mode auto-mode-alist "\\.jgr\\'") (json-mode auto-mode-alist "\\.json\\'") (lmc auto-mode-alist "\\.elmc\\'" lmc-asm-mode) @@ -55,6 +56,7 @@ (omn-mode auto-mode-alist "\\.omn\\'") (poke-mode auto-mode-alist "\\.pk\\'") (pspp-mode auto-mode-alist "\\.sps\\'") +(python auto-mode-alist "\\(?:\\.\\(?:p\\(?:th\\|y[iw]?\\)\\)\\|/\\(?:SCons\\(?:\\(?:crip\\|truc\\)t\\)\\)\\)\\'" python-mode) (python interpreter-mode-alist "python[0-9.]*" python-mode) (python auto-mode-alist "/\\(?:Pipfile\\|\\.?flake8\\)\\'" conf-mode) (rec-mode auto-mode-alist "\\.rec\\'") @@ -62,8 +64,10 @@ (sed-mode auto-mode-alist "\\.sed\\'") (sed-mode interpreter-mode-alist "sed") (shen-mode auto-mode-alist "\\.shen\\'") +(show-font auto-mode-alist "\\.\\(ttf\\|otf\\)\\'" show-font-mode) (sisu-mode auto-mode-alist "\\.ss[imt]\\'") (smalltalk-mode auto-mode-alist "\\.st\\'") +(smalltalk-mode auto-mode-alist "\\.star\\'" archive-mode) (sml-mode auto-mode-alist "\\.s\\(ml\\|ig\\)\\'") (sml-mode auto-mode-alist "\\.cm\\'" sml-cm-mode) (sml-mode auto-mode-alist "\\.grm\\'" sml-yacc-mode) @@ -77,6 +81,7 @@ (systemd auto-mode-alist "\\.swap\\'" systemd-swap-mode) (systemd auto-mode-alist "\\.timer\\'" systemd-timer-mode) (vcard auto-mode-alist "\\.[Vv][Cc][Ff]\\'" vcard-mode) +(vcl-mode auto-mode-alist "\\.vcl\\'") (wisi auto-mode-alist "\\.parse_table.*\\'" wisitoken-parse_table-mode) (wisitoken-grammar-mode auto-mode-alist "\\.wy\\'" simple-indent-mode) (wisitoken-grammar-mode auto-mode-alist "\\.wy\\'") @@ -107,6 +112,7 @@ (coffee-mode interpreter-mode-alist "coffee") (d-mode auto-mode-alist "\\.d[i]?\\'") (dart-mode auto-mode-alist "\\.dart\\'") +(dockerfile-mode auto-mode-alist "[/\\]\\(?:Containerfile\\|Dockerfile\\)\\(?:\\.[^/\\]*\\)?\\'") (dockerfile-mode auto-mode-alist "\\.dockerfile\\'") (drupal-mode auto-mode-alist "[^/]\\.\\(module\\|test\\|install\\|profile\\|tpl\\.php\\|theme\\|inc\\)\\'" php-mode) (drupal-mode auto-mode-alist "[^/]\\.info\\'" conf-windows-mode) @@ -121,6 +127,7 @@ (geiser-racket auto-mode-alist "\\.rkt\\'" scheme-mode) (gnu-apl-mode auto-mode-alist "\\.apl\\'") (gnu-apl-mode interpreter-mode-alist "apl") +(go-mode auto-mode-alist "\\.go\\'") (go-mode auto-mode-alist "go\\.mod\\'" go-dot-mod-mode) (go-mode auto-mode-alist "go\\.work\\'" go-dot-work-mode) (graphql-mode auto-mode-alist "\\.graphql\\'") @@ -137,6 +144,7 @@ (haskell-mode auto-mode-alist "\\.hsc\\'") (haskell-mode interpreter-mode-alist "runghc") (haskell-mode interpreter-mode-alist "runhaskell") +(haskell-tng-mode auto-mode-alist "\\.hs\\'") (j-mode auto-mode-alist "\\.ij[rsp]$") (j-mode auto-mode-alist "\\.ijt$" j-lab-mode) (jade-mode auto-mode-alist "\\.jade\\'") @@ -147,12 +155,15 @@ (julia-mode auto-mode-alist "\\.jl\\'") (lua-mode auto-mode-alist "\\.lua\\'") (lua-mode interpreter-mode-alist "lua") +(magit-section auto-mode-alist "/git-rebase-todo\\'" git-rebase-mode) +(magit auto-mode-alist "/git-rebase-todo\\'" git-rebase-mode) (markdown-mode auto-mode-alist "\\.\\(?:md\\|markdown\\|mkd\\|mdown\\|mkdn\\|mdwn\\)\\'") (nginx-mode auto-mode-alist "nginx\\.conf\\'") (nginx-mode auto-mode-alist "/nginx/.+\\.conf\\'") (nix-mode auto-mode-alist "^/nix/store/.+\\.drv\\'" nix-drv-mode) (nix-mode auto-mode-alist "\\flake.lock\\'" js-mode) (nix-mode auto-mode-alist "\\.nix\\'") +(php-mode interpreter-mode-alist "php\\(?:-?[34578]\\(?:\\.[0-9]+\\)*\\)?") (php-mode auto-mode-alist "/\\.php_cs\\(?:\\.dist\\)?\\'") (php-mode auto-mode-alist "\\.\\(?:php\\.inc\\|stub\\)\\'") (php-mode auto-mode-alist "\\.\\(?:php[s345]?\\|phtml\\)\\'" php-mode-maybe) @@ -178,6 +189,9 @@ (subed auto-mode-alist "\\.vtt\\'" subed-vtt-mode) (swift-mode auto-mode-alist "\\.swift\\(interface\\)?\\'") (systemd auto-mode-alist "\\.nspawn\\'" systemd-mode) +(systemd auto-mode-alist "[.0-9@-Z\\_a-z-]+?\\.\\(?:automount\\|busname\\|link\\|mount\\|net\\(?:dev\\|work\\)\\|s\\(?:ervice\\|lice\\|ocket\\|wap\\)\\|t\\(?:arget\\|imer\\)\\)\\'" systemd-mode) +(systemd auto-mode-alist "\\.#\\(?:[.0-9@-Z\\_a-z-]+?\\.\\(?:automount\\|busname\\|link\\|mount\\|net\\(?:dev\\|work\\)\\|s\\(?:ervice\\|lice\\|ocket\\|wap\\)\\|t\\(?:arget\\|imer\\)\\)\\|override\\.conf\\)[[:xdigit:]]\\{16\\}\\'" systemd-mode) +(systemd auto-mode-alist "/systemd/[^z-a]+?\\.d/[^/]+?\\.conf\\'" systemd-mode) (tuareg auto-mode-alist "\\.ml[ip]?\\'" tuareg-mode) (tuareg auto-mode-alist "\\.eliomi?\\'" tuareg-mode) (tuareg interpreter-mode-alist "ocamlrun" tuareg-mode) From 6dea509613a5886cbc9cb197c33b19df383f6b75 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Mon, 9 Feb 2026 21:17:19 +0100 Subject: [PATCH 136/191] ; Remove test code from previous commit --- admin/scrape-elpa.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index f3e9d7f8d0f..f1bd0307b43 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -56,8 +56,6 @@ be comprehensive, but just to handle the kinds of expressions that (let ((ent (assq exp vars))) (if ent (cdr ent) (signal 'void-variable exp)))))) -(scrape-elpa--safe-eval '(cons "\\.go\\'" 'go-mode)) - (defun scrape-elpa (&rest directories) "Scrape autoload files in DIRECTORIES for package suggestions. This file will automatically update \"package-autosuggest.eld\", but not From ae5ee77f488c8387ed66d946f2a5eff295ed6af1 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Mon, 9 Feb 2026 21:22:37 +0100 Subject: [PATCH 137/191] Enable fewer minor modes in package suggestion buffers * lisp/emacs-lisp/package.el (package--autosugest-prompt): Do not enable 'enriched-mode' and 'variable-pitch-mode'. --- lisp/emacs-lisp/package.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1315cd6fbed..44da3ab94e1 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4612,8 +4612,6 @@ so you have to select which to install!)" nl)) (fill-region (point-min) (point-max)) (special-mode) (button-mode t) - (enriched-mode t) - (variable-pitch-mode t) (let ((win (display-buffer-below-selected (current-buffer) '()))) (fit-window-to-buffer win) From 8cb9aaec0fbb2bcc1640c11e842852b7f3f420e9 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 10 Feb 2026 02:22:24 +0200 Subject: [PATCH 138/191] Amend previous to avoid remote call in project--remove-from-project-list * lisp/progmodes/project.el (project--remove-from-project-list): Don't call 'abbreviate-file-name', expect it to be abbreviated already. The file might be on an inaccessible filesystem. (project-current): Call abbreviate-file-name here (bug#80340). --- lisp/progmodes/project.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 80f705f49c6..efd79d0155b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -275,7 +275,8 @@ of the project instance object." (if pr (project-remember-project pr) (project--remove-from-project-list - directory "Project `%s' not found; removed from list") + (abbreviate-file-name directory) + "Project `%s' not found; removed from list") (setq pr (cons 'transient directory)))) pr)) @@ -2206,7 +2207,7 @@ result in `project-list-file'. Announce the project's removal from the list using REPORT-MESSAGE, which is a format string passed to `message' as its first argument." (project--ensure-read-project-list) - (when-let* ((ent (assoc (abbreviate-file-name project-root) project--list))) + (when-let* ((ent (assoc project-root project--list))) (setq project--list (delq ent project--list)) (message report-message project-root) (project--write-project-list))) From 583a112169f0c964552b94f84ea0c942377a14e6 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 10 Feb 2026 02:50:17 +0200 Subject: [PATCH 139/191] Do cache and timed invalidation in "VC-aware" project backend * lisp/progmodes/project.el: Describe the new cache in Commentary, the "VC-aware project" section. (project-vc-cache-timeout) (project-vc-non-essential-cache-timeout): New variables. (project--get-cached, project--set-cached): New functions. (project-try-vc, project--value-in-dir): Use them. (project--read-dir-locals): New function, extracted from the above. Return the full alist, to be saved to cache at once. (project--clear-cache): New function. (project-remember-projects-under) (project-forget-zombie-projects, project-forget-projects-under): Use it. (project-uniquify-dirname-transform, project-mode-line-format): Bind 'non-essential' to choose the longer caching strategy. (project-name-cache-timeout, project-name-cached): Remove. (project-mode-line-format): Switch to calling 'project-name' directly, with the new caching in use. Co-authored-by: Juri Linkov --- doc/emacs/maintaining.texi | 4 ++ etc/NEWS | 5 ++ lisp/progmodes/project.el | 133 +++++++++++++++++++++++++++---------- 3 files changed, 107 insertions(+), 35 deletions(-) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 305487b4e6d..91784ff71ef 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2323,6 +2323,10 @@ configuration (if any), excluding the ``ignored'' files from the output. It has some performance optimizations for listing the files with some of the popular VCS systems (currently Git and Mercurial). +It also uses a cache for some of the computations, for shorter or longer +periods of time, depending on whether it's being used from an +interactive command, or from non-essential code running in background. + @defopt project-vc-include-untracked By default, files which are neither registered with nor ignored by the VCS are considered part of the project. Customize this variable to nil diff --git a/etc/NEWS b/etc/NEWS index fb78b3f7b5e..61dd9899edc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -726,6 +726,11 @@ If the value of 'project-mode-line' is 'non-remote', project name and the Project menu will be shown on the mode line only for projects with local files. +*** The "VC-aware" project backend caches the current project and its name. +The duration for which the values are cached depends on whether it's +called from 'non-essential' context, and it determined by variables +'project-vc-cache-timeout' and 'project-vc-non-essential-cache-timeout'. + ** Help +++ diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index efd79d0155b..f8dc629d11d 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -84,6 +84,12 @@ ;; This project type can also be used for non-VCS controlled ;; directories, see the variable `project-vc-extra-root-markers'. ;; +;; Some of the methods on this backend cache their computations for time +;; determined either by variable `project-vc-cache-timeout' or +;; `project-vc-non-essential-cache-timeout', depending on whether the +;; MAYBE-PROMPT argument to `project-current' is non-nil, or the value +;; of `non-essential' when project methods are called. +;; ;; Utils: ;; ;; `project-combine-directories' and `project-subtract-directories', @@ -587,16 +593,72 @@ project backend implementation of `project-external-roots'.") See `project-vc-extra-root-markers' for the marker value format.") -;; FIXME: Should perhaps use `vc--repo-*prop' functions -;; (after promoting those to public). --spwhitton +(defvar project-vc-cache-timeout '((file-remote-p . nil) + (always . 2)) + "Number of seconds to cache a value in VC-aware project methods. +It can be nil, a number, or an alist where +the key is a predicate, and the value is a number. +Set to nil to disable time-based expiration.") + +(defvar project-vc-non-essential-cache-timeout '((file-remote-p . nil) + (always . 300)) + "Number of seconds to cache non-essential information. +Unlike `project-vc-cache-timeout' intended for interactive +commands, this variable has much more aggressive caching, +and is intended for \"background\" things like `project-mode-line' +indicators and `project-uniquify-dirname-transform'. +It is used when `non-essential' is non-nil.") + +(defun project--get-cached (dir key) + (let ((cached (vc-file-getprop dir key)) + (current-time (float-time))) + (when (and (numberp (cdr cached)) + ;; Support package upgrade mid-session. + (let* ((project-vc-cache-timeout + (if non-essential + project-vc-non-essential-cache-timeout + project-vc-cache-timeout)) + (timeout + (cond + ((numberp project-vc-cache-timeout) + project-vc-cache-timeout) + ((null project-vc-cache-timeout) + nil) + ((listp project-vc-cache-timeout) + (cdr + (seq-find (lambda (pair) + (and (functionp (car pair)) + (funcall (car pair) dir))) + project-vc-cache-timeout))) + (t nil)))) + (or (null timeout) + (< (- current-time (cdr cached)) timeout)))) + (car cached)))) + +(defun project--set-cached (dir key value) + (vc-file-setprop dir key (cons value (float-time)))) + +;; TODO: We can have our own, separate obarray. +(defun project--clear-cache () + (obarray-map + (lambda (sym) + (if (get sym 'project-vc) + (put sym 'project-vc nil))) + vc-file-prop-obarray)) + (defun project-try-vc (dir) - ;; FIXME: Learn to invalidate when the value changes: - ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'. - (or (vc-file-getprop dir 'project-vc) - ;; FIXME: Cache for a shorter time (bug#78545). - (let ((res (project-try-vc--search dir))) - (and res (vc-file-setprop dir 'project-vc res)) - res))) + "Returns a project value corresponding to DIR from the VC-aware backend. + +The value is cached, and depending on whether MAYBE-PROMPT was non-nil +in the `project-current' call, the timeout is determined by +`project-vc-cache-timeout' or `project-vc-non-essential-cache-timeout'." + (let ((cached (project--get-cached dir 'project-vc))) + (if (eq cached 'none) + nil + (or cached + (let ((res (project-try-vc--search dir))) + (project--set-cached dir 'project-vc (or res 'none)) + res))))) (defun project-try-vc--search (dir) (let* ((backend-markers @@ -897,13 +959,24 @@ DIRS must contain directory names." (cl-set-difference files dirs :test #'file-in-directory-p)) (defun project--value-in-dir (var dir) + (alist-get + var + (let ((cached (project--get-cached dir 'project-vc-dir-locals))) + (if (eq cached 'none) + nil + (or cached + (let ((res (project--read-dir-locals dir))) + (project--set-cached dir 'project-vc-dir-locals (or res 'none)) + res)))) + (symbol-value var))) + +(defun project--read-dir-locals (dir) (with-temp-buffer (setq default-directory (file-name-as-directory dir)) + ;; Don't use `hack-local-variables-apply' to avoid setting modes. (let ((enable-local-variables :all)) (hack-dir-local-variables)) - ;; Don't use `hack-local-variables-apply' to avoid setting modes. - (alist-get var file-local-variables-alist - (symbol-value var)))) + file-local-variables-alist)) (cl-defmethod project-buffers ((project (head vc))) (let* ((root (expand-file-name (file-name-as-directory (project-root project)))) @@ -925,6 +998,11 @@ DIRS must contain directory names." (nreverse bufs))) (cl-defmethod project-name ((project (head vc))) + "Returns the name of this VC-aware type PROJECT. + +The value is cached, and depending on whether `non-essential' is nil, +the timeout is determined by `project-vc-cache-timeout' or +`project-vc-non-essential-cache-timeout'." (or (project--value-in-dir 'project-vc-name (project-root project)) (cl-call-next-method))) @@ -2386,6 +2464,7 @@ projects. Display a message at the end summarizing what was found. Return the number of detected projects." (interactive "DDirectory: \nP") + (project--clear-cache) (project--ensure-read-project-list) (let ((dirs (if recursive (directory-files-recursively dir "" t) @@ -2429,6 +2508,7 @@ projects should be deleted." (defun project-forget-zombie-projects (&optional interactive) "Forget all known projects that don't exist any more." (interactive (list t)) + (project--clear-cache) (let ((pred (when interactive (alist-get 'interactively project-prune-zombie-projects)))) (project--delete-zombie-projects pred))) @@ -2441,6 +2521,7 @@ to remove those projects from the index. Display a message at the end summarizing what was forgotten. Return the number of forgotten projects." (interactive "DDirectory: \nP") + (project--clear-cache) (let ((count 0)) (if recursive (dolist (proj (project-known-project-roots)) @@ -2630,7 +2711,8 @@ slash-separated components from `project-name' will be appended to the buffer's directory name when buffers from two different projects would otherwise have the same name." (if-let* ((proj (project-current nil dirname))) - (let ((root (project-root proj))) + (let ((root (project-root proj)) + (non-essential t)) (expand-file-name (file-name-concat (file-name-directory root) @@ -2640,27 +2722,6 @@ would otherwise have the same name." ;;; Project mode-line -(defvar project-name-cache-timeout 300 - "Number of seconds to cache the project name. -Used by `project-name-cached'.") - -(defun project-name-cached (dir) - "Return the cached project name for the directory DIR. -Until it's cached, retrieve the project name using `project-current' -and `project-name', then put the name to the cache for the time defined -by the variable `project-name-cache-timeout'. This function is useful -for project indicators such as on the mode line." - (let ((cached (vc-file-getprop dir 'project-name)) - (current-time (float-time))) - (if (and cached (< (- current-time (cdr cached)) - project-name-cache-timeout)) - (let ((value (car cached))) - (if (eq value 'none) nil value)) - (let ((res (when-let* ((project (project-current nil dir))) - (project-name project)))) - (vc-file-setprop dir 'project-name (cons (or res 'none) current-time)) - res)))) - ;;;###autoload (defcustom project-mode-line nil "Whether to show current project name and Project menu on the mode line. @@ -2697,7 +2758,9 @@ value is `non-remote', show the project name only for local files." ;; 'last-coding-system-used' when reading the project name ;; from .dir-locals.el also enables flyspell-mode (bug#66825). (when-let* ((last-coding-system-used last-coding-system-used) - (project-name (project-name-cached default-directory))) + (non-essential t) + (project (project-current)) + (project-name (project-name project))) (concat " " (propertize From f2b81c38c2365507ad0b579fed4fd918117c3f00 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 10 Feb 2026 11:46:25 +0000 Subject: [PATCH 140/191] vc-git--deduce-files-for-stash: Use file-relative-name (bug#80278) * lisp/vc/vc-git.el (vc-git--deduce-files-for-stash): Use file-relative-name (bug#80278). --- lisp/vc/vc-git.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 85e90bfc25a..5e51b28fb37 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -2592,9 +2592,9 @@ This command shares argument histories with \\[rgrep] and \\[grep]." ;; In *vc-dir*, if nothing is marked, act on the whole working tree ;; regardless of the position of point. This preserves historical ;; behavior and is also probably more useful. - (if (derived-mode-p 'vc-dir-mode) - (vc-dir-marked-files) - (cadr (vc-deduce-fileset)))) + (mapcar #'file-relative-name (if (derived-mode-p 'vc-dir-mode) + (vc-dir-marked-files) + (cadr (vc-deduce-fileset))))) (defun vc-git-stash (name) "Create a stash named NAME. From d91d8c98f825b1d51837bb44f632a075fec32e0d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Tue, 10 Feb 2026 17:09:56 +0200 Subject: [PATCH 141/191] * src/process.c (server_accept_connection): Fix assertion (bug#80237). --- src/process.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/process.c b/src/process.c index ac29d403c6f..d40500cc050 100644 --- a/src/process.c +++ b/src/process.c @@ -5137,11 +5137,15 @@ server_accept_connection (Lisp_Object server, int channel) /* If the server process is locked to this thread, lock the client process to the same thread, otherwise clear the thread of its I/O descriptors. */ - eassert (!fd_callback_info[p->infd].thread); if (NILP (ps->thread)) - set_proc_thread (p, NULL); + { + eassert (!fd_callback_info[p->infd].thread); + set_proc_thread (p, NULL); + } else { + eassert (!fd_callback_info[p->infd].thread + || fd_callback_info[p->infd].thread == XTHREAD (ps->thread)); eassert (XTHREAD (ps->thread) == current_thread); set_proc_thread (p, XTHREAD (ps->thread)); } From d62370a0ec5bef48fcbe4dd14e8b9e129a0d0cae Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 10 Feb 2026 18:56:31 +0200 Subject: [PATCH 142/191] Improve project-vc-*cache-timeout docstrings * lisp/progmodes/project.el: (project-vc-cache-timeout) (project-vc-non-essential-cache-timeout): Improve docstrings (bug#78545). --- lisp/progmodes/project.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index f8dc629d11d..9e5a8be5e13 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -598,15 +598,17 @@ See `project-vc-extra-root-markers' for the marker value format.") "Number of seconds to cache a value in VC-aware project methods. It can be nil, a number, or an alist where the key is a predicate, and the value is a number. +A predicate function should take a directory string and if it returns +non-nil, the corresponding value will be used as the timeout. Set to nil to disable time-based expiration.") (defvar project-vc-non-essential-cache-timeout '((file-remote-p . nil) (always . 300)) "Number of seconds to cache non-essential information. -Unlike `project-vc-cache-timeout' intended for interactive -commands, this variable has much more aggressive caching, -and is intended for \"background\" things like `project-mode-line' -indicators and `project-uniquify-dirname-transform'. +The format of the value is same as `project-vc-cache-timeout', but while +the former is intended for interactive commands, this variable uses +higher numbers, intended for \"background\" things like +`project-mode-line' indicators and `project-uniquify-dirname-transform'. It is used when `non-essential' is non-nil.") (defun project--get-cached (dir key) From 79fda663272636345927a88fbc38b73953668a67 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 11 Feb 2026 09:19:52 +0200 Subject: [PATCH 143/191] Revert "New key 'M-j' for 'icomplete-mode' (bug#62108)" This reverts commit 3584a762b8cbfb6e13011827ec5934f039344d0f. Another fix follows shortly after this commit. --- etc/NEWS | 4 ---- lisp/icomplete.el | 3 --- lisp/replace.el | 3 --- 3 files changed, 10 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 61dd9899edc..0388d47b87e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3092,10 +3092,6 @@ Meant to be given a global binding convenient to the user. Example: ** Icomplete -*** New key 'M-j' for 'icomplete-mode' and 'icomplete-vertical-mode'. -Like 'M-j' in 'fido-mode', it can exit the minibuffer with a selected -candidate even when 'icomplete-show-matches-on-no-input' is non-nil. - *** New user options for 'icomplete-vertical-mode'. New user options have been added to enhance 'icomplete-vertical-mode': diff --git a/lisp/icomplete.el b/lisp/icomplete.el index c1d9556e24d..6de3dd0b50a 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -242,7 +242,6 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") :doc "Keymap used by `icomplete-mode' in the minibuffer." "C-M-i" #'icomplete-force-complete "C-j" #'icomplete-force-complete-and-exit - "M-j" #'icomplete-exit "C-." #'icomplete-forward-completions "C-," #'icomplete-backward-completions " " #'icomplete-ret) @@ -456,8 +455,6 @@ if that doesn't produce a completion match." (minibuffer-complete-and-exit) (exit-minibuffer))) -(defalias 'icomplete-exit #'icomplete-fido-exit) - (defun icomplete-fido-backward-updir () "Delete char before or go up directory, like `ido-mode'." (interactive) diff --git a/lisp/replace.el b/lisp/replace.el index d8b27544128..933249d824c 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1878,9 +1878,6 @@ is not modified." (bound-and-true-p ido-everywhere)) (substitute-command-keys "(\\\\[ido-select-text] to end): ")) - ((bound-and-true-p icomplete-mode) - (substitute-command-keys - "(\\\\[icomplete-exit] to end): ")) ((bound-and-true-p fido-mode) (substitute-command-keys "(\\\\[icomplete-fido-exit] to end): ")) From f13ab20f0456f311bc5e1374db2e638bed17f8e9 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 11 Feb 2026 09:50:34 +0200 Subject: [PATCH 144/191] Don't remap RET to 'icomplete-ret' in 'icomplete-mode' (bug#62108) * lisp/icomplete.el (icomplete-show-matches-on-no-input): Fix docstring. (icomplete-minibuffer-map): Don't remap 'minibuffer-complete-and-exit' (RET) to 'icomplete-ret'. (icomplete-ret): Improve docstring. --- etc/NEWS | 12 ++++++++++++ lisp/icomplete.el | 15 +++++++++------ 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 0388d47b87e..757a84070ac 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3092,6 +3092,18 @@ Meant to be given a global binding convenient to the user. Example: ** Icomplete +*** Change in meaning of 'icomplete-show-matches-on-no-input' (again). +Previously, choosing a different completion with commands like 'C-.' +and then hitting 'RET' would choose the completion under point +when 'icomplete-show-matches-on-no-input' is customized to non-nil. +Doing this will now choose the default value instead. There is +still 'C-j' to choose the completion under point in 'icomplete-mode'. +You can get back the old behavior of the 'RET' key with + + (keymap-set + icomplete-minibuffer-map " " + #'icomplete-ret) + *** New user options for 'icomplete-vertical-mode'. New user options have been added to enhance 'icomplete-vertical-mode': diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 6de3dd0b50a..b7002fa545b 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -80,10 +80,10 @@ selection process starts again from the user's $HOME." "When non-nil, show completions when first prompting for input. This means to show completions even when the current minibuffer contents is the same as was the initial input after minibuffer activation. -This also means that if you traverse the list of completions with -commands like \\`C-.' and just hit \\`RET' without typing any +This also means that if you just hit \\`C-j' without typing any characters, the match under point will be chosen instead of the -default." +default. But \\`RET' will still choose the default value exactly +as when this option is nil." :type 'boolean :version "24.4") @@ -243,11 +243,14 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") "C-M-i" #'icomplete-force-complete "C-j" #'icomplete-force-complete-and-exit "C-." #'icomplete-forward-completions - "C-," #'icomplete-backward-completions - " " #'icomplete-ret) + "C-," #'icomplete-backward-completions) (defun icomplete-ret () - "Exit minibuffer for icomplete." + "Exit minibuffer for icomplete. +You can bind this command to \\`RET' in `icomplete-minibuffer-map', +or remap from `minibuffer-complete-and-exit', to be able to choose +the completion under point with \\`RET' instead of choosing the +default value." (interactive) (if (and icomplete-show-matches-on-no-input (car completion-all-sorted-completions) From 0bee754a7204f911f934d750f6f1870c929ccdb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Marks?= Date: Wed, 4 Feb 2026 18:20:55 -0500 Subject: [PATCH 145/191] system-sleep sleep blocker and sleep/wake event package (bug#80348) This package provides platform-neutral interfaces to block your system from entering idle sleep and a hook to process pre-sleep and post-wake events. Implementations are for D-Bus on GNU/Linux, macOS/GNUstep, and MS-Windows. * lisp/system-sleep.el: New package. * src/fns.c: Qpre_sleep, Qpost_wake: New DEFSYM. * src/nsfns.m (Fns_block_system_sleep, Fns_unblock_system_sleep) (syms_of_nsfns): New functions. * src/nsterm.m (applicationDidFinishLaunching): Subscribe to pre-sleep and post-wake notifications. (systemWillSleep, systemDidWake): New function. * src/w32fns.c (Fw32_block_system_sleep) (Fw32_unblock_system_sleep, Fw32_system_sleep_block_count) (sleep_notification_callback) (w32_register_for_sleep_notifications): New function. (syms_of_w32fns): Sw32_unblock_system_sleep Sw32_block_system_sleep Sw32_system_sleep_block_count: New defsubr. * src/w32term.h (Fw32_block_system_sleep): New extern. * src/w32term.c (w32_initialize): Call w32_register_for_sleep_notifications. * doc/lispref/os.texi: Document the system-sleep package. * doc/lispref/commands.texi: Update sleep-event special documentation. * etc/NEWS: Announce the new package. --- doc/lispref/commands.texi | 10 +- doc/lispref/os.texi | 68 +++++ etc/NEWS | 16 ++ lisp/system-sleep.el | 513 ++++++++++++++++++++++++++++++++++++++ src/fns.c | 4 + src/nsfns.m | 84 +++++++ src/nsterm.m | 48 +++- src/w32fns.c | 145 +++++++++++ src/w32term.c | 1 + src/w32term.h | 1 + 10 files changed, 876 insertions(+), 14 deletions(-) create mode 100644 lisp/system-sleep.el diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index b907ba96bed..0583179ed31 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -2778,12 +2778,12 @@ To test the signal handler, you can make Emacs send a signal to itself: @end smallexample @cindex @code{sleep-event} event -@item (sleep-event @var{sleep-wake}) -This event is injected when the device Emacs is running on enters or -leaves the sleep state. A non-@code{nil} @var{sleep-wake} indicates -entering the sleep state. +@item (sleep-event @var{state}) +This event is injected when the device Emacs is running on is about to +enter a sleep state, or has just awoken from one. @var{state} will be +the symbol @code{pre-sleep} or @code{post-wake}. -This is implemented only on GNU/Linux. +This is implemented on GNU/Linux, macOS, and MS-Windows. @cindex @code{language-change} event @item language-change diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index c5ba86dddee..0e669c70592 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -35,6 +35,7 @@ terminal and the screen. * Session Management:: Saving and restoring state with X Session Management. * Desktop Notifications:: Desktop notifications. * System Taskbar:: Controlling system GUI taskbar features. +* System Sleep:: Block system sleep and process sleep events. * File Notifications:: File notifications. * Dynamic Libraries:: On-demand loading of support libraries. * Security Considerations:: Running Emacs in an unfriendly environment. @@ -3493,6 +3494,73 @@ Examples of system taskbar functions: @end group @end lisp +@node System Sleep +@section Block System Sleep and Process Sleep Events +@cindex system sleep +@cindex mode, system sleep + +@defun system-sleep-block-sleep &optional why allow-display-sleep +This function blocks the system from entering its idle sleep state. + +It returns a token that must be passed to +@code{system-sleep-unblock-sleep} to unblock this specific block (other +sleep blocks may be simultaneously in force for other purposes). +Otherwise, it returns @code{nil} if the sleep blocking fails. + +@var{why} is a string and, when non-nil, is used to identify the sleep +block as it may appear on the system's inspectable block lists. It +defaults to ``Emacs''. + +If @var{allow-display-sleep} is non-nil, allow the display to sleep. By +default, the display is kept active. + +Note: ​When the Emacs process dies, blocks are released on all platforms. +@end defun + +@defun system-sleep-unblock-sleep token +This function unblocks the sleep block associated with @var{token}. It +returns non-@code{nil} on success, otherwise returns @code{nil}. +@end defun + +@defmac with-system-sleep-block (&optional why allow-display-sleep) body@dots{} +This is a convenience macro that lets you wrap the forms in @var{body} +with a sleep block that is unblocked for you when @var{body} completes. +The arguments have the same meaning as in +@code{system-sleep-block-sleep}, above. +@end defmac + +@defun system-sleep-sleep-blocked-p +This predicate function returns non-@code{nil} on if there are any +active @code{system-sleep} blocks, otherwise returns @code{nil}. +@end defun + +@defun system-sleep-unblock-all-sleep-blocks +This function unblocks all active sleep blocks. It is unlikely that you +will need to call this function. +@end defun + +@defopt system-sleep-event-functions +When the system is about to enter a sleep state or after it wakes from +one, each function on this abnormal hook is called with one argument, +@var{event}, a sleep event. Its state can be retrieved via +@samp{@code{(sleep-event-state event)}}. State will be one of the +symbols @code{pre-sleep} or @code{post-wake}. + +Handling @code{pre-sleep} events should be done as fast as possible and +avoid user prompting. Systems often grant a very short pre-sleep +processing interval, typically ranging between 2 and 5 seconds. The +system may sleep even if your processing is not complete, so be sure you +do as little as possible. For example, your function could close active +connections or serial ports. + +Handling @code{post-wake} events offers more leeway. Use this, for +example, to reestablish connections. + +Note: Your code, or the functions it calls, should not raise any signals +or all hooks will be halted. You can wrap your code in a +@code{condition-case} block (@pxref{Errors}). +@end defopt + @node File Notifications @section Notifications on File Changes @cindex file notifications diff --git a/etc/NEWS b/etc/NEWS index 757a84070ac..abf4b3d10a3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3597,6 +3597,22 @@ On GNU/Linux systems, shell extensions or similar helpers such as and . ++++ +** New package 'system-sleep'. +This package provides platform-neutral interfaces to block your system +from entering idle sleep and a hook to process pre-sleep and post-wake +events. You can use this to avoid the system entering an idle sleep +state and interrupting a long-running process due to lack of user +activity. The sleep event hook lets you, for example close external +connections or serial ports before sleeping, and reestablish them when +the system wakes up. + +Supported capable systems are GNU/Linux via D-Bus (sleep blocking and +events require the org.freedesktop.login1 service, display sleep +blocking requires org.freedesktop.Screensaver service), macOS +(sleep/display blocking requires 10.9+, sleep events are supported on +all versions), MS-Windows (sleep blocking is supported on all versions, +sleep events require 8+). * Incompatible Lisp Changes in Emacs 31.1 diff --git a/lisp/system-sleep.el b/lisp/system-sleep.el new file mode 100644 index 00000000000..bd14e9d0e50 --- /dev/null +++ b/lisp/system-sleep.el @@ -0,0 +1,513 @@ +;;; system-sleep.el --- System sleep/wake event management -*- lexical-binding: t -*- + +;; Copyright (C) 2025-2026 Free Software Foundation, Inc. + +;; Author: Stephane Marks +;; Maintainer: emacs-devel@gnu.org +;; Keywords: convenience +;; Package-Requires: ((emacs "31.1")) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Call `system-sleep-block-sleep' to inhibit system-wide idle sleep. +;; Idle sleep is typically triggered when the system does not detect +;; user activity and is independent of any processing that may be on +;; going. This function is useful to block idle sleep for long-running +;; operations, for example, when a compilation is running. You have the +;; option of keeping the system active while letting the display sleep. +;; This function returns a token which you must use to unblock this +;; request. +;; +;; Call `system-sleep-unblock-sleep' with the token from +;; `system-sleep-block-sleep' to unblock system-wide idle sleep for this +;; request. There may be other active requests which will prevent the +;; system from sleeping. +;; +;; The function `system-sleep-sleep-blocked-p' will tell you if +;; `system-sleep' has any active system sleep blocks. +;; +;; Note: ​When the Emacs process dies, blocks are released on all +;; platforms. +;; +;; You can register functions on the abnormal hook +;; `system-sleep-event-functions'. Each function will be called when +;; the system is preparing for sleep and when the system wakes from +;; sleep. These functions are useful when you want to close (and +;; potentially reopen) external connections or serial ports. +;; +;; On supported GNU/Linux systems, the implementation is via D-Bus to +;; inhibit idle sleep, keep the display active, and forward events from +;; logind for system sleep events. +;; +;; On macOS and MS-Windows, native APIs are used to block idle sleep, +;; keep the display active, and provide sleep event notifications. +;; +;; On MS-Windows, an idle sleep block that keeps the display active may +;; not inhibit the screen saver. +;; +;; Externally to Emacs, there are system utility functions that you can +;; use to inspect all processes on your system that might be blocking it +;; from sleeping. +;; +;; On D-Bus systems, you can use the commands: +;; +;; systemd-inhibit --list +;; or +;; dbus-send --system --print-reply --dest=org.freedesktop.login1 \ +;; /org/freedesktop/login1 \ +;; org.freedesktop.login1.Manager.ListInhibitors +;; +;; Note: You can find the sleep/shutdown delay InhibitDelayMaxUSec in +;; the file logind.conf(5) which typically defaults to 5 seconds. +;; +;; On macOS, you can use the command: +;; +;; pmset -g assertions +;; +;; On MS-Windows, you can use the following command which may need to be +;; run as an administrator: +;; +;; powercfg -requests + +;;; Code: + +(require 'cl-lib) + +;; Pacify the byte compiler. +(declare-function dbus--fd-close "dbusbind.c") +(declare-function dbus-unregister-object "dbus.el") +(declare-function dbus-register-signal "dbus.el") +(declare-function dbus-call-method "dbus.el") +(declare-function dbus-list-activatable-names "dbus.el") +(defvar dbus-service-emacs) + +(defgroup system-sleep nil + "System sleep/wake blocking and event management." + :group 'system-interface + :version "31.1") + +(defvar system-sleep--back-end nil + "Generic sleep-wake method system dispatcher.") + +(defvar system-sleep--sleep-block-tokens nil + "A list of active sleep-block tokens. +If non-nil, idle sleep is inhibited by `system-sleep'.") + +(cl-defstruct + (sleep-event (:type list) :named + (:constructor nil) + (:constructor make-sleep-event (state))) + state) + +;;;###autoload +(defcustom system-sleep-event-functions nil + "Abnormal hook invoked on system sleep events. +Each function is called with one argument EVENT, a sleep event. EVENT +state can be retrieved via \\+`(sleep-event-state EVENT)'. It will be +one of the symbols \\+`pre-sleep' or \\+`post-wake'. + +Handling \\+`pre-sleep' events should be done as fast as possible, do as +little as possible and avoid user prompts. Systems often grant a very +short pre-sleep processing interval, typically ranging between 2 and 5 +seconds. The system may sleep even if your processing is not complete. +For example, your function could close active connections or serial +ports. + +Handling \\+`post-wake' events offers more leeway. Your function could +reestablish connections. + +Note: Your code, or the functions it calls, should not raise any signals +or all hooks will be halted preventing other hook functions from +cleaning up or waking up. You can wrap your code in a `condition-case' +block." + :type 'hook + :version "31.1") + +;;;###autoload +(defun system-sleep-block-sleep (&optional why allow-display-sleep) + "Inhibit system idle sleep. +Optional WHY is a string that identifies a sleep block to system utility +commands that inspect system-wide blocks. WHY defaults to \"Emacs\". + +Optional ALLOW-DISPLAY-SLEEP, when non-nil, allows the display to sleep +or a screen saver to run while the system idle sleep is blocked. The +default is to keep the display active. + +Return a sleep blocking token. You must retain this value and provide +it to `system-sleep-unblock-sleep' to unblock its associated block. + +Return nil if system sleep cannot be inhibited. + +Note: All active blocks are released when the Emacs process dies. +Despite this, you should unblock your blocks when your processing is +complete. See `with-system-sleep-block' for an easy way to do that." + (when system-sleep--back-end + (system-sleep--block-sleep (or why "Emacs") allow-display-sleep))) + +(defun system-sleep-unblock-sleep (token) + "Unblock the system sleep block associated with TOKEN. +Return non-nil TOKEN was unblocked, or nil if not. +In the unlikely event that unblock fails, the block will be released +when the Emacs process dies." + (when system-sleep--back-end + (system-sleep--unblock-sleep token))) + +;;;###autoload +(defmacro with-system-sleep-block (&optional why allow-display-sleep &rest body) + "Execute the forms in BODY while blocking system sleep. +The optional arguments WHY and ALLOW-DISPLAY-SLEEP have the same meaning +as in `system-sleep-block-sleep', which see. +The block is unblocked when BODY completes." + (declare (indent 1) (debug t)) + (let ((token (make-symbol "--sleep-token--"))) + `(let ((,token (system-sleep-block-sleep ,why ,allow-display-sleep))) + (unwind-protect + (progn + ,@body) + (system-sleep-unblock-sleep ,token))))) + +(defun system-sleep-unblock-all-sleep-blocks () + "Unblock all `system-sleep' blocks." + (while system-sleep--sleep-block-tokens + (system-sleep-unblock-sleep (car system-sleep--sleep-block-tokens)))) + +;;;###autoload +(defun system-sleep-sleep-blocked-p () + "Return non-nil if there are active sleep blocks." + (and system-sleep--back-end + system-sleep--sleep-block-tokens)) + + +;; Internal implementation. + +(defun system-sleep--set-back-end () + "Determine sleep/wake host system type." + ;; Order matters to accommodate the cases where an NS or MS-Windows + ;; build have the dbus feature. + (setq system-sleep--back-end + (cond ((featurep 'ns) 'ns) + ((featurep 'w32) 'w32) + ((and (require 'dbus) + (featurep 'dbusbind) + (member "org.freedesktop.login1" + (dbus-list-activatable-names :system))) + 'dbus) + (t nil)))) + +(defun system-sleep--sleep-event-handler (event) + "`sleep-event' EVENT handler." + (declare (completion ignore)) + (interactive "e") + (run-hook-with-args 'system-sleep-event-functions event)) + +(defun system-sleep-enable () + "Enable `system-sleep'." + (unless system-sleep--back-end + (if (and (system-sleep--set-back-end) + (system-sleep--enable)) + (keymap-set special-event-map "" + #'system-sleep--sleep-event-handler) + (warn "`system-sleep' could not be initialized")))) + +(defun system-sleep-disable () + "Disable `system-sleep'." + (when system-sleep--back-end + (keymap-set special-event-map "" #'ignore) + (system-sleep-unblock-all-sleep-blocks) + (system-sleep--disable) + (setq system-sleep--back-end nil))) + +(cl-defgeneric system-sleep--enable () + "Enable the `system-sleep' back end. +Return t if the back end is initialized, or nil.") + +(cl-defgeneric system-sleep--disable () + "Disable the sleep/wake back end.") + +(cl-defgeneric system-sleep--block-sleep (why allow-display-sleep) + "Inhibit system idle sleep. +WHY is a string that identifies a sleep block to system utility commands +that inspect system-wide blocks. +When non-nil, ALLOW-DISPLAY-SLEEP allows the display to sleep or a +screen saver to run while the system idle sleep is blocked. The default +is to keep the display active. +Return a sleep-block token.") + +(cl-defgeneric system-sleep--unblock-sleep (token) + "Unblock the system sleep block associated with TOKEN. +Return non-nil TOKEN was unblocked, or nil if not.") + +(defvar system-sleep--event-in-progress nil) +(defvar system-sleep--event-queue nil) + +(defun system-sleep--sleep-event-function (event) + "Handle special events and avoid races." + ;; Queue incoming event. + (setq system-sleep--event-queue + (append system-sleep--event-queue (list event))) + ;; If an event is already in progress, return right away. + ;; Otherwise, process queued events. + (while (and (not system-sleep--event-in-progress) + system-sleep--event-queue) + (let ((current-event (pop system-sleep--event-queue))) + (setq system-sleep--event-in-progress current-event) + (unwind-protect + (run-hook-with-args 'system-sleep-event-functions + current-event) + (setq system-sleep--event-in-progress nil))))) + + +;; D-Bus support. + +(defvar system-sleep--dbus-sleep-inhibitor-types "sleep" + "This is a colon-separated list of options. +The default is \"sleep\" which is compatible with the other supported +`system-sleep' platforms. This could also be +\"sleep:shutdown\". Shutdown is available only on D-Bus systems.") + +(defvar system-sleep--dbus-delay-lock nil) +(defvar system-sleep--dbus-pre-sleep-signal nil) + +(defun system-sleep--dbus-delay-lock (make-or-close) + (cond (make-or-close + (if system-sleep--dbus-delay-lock + (error "Delay lock should be nil") + (setq system-sleep--dbus-delay-lock + (dbus-call-method + :system + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "Inhibit" + :keep-fd + system-sleep--dbus-sleep-inhibitor-types + dbus-service-emacs + "Emacs sleep event watcher" + "delay")))) + (t + (when system-sleep--dbus-delay-lock + (dbus--fd-close system-sleep--dbus-delay-lock) + (setq system-sleep--dbus-delay-lock nil))))) + +(defun system-sleep--dbus-prepare-for-sleep-callback (sleep-or-wake) + (cond (sleep-or-wake + (insert-special-event (make-sleep-event 'pre-sleep))) + (t + (insert-special-event (make-sleep-event 'post-wake))))) + +(defun system-sleep--dbus-prepare-for-sleep-watcher (make-or-close) + (cond (make-or-close + (if system-sleep--dbus-pre-sleep-signal + (error "PrepareForSleep watcher should be nil") + (setq system-sleep--dbus-pre-sleep-signal + (dbus-register-signal + :system + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "PrepareForSleep" + #'system-sleep--dbus-prepare-for-sleep-callback)))) + (t + (dbus-unregister-object system-sleep--dbus-pre-sleep-signal) + (setq system-sleep--dbus-pre-sleep-signal nil)))) + +(defun system-sleep--dbus-prepare-for-sleep-function (event) + (pcase (sleep-event-state event) + ('pre-sleep + (system-sleep--dbus-delay-lock nil)) + ('post-wake + (system-sleep--dbus-delay-lock t)))) + +(cl-defmethod system-sleep--enable (&context + (system-sleep--back-end (eql 'dbus))) + ;; Order matters. + (add-hook 'system-sleep-event-functions + #'system-sleep--dbus-prepare-for-sleep-function + ;; This must run last. + 99) + (system-sleep--dbus-delay-lock t) + (system-sleep--dbus-prepare-for-sleep-watcher t) + t) + +(cl-defmethod system-sleep--disable (&context + (system-sleep--back-end (eql 'dbus))) + (system-sleep--dbus-prepare-for-sleep-watcher nil) + (system-sleep--dbus-delay-lock nil) + (remove-hook 'system-sleep-event-functions + #'system-sleep--dbus-prepare-for-sleep-function)) + +(cl-defmethod system-sleep--block-sleep (why + allow-display-sleep + &context + (system-sleep--back-end (eql 'dbus))) + (let ((subtokens)) + (if-let* ((sleep-cookie (dbus-call-method + :system + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "Inhibit" + :keep-fd + system-sleep--dbus-sleep-inhibitor-types + dbus-service-emacs + why + "block"))) + (progn + (let ((inhibit-quit t)) + (push (cons 'dbus-inhibitor-lock sleep-cookie) subtokens)) + (unless allow-display-sleep + (if-let* ((screen-cookie + (dbus-call-method + :session + "org.freedesktop.ScreenSaver" + "/org/freedesktop/ScreenSaver" + "org.freedesktop.ScreenSaver" + "Inhibit" + dbus-service-emacs + "Screen Saver Block"))) + (let ((inhibit-quit t)) + (push (cons 'dbus-screensaver-lock screen-cookie) subtokens)) + (warn "Unable to block the screen saver"))) + (let ((inhibit-quit t)) + (let ((token (list :system 'dbus :why why :subtokens subtokens))) + (push token system-sleep--sleep-block-tokens) + token))) + (warn "Unable to block system sleep")))) + +(cl-defmethod system-sleep--unblock-sleep (token + &context + (system-sleep--back-end (eql 'dbus))) + + (if (memq token system-sleep--sleep-block-tokens) + (progn + (let ((inhibit-quit t)) + (setq system-sleep--sleep-block-tokens + (remq token system-sleep--sleep-block-tokens))) + (dolist (subtoken (plist-get token :subtokens)) + (pcase (car subtoken) + ('dbus-inhibitor-lock + (dbus--fd-close (cdr subtoken))) + ('dbus-screensaver-lock + (dbus-call-method + :session + "org.freedesktop.ScreenSaver" + "/org/freedesktop/ScreenSaver" + "org.freedesktop.ScreenSaver" + "UnInhibit" + (cdr subtoken))))) + t) + (warn "Unknown `system-sleep' sleep token") + nil)) + + +;; macOS/GNUstep NS support. + +(declare-function ns-block-system-sleep "nsfns.m") +(declare-function ns-unblock-system-sleep "nsfns.m") + +(cl-defmethod system-sleep--enable (&context + (system-sleep--back-end (eql 'ns))) + t) + +(cl-defmethod system-sleep--disable (&context + (system-sleep--back-end (eql 'ns))) + (ignore)) + +(cl-defmethod system-sleep--block-sleep (why + allow-display-sleep + &context + (system-sleep--back-end (eql 'ns))) + (if-let* ((cookie (ns-block-system-sleep why allow-display-sleep)) + (token (list :system 'ns :why why + :token (cons 'ns-sleep-block cookie)))) + (progn + (let ((inhibit-quit t)) + (push token system-sleep--sleep-block-tokens)) + token) + (warn "Unable to block system sleep"))) + +(cl-defmethod system-sleep--unblock-sleep (token + &context + (system-sleep--back-end (eql 'ns))) + (if (memq token system-sleep--sleep-block-tokens) + (progn + (let ((inhibit-quit t)) + (setq system-sleep--sleep-block-tokens + (remq token system-sleep--sleep-block-tokens))) + (if (ns-unblock-system-sleep (cdr (plist-get token :token))) + t + (warn "Unable to unblock system sleep (blocks are released when Emacs dies)") + nil)) + (warn "Unknown `system-sleep' sleep token") + nil)) + + +;; MS-Windows support. + +(declare-function w32-block-system-sleep "w32fns.c") +(declare-function w32-unblock-system-sleep "w32fns.c") +(declare-function w32-system-sleep-block-count "w32fns.c") + +(defvar system-sleep--w32-sleep-block-count 0) + +(cl-defmethod system-sleep--enable (&context + (system-sleep--back-end (eql 'w32))) + t) + +(cl-defmethod system-sleep--disable (&context + (system-sleep--back-end (eql 'w32))) + (ignore)) + +(cl-defmethod system-sleep--block-sleep (why + allow-display-sleep + &context + (system-sleep--back-end (eql 'w32))) + (if-let* ((cookie (w32-block-system-sleep allow-display-sleep)) + (token (list :system 'w32 :why why + :token (cons 'w32-sleep-block cookie)))) + (progn + (let ((inhibit-quit t)) + (push token system-sleep--sleep-block-tokens)) + token) + (warn "Unable to block system sleep"))) + +(cl-defmethod system-sleep--unblock-sleep (token + &context + (system-sleep--back-end (eql 'w32))) + (if (memq token system-sleep--sleep-block-tokens) + (progn + (let ((inhibit-quit t)) + (setq system-sleep--sleep-block-tokens + (remq token system-sleep--sleep-block-tokens))) + (if (eq 0 (w32-system-sleep-block-count)) + (warn "Unable to unblock system sleep (no active tokens)") + (if (w32-unblock-system-sleep) + t + (warn "Unable to unblock system sleep (blocks are released when Emacs dies)") + nil))) + (warn "Unknown `system-sleep' sleep token") + nil)) + + +;; Initialize system-sleep. + +(system-sleep-enable) + +(provide 'system-sleep) + +;;; system-sleep.el ends here diff --git a/src/fns.c b/src/fns.c index 5c30d950cff..c29f9fa8cd1 100644 --- a/src/fns.c +++ b/src/fns.c @@ -6891,4 +6891,8 @@ For best results this should end in a space. */); DEFSYM (QCin_place, ":in-place"); DEFSYM (QCreverse, ":reverse"); DEFSYM (Qvaluelt, "value<"); + + /* sleep-event states. */ + DEFSYM (Qpre_sleep, "pre-sleep"); + DEFSYM (Qpost_wake, "post-wake"); } diff --git a/src/nsfns.m b/src/nsfns.m index cf685630ab7..3d3d5ec1bde 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -3805,6 +3805,88 @@ The position is returned as a cons cell (X . Y) of the return Qnil; } +/* A unique integer sleep block id and a hash map of its id to opaque + NSObject sleep block activity tokens. */ +static unsigned int sleep_block_id = 0; +static NSMutableDictionary *sleep_block_map = NULL; + +DEFUN ("ns-block-system-sleep", + Fns_block_system_sleep, + Sns_block_system_sleep, + 2, 2, 0, + doc: /* Block system idle sleep. +WHY is a string reason for the block. +If ALLOW-DISPLAY-SLEEP is non-nil, block the screen from sleeping. +Return a token to unblock this block using `ns-unblock-system-sleep', +or nil if the block fails. */) + (Lisp_Object why, Lisp_Object allow_display_sleep) +{ + block_input (); + + NSString *reason = @"Emacs"; + if (!NILP (why)) + { + CHECK_STRING (why); + reason = [NSString stringWithLispString: why]; + } + + unsigned long activity_options = + NSActivityUserInitiated | NSActivityIdleSystemSleepDisabled; + if (NILP (allow_display_sleep)) + activity_options |= NSActivityIdleDisplaySleepDisabled; + + NSProcessInfo *processInfo = [NSProcessInfo processInfo]; + NSObject *activity_id = nil; + if ([processInfo respondsToSelector:@selector(beginActivityWithOptions:reason:)]) + activity_id = [[NSProcessInfo processInfo] + beginActivityWithOptions: activity_options + reason: reason]; + unblock_input (); + + if (!sleep_block_map) + sleep_block_map = [[NSMutableDictionary alloc] initWithCapacity: 25]; + + if (activity_id) + { + [sleep_block_map setObject: activity_id + forKey: [NSNumber numberWithInt: ++sleep_block_id]]; + return make_fixnum (sleep_block_id); + } + else + return Qnil; +} + +DEFUN ("ns-unblock-system-sleep", + Fns_unblock_system_sleep, + Sns_unblock_system_sleep, + 1, 1, 0, + doc: /* Unblock system idle sleep. +TOKEN is an object returned by `ns-block-system-sleep'. +Return non-nil if the TOKEN block was unblocked. */) + (Lisp_Object token) +{ + block_input (); + Lisp_Object res = Qnil; + CHECK_FIXNAT (token); + if (sleep_block_map) + { + NSNumber *key = [NSNumber numberWithInt: XFIXNAT (token)]; + NSObject *activity_id = [sleep_block_map objectForKey: key]; + if (activity_id) + { + NSProcessInfo *processInfo = [NSProcessInfo processInfo]; + if ([processInfo respondsToSelector:@selector(endActivity:)]) + { + [[NSProcessInfo processInfo] endActivity: activity_id]; + res = Qt; + } + [sleep_block_map removeObjectForKey: key]; + } + } + unblock_input (); + return res; +} + #ifdef NS_IMPL_COCOA DEFUN ("ns-send-items", @@ -4091,6 +4173,8 @@ - (Lisp_Object)lispString defsubr (&Sns_badge); defsubr (&Sns_request_user_attention); defsubr (&Sns_progress_indicator); + defsubr (&Sns_block_system_sleep); + defsubr (&Sns_unblock_system_sleep); #ifdef NS_IMPL_COCOA defsubr (&Sns_send_items); #endif diff --git a/src/nsterm.m b/src/nsterm.m index c852b70be74..d0bbd1b4660 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5838,15 +5838,6 @@ static Lisp_Object ns_new_font (struct frame *f, Lisp_Object font_object, ns_pending_service_names = [[NSMutableArray alloc] init]; ns_pending_service_args = [[NSMutableArray alloc] init]; -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 260000 - /* Disable problematic event processing on macOS 26 (Tahoe) to avoid - scrolling lag and input handling issues. These are undocumented - options as of macOS 26.0. */ - [NSUserDefaults.standardUserDefaults - registerDefaults:@{@"NSEventConcurrentProcessingEnabled" : @"NO", - @"NSApplicationUpdateCycleEnabled" : @"NO"}]; -#endif - /* Start app and create the main menu, window, view. Needs to be here because ns_initialize_display_info () uses AppKit classes. The view will then ask the NSApp to stop and return to Emacs. */ @@ -6383,6 +6374,20 @@ - (void)applicationDidFinishLaunching: (NSNotification *)notification object:nil]; #endif +#ifdef NS_IMPL_COCOA + /* Sleep event notification. */ + [[[NSWorkspace sharedWorkspace] notificationCenter] + addObserver: self + selector:@selector(systemWillSleep:) + name: NSWorkspaceWillSleepNotification + object: nil]; + [[[NSWorkspace sharedWorkspace] notificationCenter] + addObserver: self + selector: @selector(systemDidWake:) + name: NSWorkspaceDidWakeNotification + object: nil]; +#endif + #ifdef NS_IMPL_COCOA /* Some functions/methods in CoreFoundation/Foundation increase the maximum number of open files for the process in their first call. @@ -6421,6 +6426,31 @@ - (void)antialiasThresholdDidChange:(NSNotification *)notification #endif } +/* Sleep event notification. */ + +- (void) systemWillSleep:(NSNotification *)notification +{ +#ifdef NS_IMPL_COCOA + NSTRACE ("[EmacsApp systemWillSleep:]"); + struct input_event ie; + EVENT_INIT (ie); + ie.kind = SLEEP_EVENT; + ie.arg = list1 (Qpre_sleep); + kbd_buffer_store_event (&ie); +#endif +} + +- (void) systemDidWake:(NSNotification *)notification +{ +#ifdef NS_IMPL_COCOA + NSTRACE ("[EmacsApp systemDidWake:]"); + struct input_event ie; + EVENT_INIT (ie); + ie.kind = SLEEP_EVENT; + ie.arg = list1 (Qpost_wake); + kbd_buffer_store_event (&ie); +#endif +} /* Termination sequences: C-x C-c: diff --git a/src/w32fns.c b/src/w32fns.c index b75bce8d1a2..3a32d046132 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -11325,6 +11325,136 @@ if the selected frame is not (yet) associated with a window handle */) #endif /* WINDOWSNT */ +/*********************************************************************** + System Sleep Support + ***********************************************************************/ + +typedef ULONG (WINAPI * SetThreadExecutionState_Proc) + (IN ULONG); +static SetThreadExecutionState_Proc SetThreadExecutionState_fn = NULL; + +static unsigned int sleep_block_id = 0; +static unsigned int sleep_block_count = 0; + +DEFUN ("w32-block-system-sleep", + Fw32_block_system_sleep, + Sw32_block_system_sleep, + 1, 1, 0, + doc: /* Block system idle sleep. +If ALLOW-DISPLAY-SLEEP is non-nil, block the screen from sleeping. +Return a token to unblock this block using `w32-unblock-system-sleep', +or nil if the block fails. */) + (Lisp_Object allow_display_sleep) +{ + if (SetThreadExecutionState_fn == NULL) + return Qnil; + + /* ES_CONTINUOUS keeps the state until cleared. */ + EXECUTION_STATE new_state = ES_SYSTEM_REQUIRED | ES_CONTINUOUS; + if (NILP (allow_display_sleep)) + new_state |= ES_DISPLAY_REQUIRED; + + if (SetThreadExecutionState (new_state) == 0) + return Qnil; + else + { + /* One more block and next id. */ + ++sleep_block_count; + ++sleep_block_id; + + /* Synthesize a token. */ + return make_fixnum (sleep_block_id); + } +} + +DEFUN ("w32-unblock-system-sleep", + Fw32_unblock_system_sleep, + Sw32_unblock_system_sleep, + 0, 0, 0, + doc: /* Unblock system idle sleep. +Return non-nil if the TOKEN block was unblocked. */) + (void) +{ + if (SetThreadExecutionState_fn == NULL) + return Qnil; + + /* No blocks to unblock. */ + if (sleep_block_count == 0) + return Qnil; + + /* One fewer block. */ + if (--sleep_block_count == 0 + && SetThreadExecutionState (ES_CONTINUOUS) == 0) + return Qnil; + else + return Qt; +} + +DEFUN ("w32-system-sleep-block-count", + Fw32_system_sleep_block_count, + Sw32_system_sleep_block_count, + 0, 0, 0, + doc: /* Return the w32 sleep block count. */) + (void) +{ + return make_fixnum (sleep_block_count); +} + +typedef ULONG (CALLBACK *PMY_DEVICE_NOTIFY_CALLBACK_ROUTINE) + (PVOID Context, ULONG Type, PVOID Setting); + +static ULONG ALIGN_STACK +sleep_notification_callback(PVOID _Context, ULONG Type, PVOID _Setting) +{ + struct input_event ie; + EVENT_INIT (ie); + ie.kind = SLEEP_EVENT; + + switch (Type) + { + case PBT_APMRESUMEAUTOMATIC: + /* Ignore this event. No user is present. */ + break; + case PBT_APMSUSPEND: + ie.arg = list1 (Qpre_sleep); + kbd_buffer_store_event (&ie); + break; + case PBT_APMRESUMESUSPEND: + ie.arg = list1 (Qpost_wake); + kbd_buffer_store_event (&ie); + break; + } + return 0; +} + +typedef HPOWERNOTIFY (WINAPI * RegisterSuspendResumeNotification_Proc) + (IN HANDLE, IN DWORD); +static RegisterSuspendResumeNotification_Proc RegisterSuspendResumeNotification_fn = NULL; + +static HPOWERNOTIFY sleep_notification_handle = 0; + +typedef struct _MY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS { + PMY_DEVICE_NOTIFY_CALLBACK_ROUTINE Callback; + PVOID Context; +} MY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS, *PMY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS; + +void +w32_register_for_sleep_notifications() +{ + /* PowerRegisterSuspendResumeNotification is not a user-space call so + we use RegisterSuspendResumeNotification. */ + if (RegisterSuspendResumeNotification_fn) + { + MY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS params; + params.Callback = sleep_notification_callback; + params.Context = NULL; + + /* DEVICE_NOTIFY_CALLBACK = 2 */ + sleep_notification_handle = + RegisterSuspendResumeNotification_fn (¶ms, 2); + } +} + /*********************************************************************** Initialization ***********************************************************************/ @@ -11834,6 +11964,10 @@ keys when IME input is received. */); defsubr (&Sw32_request_user_attention); DEFSYM (Qinformational, "informational"); DEFSYM (Qcritical, "critical"); + /* System sleep support. */ + defsubr (&Sw32_unblock_system_sleep); + defsubr (&Sw32_block_system_sleep); + defsubr (&Sw32_system_sleep_block_count); #endif } @@ -12094,6 +12228,7 @@ void globals_of_w32fns (void) { HMODULE user32_lib = GetModuleHandle ("user32.dll"); + HMODULE kernel32_lib = GetModuleHandle ("kernel32.dll"); /* TrackMouseEvent not available in all versions of Windows, so must load it dynamically. Do it once, here, instead of every time it is used. @@ -12120,6 +12255,16 @@ globals_of_w32fns (void) RegisterTouchWindow_fn = (RegisterTouchWindow_proc) get_proc_addr (user32_lib, "RegisterTouchWindow"); + /* For system sleep support. */ + SetThreadExecutionState_fn + = (SetThreadExecutionState_Proc) + get_proc_addr (kernel32_lib, + "SetThreadExecutionState"); + RegisterSuspendResumeNotification_fn + = (RegisterSuspendResumeNotification_Proc) + get_proc_addr (user32_lib, + "RegisterSuspendResumeNotification"); + SetGestureConfig_fn = (SetGestureConfig_proc) get_proc_addr (user32_lib, "SetGestureConfig"); diff --git a/src/w32term.c b/src/w32term.c index 091a1fbd5f1..5b7d9c5f17d 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -8249,6 +8249,7 @@ w32_initialize (void) } w32_get_mouse_wheel_vertical_delta (); + w32_register_for_sleep_notifications (); } void diff --git a/src/w32term.h b/src/w32term.h index 91db0b6e249..cb9d59371a4 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -274,6 +274,7 @@ extern const char *w32_get_string_resource (void *v_rdb, extern frame_parm_handler w32_frame_parm_handlers[]; extern void w32_default_font_parameter (struct frame* f, Lisp_Object parms); extern Lisp_Object w32_process_dnd_data (int format, void *pDataObj); +extern void w32_register_for_sleep_notifications(); #define PIX_TYPE COLORREF From 37891d1a1e3dded6fd26478e9b2012ca433dfd4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Tue, 10 Feb 2026 14:05:43 +0100 Subject: [PATCH 146/191] ; * test/lisp/net/dbus-tests.el: no warnings for non-dbus configs --- test/lisp/net/dbus-tests.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index f4dd9e3796b..18e6b09a8de 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -32,6 +32,9 @@ (declare-function dbus-registered-inhibitor-locks "dbusbind.c" ()) (declare-function dbus-make-inhibitor-lock "dbusbind.c" (what why &optional block)) +(declare-function dbus--fd-open "dbusbind.c" (filename)) +(declare-function dbus--fd-close "dbusbind.c" (fd)) +(declare-function dbus--registered-fds "dbusbind.c" ()) (defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) From e464052a2835e33029fd180a3609ef6f5a915ec9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 11 Feb 2026 14:44:09 +0200 Subject: [PATCH 147/191] ; Fix recently installed changes * src/w32fns.c (w32_register_for_sleep_notifications) (sleep_notification_callback): Fix signatures. * src/w32term.h (w32_register_for_sleep_notifications): Fix prototype. These changes avoid compilation warnings. * lisp/system-sleep.el: Remove stray non-ASCII character. * doc/lispref/os.texi (System Sleep): Remove non-ASCII character, and fix wording and markup. * etc/NEWS: Fix wording of recently-added entry. --- doc/lispref/os.texi | 14 ++++++++------ etc/NEWS | 8 ++++---- lisp/system-sleep.el | 2 +- src/w32fns.c | 15 ++++++--------- src/w32term.h | 2 +- 5 files changed, 20 insertions(+), 21 deletions(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 0e669c70592..6c155c3ba65 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -3509,29 +3509,31 @@ Otherwise, it returns @code{nil} if the sleep blocking fails. @var{why} is a string and, when non-nil, is used to identify the sleep block as it may appear on the system's inspectable block lists. It -defaults to ``Emacs''. +defaults to @samp{Emacs}. If @var{allow-display-sleep} is non-nil, allow the display to sleep. By default, the display is kept active. -Note: ​When the Emacs process dies, blocks are released on all platforms. +Note that when the Emacs process terminates, blocks are released on all +platforms. @end defun @defun system-sleep-unblock-sleep token This function unblocks the sleep block associated with @var{token}. It -returns non-@code{nil} on success, otherwise returns @code{nil}. +returns non-@code{nil} on success, otherwise it returns @code{nil}. @end defun @defmac with-system-sleep-block (&optional why allow-display-sleep) body@dots{} This is a convenience macro that lets you wrap the forms in @var{body} with a sleep block that is unblocked for you when @var{body} completes. -The arguments have the same meaning as in +This guarantees that the system will never go to sleep while @var{body} +executes. The arguments have the same meaning as in @code{system-sleep-block-sleep}, above. @end defmac @defun system-sleep-sleep-blocked-p -This predicate function returns non-@code{nil} on if there are any -active @code{system-sleep} blocks, otherwise returns @code{nil}. +This predicate function returns non-@code{nil} if there are any +active @code{system-sleep} blocks, otherwise it returns @code{nil}. @end defun @defun system-sleep-unblock-all-sleep-blocks diff --git a/etc/NEWS b/etc/NEWS index abf4b3d10a3..68b21fee066 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3608,11 +3608,11 @@ connections or serial ports before sleeping, and reestablish them when the system wakes up. Supported capable systems are GNU/Linux via D-Bus (sleep blocking and -events require the org.freedesktop.login1 service, display sleep +sleep events require the org.freedesktop.login1 service, display sleep blocking requires org.freedesktop.Screensaver service), macOS -(sleep/display blocking requires 10.9+, sleep events are supported on -all versions), MS-Windows (sleep blocking is supported on all versions, -sleep events require 8+). +(sleep/display blocking requires version 10.9 or later, sleep events are +supported on all versions), MS-Windows (sleep blocking is supported on +all versions, sleep events require Windows 8 or later). * Incompatible Lisp Changes in Emacs 31.1 diff --git a/lisp/system-sleep.el b/lisp/system-sleep.el index bd14e9d0e50..e09f2fedcd1 100644 --- a/lisp/system-sleep.el +++ b/lisp/system-sleep.el @@ -41,7 +41,7 @@ ;; The function `system-sleep-sleep-blocked-p' will tell you if ;; `system-sleep' has any active system sleep blocks. ;; -;; Note: ​When the Emacs process dies, blocks are released on all +;; Note: When the Emacs process dies, blocks are released on all ;; platforms. ;; ;; You can register functions on the abnormal hook diff --git a/src/w32fns.c b/src/w32fns.c index 3a32d046132..d4ade9bf283 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -11329,8 +11329,7 @@ if the selected frame is not (yet) associated with a window handle */) System Sleep Support ***********************************************************************/ -typedef ULONG (WINAPI * SetThreadExecutionState_Proc) - (IN ULONG); +typedef ULONG (WINAPI * SetThreadExecutionState_Proc) (IN ULONG); static SetThreadExecutionState_Proc SetThreadExecutionState_fn = NULL; static unsigned int sleep_block_id = 0; @@ -11403,8 +11402,8 @@ DEFUN ("w32-system-sleep-block-count", typedef ULONG (CALLBACK *PMY_DEVICE_NOTIFY_CALLBACK_ROUTINE) (PVOID Context, ULONG Type, PVOID Setting); -static ULONG ALIGN_STACK -sleep_notification_callback(PVOID _Context, ULONG Type, PVOID _Setting) +static ULONG CALLBACK ALIGN_STACK +sleep_notification_callback (PVOID _Context, ULONG Type, PVOID _Setting) { struct input_event ie; EVENT_INIT (ie); @@ -11439,7 +11438,7 @@ typedef struct _MY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS { } MY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS, *PMY_DEVICE_NOTIFY_SUBSCRIBE_PARAMETERS; void -w32_register_for_sleep_notifications() +w32_register_for_sleep_notifications (void) { /* PowerRegisterSuspendResumeNotification is not a user-space call so we use RegisterSuspendResumeNotification. */ @@ -12258,12 +12257,10 @@ globals_of_w32fns (void) /* For system sleep support. */ SetThreadExecutionState_fn = (SetThreadExecutionState_Proc) - get_proc_addr (kernel32_lib, - "SetThreadExecutionState"); + get_proc_addr (kernel32_lib, "SetThreadExecutionState"); RegisterSuspendResumeNotification_fn = (RegisterSuspendResumeNotification_Proc) - get_proc_addr (user32_lib, - "RegisterSuspendResumeNotification"); + get_proc_addr (user32_lib, "RegisterSuspendResumeNotification"); SetGestureConfig_fn = (SetGestureConfig_proc) get_proc_addr (user32_lib, diff --git a/src/w32term.h b/src/w32term.h index cb9d59371a4..aec957b20b3 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -274,7 +274,7 @@ extern const char *w32_get_string_resource (void *v_rdb, extern frame_parm_handler w32_frame_parm_handlers[]; extern void w32_default_font_parameter (struct frame* f, Lisp_Object parms); extern Lisp_Object w32_process_dnd_data (int format, void *pDataObj); -extern void w32_register_for_sleep_notifications(); +extern void w32_register_for_sleep_notifications (void); #define PIX_TYPE COLORREF From 17fb8a45f76500e354fd2a20bcf8c68ac740dcbe Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 11 Feb 2026 14:17:30 +0100 Subject: [PATCH 148/191] ; * test/lisp/net/dbus-tests.el: Remove obsolete function declarations. --- test/lisp/net/dbus-tests.el | 4 ---- 1 file changed, 4 deletions(-) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 18e6b09a8de..3d0ab522d3f 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -28,10 +28,6 @@ (defvar dbus-debug) (defvar dbus-message-type-signal) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) -(declare-function dbus-close-inhibitor-lock "dbusbind.c" (lock)) -(declare-function dbus-registered-inhibitor-locks "dbusbind.c" ()) -(declare-function dbus-make-inhibitor-lock "dbusbind.c" - (what why &optional block)) (declare-function dbus--fd-open "dbusbind.c" (filename)) (declare-function dbus--fd-close "dbusbind.c" (fd)) (declare-function dbus--registered-fds "dbusbind.c" ()) From 6967a8ac544d377884362a184b6eaa1c4f57d778 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Marks?= Date: Wed, 11 Feb 2026 08:24:43 -0500 Subject: [PATCH 149/191] ; system-sleep texi markup fix (bug#80348) * doc/lispref/os.texi (System Sleep): Minor markup fixes. --- doc/lispref/os.texi | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 6c155c3ba65..ccc0f69a12d 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -3507,12 +3507,12 @@ It returns a token that must be passed to sleep blocks may be simultaneously in force for other purposes). Otherwise, it returns @code{nil} if the sleep blocking fails. -@var{why} is a string and, when non-nil, is used to identify the sleep -block as it may appear on the system's inspectable block lists. It -defaults to @samp{Emacs}. +@var{why} is a string and, when non-@code{nil}, is used to identify the +sleep block as it may appear on the system's inspectable block lists. +It defaults to @samp{Emacs}. -If @var{allow-display-sleep} is non-nil, allow the display to sleep. By -default, the display is kept active. +If @var{allow-display-sleep} is non-@code{nil}, allow the display to +sleep. By default, the display is kept active. Note that when the Emacs process terminates, blocks are released on all platforms. From 90fbadb3b119eee9e6ded4dc318af7a5c3e85f46 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Wed, 11 Feb 2026 14:23:38 +0000 Subject: [PATCH 150/191] cond*: bind-and* is not always a non-exit clause! * lisp/emacs-lisp/cond-star.el (cond*-non-exit-clause-p) (cond*-non-exit-clause-substance): Don't consider a bind-and* clause without ':non-exit' to be a non-exit clause (bug#80376). (cond*): * doc/lispref/control.texi (cond* Macro): Fix docs accordingly. --- doc/lispref/control.texi | 22 +++++++++++----------- lisp/emacs-lisp/cond-star.el | 26 ++++++++++++-------------- 2 files changed, 23 insertions(+), 25 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 2b882763e06..85e13952cfb 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1524,10 +1524,10 @@ true if the first binding's value is non-@code{nil}. @findex bind-and* @code{(bind-and* @var{bindings}@dots{})} means to bind @var{bindings} (like the bindings list in @code{if-let*}, @pxref{Conditionals}) for -only the body of the clause. It is always a non-exit clause. As a -condition, it counts as true if none of the bindings evaluate to -@code{nil}. In addition, if any binding evaluates to @code{nil}, the -expressions for the values of subsequent bindings are not evaluated. +only the body of the clause. As a condition, it counts as true if none +of the bindings evaluate to @code{nil}. In addition, if any binding +evaluates to @code{nil}, the expressions for the values of subsequent +bindings are not evaluated. @findex match* @findex pcase* @@ -1549,13 +1549,13 @@ becomes the return value of the @code{cond*} construct. @subheading Non-exit clauses -If a clause has only one element, or if its first element is @code{t}, a -@code{bind*} form or a @code{bind-and*} form, or if it ends with the -keyword @code{:non-exit}, then this clause never exits the @code{cond*} -construct. Instead, control falls through to the next clause (if any). -Except for @code{bind-and*}, the bindings made in @var{condition} for -the @var{body} of the non-exit clause are passed along to the rest of -the clauses in this @code{cond*} construct. +If a clause has only one element, or if its first element is @code{t} or +a @code{bind*} form, or if it ends with the keyword @code{:non-exit}, +then this clause never exits the @code{cond*} construct. Instead, +control falls through to the next clause (if any). Except for a +@code{bind-and*} clause, the bindings made in @var{condition} for the +@var{body} of the non-exit clause are passed along to the rest of the +clauses in this @code{cond*} construct. Note: @code{pcase*} does not support @code{:non-exit}, and when used in a non-exit clause, it follows the semantics of @code{pcase-let}, see diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index dfb08459506..33a21602d9b 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -70,9 +70,8 @@ For its patterns, see `match*'. The condition counts as true if PATTERN matches DATUM. `(bind-and* BINDINGS...)' means to bind BINDINGS (as if they were in -`if-let*') for only the the body of the clause. It is always a non-exit -clause. If any expression evaluates to nil, the condition counts as -false. +`if-let*') for only the the body of the clause. If any expression +evaluates to nil, the condition counts as false. `(pcase* PATTERN DATUM)' means to match DATUM against the pattern PATTERN, using the same pattern syntax as `pcase'. @@ -84,13 +83,12 @@ in its body becomes the return value of the `cond*' construct. Non-exit clauses: -If a clause has only one element, or if its first element is t, a -`bind*' form or a `bind-and*' form, or if it ends with the keyword -`:non-exit', then this clause never exits the `cond*' construct. -Instead, control always falls through to the next clause (if any). -Except for `bind-and*', all bindings made in CONDITION for the BODY of -the non-exit clause are passed along to the rest of the clauses in this -`cond*' construct. +If a clause has only one element, or if its first element is t or a +`bind*' form, or if it ends with the keyword `:non-exit', then this +clause never exits the `cond*' construct. Instead, control always falls +through to the next clause (if any). Except for a `bind-and*' clause, +all bindings made in CONDITION for the BODY of the non-exit clause are +passed along to the rest of the clauses in this `cond*' construct. See `match*' for documentation of the patterns for use in `match*' conditions." @@ -197,9 +195,9 @@ CONDITION of a `cond*' clause. See `cond*' for details." (and (cdr-safe clause) ;; Starts with t. (or (eq (car clause) t) - ;; Starts with a `bind*' or `bind-and*' pseudo-form. + ;; Starts with a `bind*' pseudo-form. (and (consp (car clause)) - (memq (caar clause) '(bind* bind-and*))))) + (eq (caar clause) 'bind*)))) ;; Ends with keyword. (eq (car (last clause)) :non-exit))) @@ -207,8 +205,8 @@ CONDITION of a `cond*' clause. See `cond*' for details." "For a non-exit cond* clause CLAUSE, return its substance. This removes a final keyword if that's what makes CLAUSE non-exit." (cond ((or (null (cdr-safe clause)) ;; either clause has only one element - (and (consp (car clause)) ;; or it starts with `bind*'/`bind-and*' - (memq (caar clause) '(bind* bind-and*)))) + (and (consp (car clause)) ;; or it starts with `bind*' + (eq (caar clause) 'bind*))) clause) ;; Starts with t or a keyword. ;; Include t as the first element of the substance From 2e7a066d564fee63871845533b6aeb0036a4d006 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Wed, 11 Feb 2026 15:04:18 +0000 Subject: [PATCH 151/191] icomplete-ret: Ignore icomplete-show-matches-on-no-input * lisp/icomplete.el (icomplete-ret): No longer conditionalize on icomplete-show-matches-on-no-input. Suggested by Juri Linkov in bug#62108. (icomplete-show-matches-on-no-input, icomplete-ret): * etc/NEWS: Improve documentation. --- etc/NEWS | 14 ++++++++------ lisp/icomplete.el | 30 +++++++++++++++++++----------- 2 files changed, 27 insertions(+), 17 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 68b21fee066..076a4e2c15e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3093,12 +3093,14 @@ Meant to be given a global binding convenient to the user. Example: ** Icomplete *** Change in meaning of 'icomplete-show-matches-on-no-input' (again). -Previously, choosing a different completion with commands like 'C-.' -and then hitting 'RET' would choose the completion under point -when 'icomplete-show-matches-on-no-input' is customized to non-nil. -Doing this will now choose the default value instead. There is -still 'C-j' to choose the completion under point in 'icomplete-mode'. -You can get back the old behavior of the 'RET' key with +For Emacs 28 to Emacs 30, when 'icomplete-show-matches-on-no-input' was +non-nil, 'RET' had special behavior when the minibuffer's contents was +equal to the initial input it had right after minibuffer activation. +In that case, 'RET' would choose the first completion candidate, if +there was one, instead of the minibuffer's default value. +'RET' has now returned to selecting the default value in this case; you +can use 'C-j' to choose the completion under point instead. +You can opt back in to the special behavior of 'RET' like this: (keymap-set icomplete-minibuffer-map " " diff --git a/lisp/icomplete.el b/lisp/icomplete.el index b7002fa545b..875c41bd841 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -79,11 +79,12 @@ selection process starts again from the user's $HOME." (defcustom icomplete-show-matches-on-no-input nil "When non-nil, show completions when first prompting for input. This means to show completions even when the current minibuffer contents -is the same as was the initial input after minibuffer activation. +is the same as the initial input after minibuffer activation. This also means that if you just hit \\`C-j' without typing any -characters, the match under point will be chosen instead of the -default. But \\`RET' will still choose the default value exactly -as when this option is nil." +characters, this chooses the first completion candidate instead of the +minibuffer's default value. + +See also `icomplete-ret'." :type 'boolean :version "24.4") @@ -246,14 +247,21 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") "C-," #'icomplete-backward-completions) (defun icomplete-ret () - "Exit minibuffer for icomplete. -You can bind this command to \\`RET' in `icomplete-minibuffer-map', -or remap from `minibuffer-complete-and-exit', to be able to choose -the completion under point with \\`RET' instead of choosing the -default value." + "Alternative minibuffer exit for Icomplete. +If there is a completion candidate and the minibuffer contents is the +same as it was right after minibuffer activation, exit selecting that +candidate. Otherwise do as `minibuffer-complete-and-exit'. + +You may wish to consider binding this command to \\`RET' (or to +` ') in `icomplete-minibuffer-map'. +If you do that, then when Emacs first prompts for input such that the +current minibuffer contents is equal to the initial input right after +minibuffer activation, \\`RET' chooses the first completion candidate +instead of the minibuffer's default value. +This rebinding is especially useful if you have customized +`icomplete-show-matches-on-no-input' to a non-nil value." (interactive) - (if (and icomplete-show-matches-on-no-input - (car completion-all-sorted-completions) + (if (and (car completion-all-sorted-completions) (equal (icomplete--field-string) icomplete--initial-input)) (icomplete-force-complete-and-exit) (minibuffer-complete-and-exit))) From badef58d0ad97401540ea961f34841c2911683ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 11 Feb 2026 18:42:46 +0100 Subject: [PATCH 152/191] Better 'prog1' optimisation * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Always evaporate 'prog1' when the tail is effect-free, even when the value expression isn't. --- lisp/emacs-lisp/byte-opt.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c5458c1ba69..1aecae5ac7d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -345,9 +345,9 @@ There can be multiple entries for the same NAME if it has several aliases.") (let ((exp-opt (byte-optimize-form exp for-effect))) (if exps (let ((exps-opt (byte-optimize-body exps t))) - (if (macroexp-const-p exp-opt) - `(progn ,@exps-opt ,exp-opt) - `(,fn ,exp-opt ,@exps-opt))) + (cond ((null exps-opt) exp-opt) + ((macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt)) + (t `(,fn ,exp-opt ,@exps-opt)))) exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) From 5bc7185afa4538853df5ea2a1dcd85d079d075ef Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 11 Feb 2026 20:44:20 +0100 Subject: [PATCH 153/191] Disable 'package-autosuggest-mode' by default * lisp/emacs-lisp/package-activate.el (package-autosuggest-mode): Do not set the :init-value when declaring the minor mode. --- lisp/emacs-lisp/package-activate.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 24d168c5d05..7981642a7e0 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -677,7 +677,7 @@ This function should be added to `after-change-major-mode-hook'." ;;;###autoload (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." - :global t :init-value t :group 'package + :global t :group 'package :initialize #'custom-initialize-delay (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook From 0afb026a997a4636658a635d4ff82f21467ca55d Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Wed, 11 Feb 2026 20:47:26 +0100 Subject: [PATCH 154/191] Generalize 'scrape-elpa--safe-evil' * admin/scrape-elpa.el (scrape-elpa--safe-eval): Extend support from just 'cons' and 'concat' to any side-effect-free function. --- admin/scrape-elpa.el | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/admin/scrape-elpa.el b/admin/scrape-elpa.el index f1bd0307b43..e1072564db6 100644 --- a/admin/scrape-elpa.el +++ b/admin/scrape-elpa.el @@ -43,12 +43,9 @@ be comprehensive, but just to handle the kinds of expressions that (cons (if (eq (car-safe car) '\,) (scrape-elpa--safe-eval (cadr car) vars) car) (if (eq (car-safe cdr) '\,) (scrape-elpa--safe-eval (cadr cdr) vars) cdr))) - ;; supported functions - (`(cons ,car ,cdr) - (cons (scrape-elpa--safe-eval car vars) - (scrape-elpa--safe-eval cdr vars))) - (`(concat . ,args) - (apply #'concat (mapcar #'scrape-elpa--safe-eval args))) + ;; allow calling `side-effect-free' functions + (`(,(and (pred symbolp) (pred (get _ 'side-effect-free)) fn) . ,args) + (apply fn (mapcar #'scrape-elpa--safe-eval args))) ;; self-evaluating forms ((pred macroexp-const-p) exp) ;; variable evaluation From bc9a53616a0555e90cb5a65ec257846e1f0c77bb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 9 Feb 2026 14:59:18 -0500 Subject: [PATCH 155/191] make-mode.el: Avoid obsolete font-lock-*-face` variables * lisp/progmodes/make-mode.el (makefile-make-font-lock-keywords) (makefile-makepp-font-lock-keywords): Use `font-lock-*-face` faces rather than variables. --- lisp/progmodes/make-mode.el | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 8856856100e..e34eaba3150 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -331,7 +331,7 @@ not be enclosed in { } or ( )." &rest fl-keywords) `(;; Do macro assignments. These get the "variable-name" face. (,makefile-macroassign-regex - (1 font-lock-variable-name-face) + (1 'font-lock-variable-name-face) ;; This is for after != (2 'makefile-shell prepend t) ;; This is for after normal assignment @@ -340,10 +340,10 @@ not be enclosed in { } or ( )." ;; Rule actions. ;; FIXME: When this spans multiple lines we need font-lock-multiline. (makefile-match-action - (1 font-lock-type-face nil t) + (1 'font-lock-type-face nil t) (2 'makefile-shell prepend) ;; Only makepp has builtin commands. - (3 font-lock-builtin-face prepend t)) + (3 'font-lock-builtin-face prepend t)) ;; Variable references even in targets/strings/comments. (,var 2 font-lock-variable-name-face prepend) @@ -364,11 +364,11 @@ not be enclosed in { } or ( )." (string-replace "-" "[_-]" (regexp-opt (cdr keywords) t)) (regexp-opt keywords t))) "\\>[ \t]*\\([^: \t\n#]*\\)") - (1 font-lock-keyword-face) (2 font-lock-variable-name-face)))) + (1 'font-lock-keyword-face) (2 'font-lock-variable-name-face)))) ,@(if negation - `((,negation (1 font-lock-negation-char-face prepend) - (2 font-lock-negation-char-face prepend t)))) + `((,negation (1 'font-lock-negation-char-face prepend) + (2 'font-lock-negation-char-face prepend t)))) ,@(if space '(;; Highlight lines that contain just whitespace. @@ -436,9 +436,9 @@ not be enclosed in { } or ( )." ;; Colon modifier keywords. '("\\(:\\s *\\)\\(build_c\\(?:ache\\|heck\\)\\|env\\(?:ironment\\)?\\|foreach\\|signature\\|scanner\\|quickscan\\|smartscan\\)\\>\\([^:\n]*\\)" - (1 font-lock-type-face t) - (2 font-lock-keyword-face t) - (3 font-lock-variable-name-face t)) + (1 'font-lock-type-face t) + (2 'font-lock-keyword-face t) + (3 'font-lock-variable-name-face t)) ;; $(function ...) $((function ...)) ${...} ${{...}} $[...] $[[...]] '("[^$]\\$\\(?:((?\\|{{?\\|\\[\\[?\\)\\([-a-zA-Z0-9_.]+\\s \\)" From a1e32130dee7f7e4ff84549e2bd157744f571ab0 Mon Sep 17 00:00:00 2001 From: Morgan Willcock Date: Thu, 29 Jan 2026 18:05:38 +0000 Subject: [PATCH 156/191] Fix typo in smie-rules-function documentation Fix a typo in the documentation for the expected arguments when calling smie-rules-function to set the indentation offset of function arguments. * doc/lispref/modes.texi (SMIE Indentation): * lisp/emacs-lisp/smie.el (smie-rules-function): Fix typo in documentation for smie-rules-function arguments. --- doc/lispref/modes.texi | 2 +- lisp/emacs-lisp/smie.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 2214a30c170..13a8ec46a8a 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -5026,7 +5026,7 @@ should return the @var{offset} to use to indent @var{arg} itself. @item @code{:elem}, in which case the function should return either the offset to use to indent function arguments (if @var{arg} is the symbol -@code{arg}) or the basic indentation step (if @var{arg} is the symbol +@code{args}) or the basic indentation step (if @var{arg} is the symbol @code{basic}). @item @code{:list-intro}, in which case @var{arg} is a token and the function diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 91f3332a79b..33821b8be28 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1153,7 +1153,7 @@ METHOD can be: - :before, in which case ARG is a token and the function should return the OFFSET to use to indent ARG itself. - :elem, in which case the function should return either: - - the offset to use to indent function arguments (ARG = `arg') + - the offset to use to indent function arguments (ARG = `args') - the basic indentation step (ARG = `basic'). - the token to use (when ARG = `empty-line-token') when we don't know how to indent an empty line. From 451d5c6f05dfe4c8e74c4361bba00290ffe5bc62 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 11 Feb 2026 15:53:09 -0500 Subject: [PATCH 157/191] (describe-mode): Fix bug#80170 * lisp/help-fns.el (describe-mode--minor-modes): Add argument `buffer`. (describe-mode): Use it to fix call to `documentation` so the docstrings are computed in the right buffer and thus show correctly when bindings are shadowed by minor modes. --- lisp/help-fns.el | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 73066dd6f3d..f1ee109c87e 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2242,7 +2242,7 @@ is enabled in the Help buffer." (insert (format "Minor mode%s enabled in this buffer:" (if (length> local-minors 1) "s" "")))) - (describe-mode--minor-modes local-minors)) + (describe-mode--minor-modes local-minors nil buffer)) ;; Document the major mode. (let ((major (buffer-local-value 'major-mode buffer))) @@ -2269,7 +2269,9 @@ is enabled in the Help buffer." (help-function-def--button-function major file-name)))))) (insert ":\n\n" - (help-split-fundoc (documentation major) nil 'doc) + (help-split-fundoc (with-current-buffer buffer + (documentation major)) + nil 'doc) (with-current-buffer buffer (help-fns--list-local-commands))) (ensure-empty-lines 1) @@ -2280,7 +2282,7 @@ is enabled in the Help buffer." (insert (format "Global minor mode%s enabled:" (if (length> global-minor-modes 1) "s" "")))) - (describe-mode--minor-modes global-minor-modes t) + (describe-mode--minor-modes global-minor-modes t buffer) (unless describe-mode-outline (when (re-search-forward "^\f") (beginning-of-line) @@ -2297,7 +2299,7 @@ is enabled in the Help buffer." ;; For the sake of IELM and maybe others nil))))) -(defun describe-mode--minor-modes (modes &optional global) +(defun describe-mode--minor-modes (modes &optional global buffer) (dolist (mode (seq-sort #'string< modes)) (let ((pretty-minor-mode (capitalize @@ -2338,7 +2340,10 @@ is enabled in the Help buffer." "no indicator" (format "indicator%s" indicator))))) - (insert (or (help-split-fundoc (documentation mode) nil 'doc) + (insert (or (help-split-fundoc + (with-current-buffer (or buffer (current-buffer)) + (documentation mode)) + nil 'doc) "No docstring")) (when describe-mode-outline (insert "\n\n"))))) From 0f0a632028236de3dc3dd797b46c88b3548dc6fb Mon Sep 17 00:00:00 2001 From: Richard Lawrence Date: Wed, 11 Feb 2026 08:51:45 +0100 Subject: [PATCH 158/191] * doc/emacs/calendar.texi (Diary iCalendar Import): Doc fix. --- doc/emacs/calendar.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 5c673f21988..957cfbd9d8f 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -1658,9 +1658,9 @@ follows: @end group @end lisp -The variables @code{start-to-end}, @code{summary} and @code{location} in -this example are dynamically bound to appropriate values when the -skeleton is called. See the docstring of +The variables @code{ical-start-to-end}, @code{ical-summary} and +@code{ical-location} in this example are dynamically bound to +appropriate values when the skeleton is called. See the docstring of @code{diary-icalendar-vevent-format-function} for more information. Any errors encountered during import will be reported in a buffer named From cf83dad395a7bd03610bf9bfc9e379139cd7c563 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Thu, 12 Feb 2026 05:15:30 +0200 Subject: [PATCH 159/191] Revise the paragraph about project-vc's caching * doc/emacs/maintaining.texi (VC-Aware Project Backend): Rephrase and mention a way to force invalitation (bug#78545). --- doc/emacs/maintaining.texi | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 91784ff71ef..1d54af130a9 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2323,9 +2323,10 @@ configuration (if any), excluding the ``ignored'' files from the output. It has some performance optimizations for listing the files with some of the popular VCS systems (currently Git and Mercurial). -It also uses a cache for some of the computations, for shorter or longer -periods of time, depending on whether it's being used from an -interactive command, or from non-essential code running in background. +@findex project-remember-projects-under +It also uses a time-based cache. If the mode line shows stale project +information, you can type @kbd{M-x project-remember-projects-under RET} +to refresh the stale cached info. @defopt project-vc-include-untracked By default, files which are neither registered with nor ignored by the From 0ff45e9ca6d703274d2d818600b009445966f9d5 Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Thu, 12 Feb 2026 09:43:04 +0100 Subject: [PATCH 160/191] Scale position values in xg_frame_set_size_and_position * src/gtkutil.c (xg_frame_set_size_and_position): Scale position values. --- src/gtkutil.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/gtkutil.c b/src/gtkutil.c index 9645bbad9c3..b01bb6804ed 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1405,6 +1405,8 @@ xg_frame_set_size_and_position (struct frame *f, int width, int height) outer_height /= scale; outer_width /= scale; + x /= scale; + y /= scale; /* Full force ahead. For top-level frames the gravity will get reset to NorthWestGravity anyway. */ From 970bef602e014d0aa4442de975b8fca51c2029ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E0=A4=B8=E0=A4=AE=E0=A5=80=E0=A4=B0=20=E0=A4=B8=E0=A4=BF?= =?UTF-8?q?=E0=A4=82=E0=A4=B9=20Sameer=20Singh?= Date: Tue, 10 Feb 2026 04:45:03 +0530 Subject: [PATCH 161/191] Improve composition rules for Devanagari script * lisp/language/indian.el (devanagari-composable-pattern): Account for contextual positioning of punctuation signs when preceded by a character. (Bug#80368) Improve the Devanagari composition rules to account for contextual positioning of punctuation signs when preceded by a character. --- lisp/language/indian.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index 59076faea69..d0373086fe4 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -308,6 +308,7 @@ environment.")) ("H" . "\u094D") ; HALANT ("s" . "[\u0951\u0952]") ; stress sign ("t" . "[\u0953\u0954]") ; accent + ("D" . "[\u0964\u0965]") ; punctuation sign ("1" . "\u0967") ; numeral 1 ("3" . "\u0969") ; numeral 3 ("N" . "\u200C") ; ZWNJ @@ -316,15 +317,15 @@ environment.")) (indian-compose-regexp (concat ;; syllables with an independent vowel, or - "\\(?:RH\\)?Vn?\\(?:J?HR\\)?v*n?a?s?t?A?\\|" + "\\(?:RH\\)?Vn?\\(?:J?HR\\)?v*n?a?s?t?A?D?\\|" ;; consonant-based syllables, or - "Cn?\\(?:J?HJ?Cn?\\)*\\(?:H[NJ]?\\|v*n?a?s?t?A?\\)\\|" + "Cn?\\(?:J?HJ?Cn?\\)*\\(?:H[NJ]?D?\\|v*n?a?s?t?A?D?\\)\\|" ;; special consonant form, or - "JHR\\|" + "JHRD?\\|" ;; vedic accents with numerals, or "1ss?\\|3ss\\|s3ss\\|" ;; any other singleton characters - "X") + "XD?") table)) "Regexp matching a composable sequence of Devanagari characters.") From 396299b3c9819f81b085b04e1e2676aec094a2b2 Mon Sep 17 00:00:00 2001 From: Rahul Martim Juliato Date: Sun, 1 Feb 2026 23:28:26 -0300 Subject: [PATCH 162/191] Fix parsing of Title field in Newsticker List buffer * lisp/net/newst-backend.el (newsticker--parse-text-container): Only "xhtml" type contains inline XML nodes that need to be run through 'newsticker--unxml' to serialize back to a string. (Bug#80317) --- lisp/net/newst-backend.el | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index babd55fb29d..58bbb1b7fcb 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1109,12 +1109,13 @@ same as in `newsticker--parse-atom-1.0'." (defun newsticker--parse-text-container (node) "Handle content according to ``type'' attribute." - (let ((content (car (xml-node-children node)))) - (if (string= "html" (xml-get-attribute node 'type)) - ;; element contains entity escaped html - content - ;; plain text or xhtml - (newsticker--unxml content)))) + (let ((content (car (xml-node-children node))) + (type (xml-get-attribute node 'type))) + (if (string= "xhtml" type) + ;; xhtml: reverse-parse xml nodes back to string + (newsticker--unxml content) + ;; plain text (default) or entity-escaped html: return as-is + content))) (defun newsticker--unxml (node) "Reverse parsing of an xml string. From b12a0683527add8e866f69642c780f1e4cd3eed8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 12 Feb 2026 13:23:24 +0200 Subject: [PATCH 163/191] Add a character to IPA input method MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/leim/quail/ipa.el ("ipa"): Add ɜ. Suggested by Coque Couto . (Bug#80364) --- lisp/leim/quail/ipa.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el index 2d6c6fe5a38..846c9f96f0d 100644 --- a/lisp/leim/quail/ipa.el +++ b/lisp/leim/quail/ipa.el @@ -74,6 +74,7 @@ Upside-down characters are obtained by a preceding slash (/)." ("A~" ["ɑ̃"]) ("oe~" ["Ć“Ìƒ"]) ("/c~" ["ɔ̃"]) + ("/E" ?ɜ) ("p" ?p) ("b" ?b) ("t" ?t) From beb9c26d4c788de775f1ec2c6504a2ecff1f1d02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 12 Feb 2026 12:20:39 +0100 Subject: [PATCH 164/191] ; Simplify 'prog1' optimiser * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Drop unnecessary condition. Noticed by Pip Cet. --- lisp/emacs-lisp/byte-opt.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 1aecae5ac7d..0290a2fd6ca 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -341,14 +341,13 @@ There can be multiple entries for the same NAME if it has several aliases.") (if (cdr exps) (macroexp-progn (byte-optimize-body exps for-effect)) (byte-optimize-form (car exps) for-effect))) + (`(prog1 ,exp . ,exps) - (let ((exp-opt (byte-optimize-form exp for-effect))) - (if exps - (let ((exps-opt (byte-optimize-body exps t))) - (cond ((null exps-opt) exp-opt) - ((macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt)) - (t `(,fn ,exp-opt ,@exps-opt)))) - exp-opt))) + (let ((exp-opt (byte-optimize-form exp for-effect)) + (exps-opt (byte-optimize-body exps t))) + (cond ((null exps-opt) exp-opt) + ((macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt)) + (t `(,fn ,exp-opt ,@exps-opt))))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) ;; Those subrs which have an implicit progn; it's not quite good From 773c74ad7c5133f843116cabdb10226df54a126e Mon Sep 17 00:00:00 2001 From: Arto Jantunen Date: Sun, 8 Feb 2026 09:22:32 +0200 Subject: [PATCH 165/191] Avoid errors in shr.el due to fractional colspan attribute Apparently some people believe that a colspan can be fractional, and produce HTML with such. Make it possible for SHR to render such HTML by truncating colspan. * lisp/net/shr.el (shr-make-table-1): Ensure 'colspan' is a fixnum. (Bug#80354) --- lisp/net/shr.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index bf78cce13bf..517cb3cc237 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -2731,7 +2731,7 @@ flags that control whether to collect or render objects." (aref widths width-column) (* 10 shr-table-separator-pixel-width))) (when (setq colspan (dom-attr column 'colspan)) - (setq colspan (min (string-to-number colspan) + (setq colspan (min (truncate (string-to-number colspan)) ;; The colspan may be wrong, so ;; truncate it to the length of the ;; remaining columns. From c091ff00ec45821b911a8fd83c4b672b9a6e4feb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 12 Feb 2026 08:47:09 -0500 Subject: [PATCH 166/191] lisp/calendar/diary-icalendar.el (di:summary-regexp): Fix `:type` --- lisp/calendar/diary-icalendar.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/calendar/diary-icalendar.el b/lisp/calendar/diary-icalendar.el index 4f1b9b4114a..ed8706c50a7 100644 --- a/lisp/calendar/diary-icalendar.el +++ b/lisp/calendar/diary-icalendar.el @@ -1,6 +1,6 @@ ;;; diary-icalendar.el --- Display iCalendar data in diary -*- lexical-binding: t; -*- -;; Copyright (C) 2025 Free Software Foundation, Inc. +;; Copyright (C) 2025-2026 Free Software Foundation, Inc. ;; Author: Richard Lawrence ;; Created: January 2025 @@ -493,7 +493,7 @@ this variable if you want to export diary entries where the text to be used as the summary does not appear on the first line of the entry. In that case, the summary should match group 1 of this regexp." :version "31.1" - :type '(regexp)) + :type '(choice (const nil) regexp)) (defcustom di:todo-regexp nil "Regular expression that identifies an entry as a task (VTODO). From adf6c7bcbe989871b20c794b3f528aa348bc0c60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Marks?= Date: Wed, 11 Feb 2026 10:10:36 -0500 Subject: [PATCH 167/191] Move ns_init_colors from ns_term_init to emacs.c (bug#80377) Accommodate NS Emacs on a headless system. Add error checking for failed calls to NSColorList writeToURL and writeToFile. * src/nsterm.m (ns_term_init): Move color initialization to nsfns.m. * src/nsfns.m (ns_init_colors): New function. (Fns_list_colors): Call ns_init_colors. --- src/nsfns.m | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/nsterm.m | 48 ---------------------------------------- 2 files changed, 62 insertions(+), 48 deletions(-) diff --git a/src/nsfns.m b/src/nsfns.m index 3d3d5ec1bde..dddceb8d17b 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -2209,6 +2209,62 @@ Frames are listed from topmost (first) to bottommost (last). */) return build_string (ns_xlfd_to_fontname (SSDATA (name))); } +static void +ns_init_colors (void) +{ + NSTRACE ("ns_init_colors"); + + NSColorList *cl = [NSColorList colorListNamed: @"Emacs"]; + + /* There are 752 colors defined in rgb.txt. */ + if ( cl == nil || [[cl allKeys] count] < 752) + { + Lisp_Object color_file, color_map, color, name; + unsigned long c; + + color_file = Fexpand_file_name (build_string ("rgb.txt"), + Fsymbol_value (intern ("data-directory"))); + + color_map = Fx_load_color_file (color_file); + if (NILP (color_map)) + fatal ("Could not read %s.\n", SDATA (color_file)); + + cl = [[NSColorList alloc] initWithName: @"Emacs"]; + for ( ; CONSP (color_map); color_map = XCDR (color_map)) + { + color = XCAR (color_map); + name = XCAR (color); + c = XFIXNUM (XCDR (color)); + c |= 0xFF000000; + [cl setColor: + [NSColor colorWithUnsignedLong:c] + forKey: [NSString stringWithLispString: name]]; + } + @try + { +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 + if ([cl respondsToSelector:@selector(writeToURL:error:)]) +#endif + if ([cl writeToURL:nil error:nil] == false) + fprintf (stderr, "ns_init_colors: could not write Emacs.clr\n"); +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 + else +#endif +#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 */ +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 || defined (NS_IMPL_GNUSTEP) + if ([cl writeToFile: nil] == false) + fprintf (stderr, "ns_init_colors: could not write Emacs.clr\n"); +#endif + } + @catch (NSException *e) + { + NSLog(@"ns_init_colors: could not write Emacs.clr: %@", e.reason); + } + } +} + +static BOOL ns_init_colors_done = NO; DEFUN ("ns-list-colors", Fns_list_colors, Sns_list_colors, 0, 1, 0, doc: /* Return a list of all available colors. @@ -2220,6 +2276,12 @@ Frames are listed from topmost (first) to bottommost (last). */) NSColorList *clist; NSAutoreleasePool *pool; + if (ns_init_colors_done == NO) + { + ns_init_colors (); + ns_init_colors_done = YES; + } + if (!NILP (frame)) { CHECK_FRAME (frame); diff --git a/src/nsterm.m b/src/nsterm.m index d0bbd1b4660..932d209f56b 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -591,7 +591,6 @@ - (unsigned long)unsignedLong setenv ("LANG", lang, 1); } - void ns_release_object (void *obj) /* -------------------------------------------------------------------------- @@ -5891,53 +5890,6 @@ Needs to be here because ns_initialize_display_info () uses AppKit classes. ns_antialias_threshold = NILP (tmp) ? 10.0 : extract_float (tmp); } - NSTRACE_MSG ("Colors"); - - { - NSColorList *cl = [NSColorList colorListNamed: @"Emacs"]; - - /* There are 752 colors defined in rgb.txt. */ - if ( cl == nil || [[cl allKeys] count] < 752) - { - Lisp_Object color_file, color_map, color, name; - unsigned long c; - - color_file = Fexpand_file_name (build_string ("rgb.txt"), - Fsymbol_value (intern ("data-directory"))); - - color_map = Fx_load_color_file (color_file); - if (NILP (color_map)) - fatal ("Could not read %s.\n", SDATA (color_file)); - - cl = [[NSColorList alloc] initWithName: @"Emacs"]; - for ( ; CONSP (color_map); color_map = XCDR (color_map)) - { - color = XCAR (color_map); - name = XCAR (color); - c = XFIXNUM (XCDR (color)); - c |= 0xFF000000; - [cl setColor: - [NSColor colorWithUnsignedLong:c] - forKey: [NSString stringWithLispString: name]]; - } - - /* FIXME: Report any errors writing the color file below. */ -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 - if ([cl respondsToSelector:@selector(writeToURL:error:)]) -#endif - [cl writeToURL:nil error:nil]; -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 - else -#endif -#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 */ -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 \ - || defined (NS_IMPL_GNUSTEP) - [cl writeToFile: nil]; -#endif - } - } - NSTRACE_MSG ("Versions"); delete_keyboard_wait_descriptor (0); From 92f1d0b5d55a9a60c2fea74f9dc81bd0ea09d2ad Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 12 Feb 2026 18:19:32 +0100 Subject: [PATCH 168/191] Simplify mode-line prompt for package suggestions * lisp/emacs-lisp/package-activate.el (package--autosugest-line-format): Just indicate that packages can be installed, don't mention which. --- lisp/emacs-lisp/package-activate.el | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 7981642a7e0..4a0a9b79fb5 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -637,11 +637,7 @@ The elements of the returned list will have the form described in ((eq package-autosuggest-style 'mode-line)) (avail (package--autosuggest-find-candidates))) (propertize - (format " Install %s?" - (mapconcat - #'symbol-name - (delete-dups (mapcar #'car avail)) - ", ")) + "[Upgrade?]" 'face 'mode-line-emphasis 'mouse-face 'mode-line-highlight 'help-echo "Click to install suggested package." From 02af0e93a0e63e6ff8354a778fe186ceedb11ebe Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 12 Feb 2026 18:20:15 +0100 Subject: [PATCH 169/191] ; Reset :initialize for 'package-autosuggest-mode' * lisp/emacs-lisp/package-activate.el (package-autosuggest-mode): We don't need a special initializer for the minor mode, if we are not enabling the option OOTB. --- lisp/emacs-lisp/package-activate.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el index 4a0a9b79fb5..1689d985c28 100644 --- a/lisp/emacs-lisp/package-activate.el +++ b/lisp/emacs-lisp/package-activate.el @@ -674,7 +674,7 @@ This function should be added to `after-change-major-mode-hook'." (define-minor-mode package-autosuggest-mode "Enable the automatic suggestion and installation of packages." :global t :group 'package - :initialize #'custom-initialize-delay + ;; :initialize #'custom-initialize-delay (funcall (if package-autosuggest-mode #'add-hook #'remove-hook) 'after-change-major-mode-hook #'package--autosuggest-after-change-mode)) From 1b02bf1214f478c09283a2affbd66efbb9815752 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Thu, 12 Feb 2026 18:24:47 +0100 Subject: [PATCH 170/191] Ensure package contents for package suggestions * lisp/emacs-lisp/package.el (package--autosugest-prompt): Query archives if the package being described is not listed in package-archive-contents'. --- lisp/emacs-lisp/package.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 44da3ab94e1..e2d35f20eb5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4578,7 +4578,12 @@ so you have to select which to install!)" nl)) (package--autosuggest-install-and-enable (car sugs)) (quit-window))) - " (" (buttonize "about" #'describe-package pkg) + " (" + (buttonize "about" + (lambda (_) + (unless (assq pkg package-archive-contents) + (package-read-all-archive-contents)) + (describe-package pkg))) ", matches ") (dolist (sug sugs) (unless (eq (char-before) ?\s) From f8a25d00ae45a3362b08a999026835fde85f6ef0 Mon Sep 17 00:00:00 2001 From: Stephen Berman Date: Thu, 12 Feb 2026 18:48:20 +0100 Subject: [PATCH 171/191] Make 'overlays_in' use only real EOB (bug#80242) This restores the original behavior of 'overlays_in'. Changes in this behavior had been made for cases of narrowing, but this resulted in a regression with uses of 'remove-overlays'. * src/buffer.c (overlays_in): Change all occurrences of ZV to Z. * test/src/buffer-tests.el (test-overlays-in-2) (test-remove-overlays): Adjust expected results to accommodate changes in 'overlays_in'. --- src/buffer.c | 13 ++++++------- test/src/buffer-tests.el | 11 ++++++++--- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index 3d85d784f1c..1129d178c7b 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -3082,14 +3082,13 @@ overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend, { ptrdiff_t idx = 0; ptrdiff_t len = *len_ptr; - ptrdiff_t next = ZV; + ptrdiff_t next = Z; Lisp_Object *vec = *vec_ptr; struct itree_node *node; - /* Extend the search range if overlays beginning at ZV are - wanted. */ - ptrdiff_t search_end = ZV; - if (end >= ZV && (empty || trailing)) + /* Extend the search range if overlays beginning at Z are wanted. */ + ptrdiff_t search_end = Z; + if (end >= Z && (empty || trailing)) ++search_end; ITREE_FOREACH (node, current_buffer->overlays, beg, search_end, @@ -3103,7 +3102,7 @@ overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend, else if (node->begin == end) { next = node->begin; - if ((! empty || end < ZV) && beg < end) + if ((! empty || end < Z) && beg < end) break; if (empty && node->begin != node->end) continue; @@ -3125,7 +3124,7 @@ overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend, idx++; } if (next_ptr) - *next_ptr = next ? next : ZV; + *next_ptr = next ? next : Z; return idx; } diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 5f534ed513a..f4654e90bce 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -1060,7 +1060,9 @@ should evaporate overlays in both." (should-length 2 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max))) (narrow-to-region 1 50) - (should-length 1 (overlays-in 1 (point-max))) + ;; We only count empty overlays in narrowed buffers excluding the + ;; real EOB when the region is confined to `point-max'. + (should-length 0 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max)))))) @@ -8375,8 +8377,11 @@ dicta sunt, explicabo. ")) (should (= (length (overlays-in 1 2)) 0)) (narrow-to-region 1 2) ;; We've now narrowed, so the zero-length overlay is at the end of - ;; the (accessible part of the) buffer. - (should (= (length (overlays-in 1 2)) 1)) + ;; the (accessible part of the) buffer, but we only count it when + ;; the region is confined to `point-max'. + (should (= (length (overlays-in 1 2)) 0)) + (should (= (length (overlays-in 2 2)) 1)) + (should (= (length (overlays-in (point-max) (point-max))) 1)) (remove-overlays) (should (= (length (overlays-in (point-min) (point-max))) 0)))) From df48f7efc61777804a342d22a79f55649bc306a3 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Mon, 17 Jun 2024 19:47:04 +0200 Subject: [PATCH 172/191] Don't dump lispfwd objects The forwarding structs already exist in the data or bss section. They are all created with DEFVAR_INT and similar macros. Instead of creating new structs in the dump, create relocs to the data section. * src/pdumper.c (dump_field_fwd): New. (dump_blv, dump_symbol): Use it. (dump_pre_dump_symbol): Don't dump fwd objects. --- src/pdumper.c | 69 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 47 insertions(+), 22 deletions(-) diff --git a/src/pdumper.c b/src/pdumper.c index 151c45b3348..bc3f3f3d63a 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2383,6 +2383,51 @@ dump_fwd (struct dump_context *ctx, lispfwd fwd) } } +static void +dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, + const lispfwd *in_field) +{ + dump_field_emacs_ptr (ctx, out, in_start, in_field); + switch (XFWDTYPE (*in_field)) + { + case Lisp_Fwd_Int: + { + const struct Lisp_Intfwd *fwd = in_field->fwdptr; + dump_emacs_reloc_immediate_intmax_t (ctx, fwd->intvar, *fwd->intvar); + } + break; + case Lisp_Fwd_Bool: + { + const struct Lisp_Boolfwd *fwd = in_field->fwdptr; + dump_emacs_reloc_immediate_bool (ctx, fwd->boolvar, *fwd->boolvar); + } + break; + case Lisp_Fwd_Obj: + { + const struct Lisp_Objfwd *fwd = in_field->fwdptr; + if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (fwd->objvar)), + ctx->staticpro_table, Qnil))) + dump_emacs_reloc_to_lv (ctx, fwd->objvar, *fwd->objvar); + } + break; + case Lisp_Fwd_Kboard_Obj: + break; + case Lisp_Fwd_Buffer_Obj: + { + const struct Lisp_Buffer_Objfwd *fwd = in_field->fwdptr; + dump_emacs_reloc_immediate (ctx, &fwd->type, &fwd->type, + sizeof fwd->type); + dump_emacs_reloc_immediate (ctx, &fwd->offset, &fwd->offset, + sizeof fwd->offset); + eassert (SYMBOLP (fwd->predicate)); + /* FIXME: assumes symbols are represented as offsets from lispsym */ + dump_emacs_reloc_immediate (ctx, &fwd->predicate, &fwd->predicate, + sizeof fwd->predicate); + } + break; + } +} + static dump_off dump_blv (struct dump_context *ctx, const struct Lisp_Buffer_Local_Value *blv) @@ -2397,14 +2442,12 @@ dump_blv (struct dump_context *ctx, if (blv->fwd.fwdptr) { eassert (XFWDTYPE (blv->fwd) != Lisp_Fwd_Buffer_Obj); - dump_field_emacs_ptr (ctx, &out, blv, &blv->fwd.fwdptr); + dump_field_fwd (ctx, &out, blv, &blv->fwd); } dump_field_lv (ctx, &out, blv, &blv->where, WEIGHT_NORMAL); dump_field_lv (ctx, &out, blv, &blv->defcell, WEIGHT_STRONG); dump_field_lv (ctx, &out, blv, &blv->valcell, WEIGHT_STRONG); dump_off offset = dump_object_finish (ctx, &out, sizeof (out)); - if (blv->fwd.fwdptr) - dump_fwd (ctx, blv->fwd); return offset; } @@ -2446,11 +2489,6 @@ dump_pre_dump_symbol (struct dump_context *ctx, struct Lisp_Symbol *symbol) dump_remember_symbol_aux (ctx, symbol_lv, dump_blv (ctx, symbol->u.s.val.blv)); break; - case SYMBOL_FORWARDED: - dump_fwd (ctx, symbol->u.s.val.fwd); - dump_remember_symbol_aux (ctx, symbol_lv, - emacs_offset (symbol->u.s.val.fwd.fwdptr)); - break; default: break; } @@ -2515,11 +2553,7 @@ dump_symbol (struct dump_context *ctx, Lisp_Object object, dump_field_fixup_later (ctx, &out, symbol, &symbol->u.s.val.blv); break; case SYMBOL_FORWARDED: - /* This forwarding descriptor is in Emacs's core, but the symbol - is initialized at runtime. The next switch statement might - dump this value if it hasn't already been dumped by - dump_pre_dump_symbol. */ - dump_field_emacs_ptr (ctx, &out, symbol, &symbol->u.s.val.fwd.fwdptr); + dump_field_fwd (ctx, &out, symbol, &symbol->u.s.val.fwd); break; default: @@ -2541,15 +2575,6 @@ dump_symbol (struct dump_context *ctx, Lisp_Object object, ? aux_offset : dump_blv (ctx, symbol->u.s.val.blv))); break; - case SYMBOL_FORWARDED: - aux_offset = dump_recall_symbol_aux (ctx, make_lisp_symbol (symbol)); - /* Symbols interned by a defvar are not copied objects. */ - if (!aux_offset) - dump_fwd (ctx, symbol->u.s.val.fwd); - if (aux_offset && (aux_offset - != emacs_offset (symbol->u.s.val.fwd.fwdptr))) - emacs_abort (); - break; default: break; } From ba9a765081873a5caf5053e8b6203b00ef7324e0 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sat, 22 Jun 2024 16:43:29 +0200 Subject: [PATCH 173/191] Make Lisp_Buffer_Objfwd objects const The predicate field is always a builtin symbol. That means we know the bit pattern at compile-time and they don't change at runtime. * src/buffer.c (DEFVAR_PER_BUFFER): Create a const struct. (defvar_per_buffer): Remove predicate and address arguments. (syms_of_buffer): Instead of &BVAR (current_buffer, foo) use a plain foo as argument to DEFVAR_PER_BUFFER. * src/pdumper.c (dump_field_fwd): No more relocs needed for Lisp_Fwd_Buffer_Obj and we can't apply them in the .rodata section. --- src/buffer.c | 157 +++++++++++++++++++++++++------------------------- src/pdumper.c | 21 ++----- 2 files changed, 84 insertions(+), 94 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index 1129d178c7b..70ae2ba3d7b 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -4980,31 +4980,33 @@ init_buffer (void) that nil is allowed too). DOC is a dummy where you write the doc string as a comment. */ -#define DEFVAR_PER_BUFFER(lname, vname, predicate, doc) \ - do { \ - static struct Lisp_Buffer_Objfwd bo_fwd; \ - defvar_per_buffer (&bo_fwd, lname, vname, predicate); \ - } while (0) +/* FIXME: use LISPSYM_INITIALLY instead of TAG_PTR_INITIALLY */ +#define DEFVAR_PER_BUFFER(lname, vname, predicate_, doc) \ +do \ + { \ + const Lisp_Object sym = TAG_PTR_INITIALLY ( \ + Lisp_Symbol, (intptr_t)((i##predicate_) * sizeof *lispsym)); \ + static const struct Lisp_Buffer_Objfwd bo_fwd = { \ + .type = Lisp_Fwd_Buffer_Obj, \ + .offset = offsetof (struct buffer, vname##_), \ + .predicate = sym, \ + }; \ + defvar_per_buffer (&bo_fwd, lname); \ + } \ +while (0) static void -defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring, - Lisp_Object *address, Lisp_Object predicate) +defvar_per_buffer (const struct Lisp_Buffer_Objfwd *bo_fwd, + const char *namestring) { - struct Lisp_Symbol *sym; - int offset; + struct Lisp_Symbol *sym = XSYMBOL (intern (namestring)); - sym = XSYMBOL (intern (namestring)); - offset = (char *)address - (char *)current_buffer; - - bo_fwd->type = Lisp_Fwd_Buffer_Obj; - bo_fwd->offset = offset; - bo_fwd->predicate = predicate; sym->u.s.declared_special = true; sym->u.s.redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (sym, bo_fwd); - XSETSYMBOL (PER_BUFFER_SYMBOL (offset), sym); + XSETSYMBOL (PER_BUFFER_SYMBOL (bo_fwd->offset), sym); - if (PER_BUFFER_IDX (offset) == 0) + if (PER_BUFFER_IDX (bo_fwd->offset) == 0) /* Did a DEFVAR_PER_BUFFER without initializing the corresponding slot of buffer_local_flags. */ emacs_abort (); @@ -5103,14 +5105,14 @@ syms_of_buffer (void) DEFSYM (Qclone_indirect_buffer_hook, "clone-indirect-buffer-hook"); DEFVAR_PER_BUFFER ("tab-line-format", - &BVAR (current_buffer, tab_line_format), + tab_line_format, Qnil, doc: /* Analogous to `mode-line-format', but controls the tab line. The tab line appears, optionally, at the top of a window; the mode line appears at the bottom. */); DEFVAR_PER_BUFFER ("header-line-format", - &BVAR (current_buffer, header_line_format), + header_line_format, Qnil, doc: /* Analogous to `mode-line-format', but controls the header line. The header line appears, optionally, at the top of a window; the mode @@ -5119,7 +5121,7 @@ line appears at the bottom. Also see `header-line-indent-mode' if `display-line-numbers-mode' is turned on and header-line text should be aligned with buffer text. */); - DEFVAR_PER_BUFFER ("mode-line-format", &BVAR (current_buffer, mode_line_format), + DEFVAR_PER_BUFFER ("mode-line-format", mode_line_format, Qnil, doc: /* Template for displaying mode line for a window's buffer. @@ -5193,7 +5195,7 @@ A string is printed verbatim in the mode line except for %-constructs: %% -- print %. Decimal digits after the % specify field width to which to pad. */); - DEFVAR_PER_BUFFER ("major-mode", &BVAR (current_buffer, major_mode), + DEFVAR_PER_BUFFER ("major-mode", major_mode, Qsymbolp, doc: /* Symbol for current buffer's major mode. The default value (normally `fundamental-mode') affects new buffers. @@ -5201,28 +5203,28 @@ A value of nil means to use the current buffer's major mode, provided it is not marked as "special". */); DEFVAR_PER_BUFFER ("local-minor-modes", - &BVAR (current_buffer, local_minor_modes), + local_minor_modes, Qnil, doc: /* Minor modes currently active in the current buffer. This is a list of symbols, or nil if there are no minor modes active. */); - DEFVAR_PER_BUFFER ("mode-name", &BVAR (current_buffer, mode_name), + DEFVAR_PER_BUFFER ("mode-name", mode_name, Qnil, doc: /* Pretty name of current buffer's major mode. Usually a string, but can use any of the constructs for `mode-line-format', which see. Format with `format-mode-line' to produce a string value. */); - DEFVAR_PER_BUFFER ("local-abbrev-table", &BVAR (current_buffer, abbrev_table), Qnil, + DEFVAR_PER_BUFFER ("local-abbrev-table", abbrev_table, Qnil, doc: /* Local (mode-specific) abbrev table of current buffer. */); - DEFVAR_PER_BUFFER ("abbrev-mode", &BVAR (current_buffer, abbrev_mode), Qnil, + DEFVAR_PER_BUFFER ("abbrev-mode", abbrev_mode, Qnil, doc: /* Non-nil if Abbrev mode is enabled. Use the command `abbrev-mode' to change the value of this variable in the current buffer. Customize this variable to non-nil to enable Abbrev mode by default in all buffers. */); - DEFVAR_PER_BUFFER ("fill-column", &BVAR (current_buffer, fill_column), + DEFVAR_PER_BUFFER ("fill-column", fill_column, Qintegerp, doc: /* Column beyond which automatic line-wrapping should happen. It is used by filling commands, such as `fill-region' and `fill-paragraph', @@ -5230,12 +5232,12 @@ and by `auto-fill-mode', which see. See also `current-fill-column'. Interactively, you can set the buffer local value using \\[set-fill-column]. */); - DEFVAR_PER_BUFFER ("left-margin", &BVAR (current_buffer, left_margin), + DEFVAR_PER_BUFFER ("left-margin", left_margin, Qintegerp, doc: /* Column for the default `indent-line-function' to indent to. Linefeed indents to this column in Fundamental mode. */); - DEFVAR_PER_BUFFER ("tab-width", &BVAR (current_buffer, tab_width), + DEFVAR_PER_BUFFER ("tab-width", tab_width, Qintegerp, doc: /* Distance between tab stops (for display of tab characters), in columns. This controls the width of a TAB character on display. @@ -5245,14 +5247,14 @@ indentation step. However, if the major mode's indentation facility inserts one or more TAB characters, this variable will affect the indentation step as well, even if `indent-tabs-mode' is non-nil. */); - DEFVAR_PER_BUFFER ("ctl-arrow", &BVAR (current_buffer, ctl_arrow), Qnil, + DEFVAR_PER_BUFFER ("ctl-arrow", ctl_arrow, Qnil, doc: /* Non-nil means display control chars with uparrow `^'. A value of nil means use backslash `\\' and octal digits. This variable does not apply to characters whose display is specified in the current display table (if there is one; see `standard-display-table'). */); DEFVAR_PER_BUFFER ("enable-multibyte-characters", - &BVAR (current_buffer, enable_multibyte_characters), + enable_multibyte_characters, Qnil, doc: /* Non-nil means the buffer contents are regarded as multi-byte characters. Otherwise they are regarded as unibyte. This affects the display, @@ -5266,7 +5268,7 @@ See also Info node `(elisp)Text Representations'. */); make_symbol_constant (intern_c_string ("enable-multibyte-characters")); DEFVAR_PER_BUFFER ("buffer-file-coding-system", - &BVAR (current_buffer, buffer_file_coding_system), Qnil, + buffer_file_coding_system, Qnil, doc: /* Coding system to be used for encoding the buffer contents on saving. This variable applies to saving the buffer, and also to `write-region' and other functions that use `write-region'. @@ -5284,7 +5286,7 @@ The variable `coding-system-for-write', if non-nil, overrides this variable. This variable is never applied to a way of decoding a file while reading it. */); DEFVAR_PER_BUFFER ("bidi-display-reordering", - &BVAR (current_buffer, bidi_display_reordering), Qnil, + bidi_display_reordering, Qnil, doc: /* Non-nil means reorder bidirectional text for display in the visual order. Setting this to nil is intended for use in debugging the display code. Don't set to nil in normal sessions, as that is not supported. @@ -5292,7 +5294,7 @@ See also `bidi-paragraph-direction'; setting that non-nil might speed up redisplay. */); DEFVAR_PER_BUFFER ("bidi-paragraph-start-re", - &BVAR (current_buffer, bidi_paragraph_start_re), Qnil, + bidi_paragraph_start_re, Qnil, doc: /* If non-nil, a regexp matching a line that starts OR separates paragraphs. The value of nil means to use empty lines as lines that start and @@ -5314,7 +5316,7 @@ set both these variables to "^". See also `bidi-paragraph-direction'. */); DEFVAR_PER_BUFFER ("bidi-paragraph-separate-re", - &BVAR (current_buffer, bidi_paragraph_separate_re), Qnil, + bidi_paragraph_separate_re, Qnil, doc: /* If non-nil, a regexp matching a line that separates paragraphs. The value of nil means to use empty lines as paragraph separators. @@ -5335,7 +5337,7 @@ set both these variables to "^". See also `bidi-paragraph-direction'. */); DEFVAR_PER_BUFFER ("bidi-paragraph-direction", - &BVAR (current_buffer, bidi_paragraph_direction), Qnil, + bidi_paragraph_direction, Qnil, doc: /* If non-nil, forces directionality of text paragraphs in the buffer. If this is nil (the default), the direction of each paragraph is @@ -5346,7 +5348,7 @@ Any other value is treated as nil. This variable has no effect unless the buffer's value of `bidi-display-reordering' is non-nil. */); - DEFVAR_PER_BUFFER ("truncate-lines", &BVAR (current_buffer, truncate_lines), Qnil, + DEFVAR_PER_BUFFER ("truncate-lines", truncate_lines, Qnil, doc: /* Non-nil means do not display continuation lines. Instead, give each line of text just one screen line. @@ -5359,7 +5361,7 @@ Minibuffers set this variable to nil. Don't set this to a non-nil value when `visual-line-mode' is turned on, as it could produce confusing results. */); - DEFVAR_PER_BUFFER ("word-wrap", &BVAR (current_buffer, word_wrap), Qnil, + DEFVAR_PER_BUFFER ("word-wrap", word_wrap, Qnil, doc: /* Non-nil means to use word-wrapping for continuation lines. When word-wrapping is on, continuation lines are wrapped at the space or tab character nearest to the right window edge. @@ -5377,14 +5379,14 @@ to t, and additionally redefines simple editing commands to act on visual lines rather than logical lines. See the documentation of `visual-line-mode'. */); - DEFVAR_PER_BUFFER ("default-directory", &BVAR (current_buffer, directory), + DEFVAR_PER_BUFFER ("default-directory", directory, Qstringp, doc: /* Name of default directory of current buffer. It should be an absolute directory name; on GNU and Unix systems, these names start with "/" or "~" and end with "/". To interactively change the default directory, use the command `cd'. */); - DEFVAR_PER_BUFFER ("auto-fill-function", &BVAR (current_buffer, auto_fill_function), + DEFVAR_PER_BUFFER ("auto-fill-function", auto_fill_function, Qnil, doc: /* Function called (if non-nil) to perform auto-fill. It is called after self-inserting any character specified in @@ -5392,31 +5394,31 @@ the `auto-fill-chars' table. NOTE: This variable is not a hook; its value may not be a list of functions. */); - DEFVAR_PER_BUFFER ("buffer-file-name", &BVAR (current_buffer, filename), + DEFVAR_PER_BUFFER ("buffer-file-name", filename, Qstringp, doc: /* Name of file visited in current buffer, or nil if not visiting a file. This should be an absolute file name. */); - DEFVAR_PER_BUFFER ("buffer-file-truename", &BVAR (current_buffer, file_truename), + DEFVAR_PER_BUFFER ("buffer-file-truename", file_truename, Qstringp, doc: /* Abbreviated truename of file visited in current buffer, or nil if none. The truename of a file is calculated by `file-truename' and then abbreviated with `abbreviate-file-name'. */); DEFVAR_PER_BUFFER ("buffer-auto-save-file-name", - &BVAR (current_buffer, auto_save_file_name), + auto_save_file_name, Qstringp, doc: /* Name of file for auto-saving current buffer. If it is nil, that means don't auto-save this buffer. */); - DEFVAR_PER_BUFFER ("buffer-read-only", &BVAR (current_buffer, read_only), Qnil, + DEFVAR_PER_BUFFER ("buffer-read-only", read_only, Qnil, doc: /* Non-nil if this buffer is read-only. */); - DEFVAR_PER_BUFFER ("buffer-backed-up", &BVAR (current_buffer, backed_up), Qnil, + DEFVAR_PER_BUFFER ("buffer-backed-up", backed_up, Qnil, doc: /* Non-nil if this buffer's file has been backed up. Backing up is done before the first time the file is saved. */); - DEFVAR_PER_BUFFER ("buffer-saved-size", &BVAR (current_buffer, save_length), + DEFVAR_PER_BUFFER ("buffer-saved-size", save_length, Qintegerp, doc: /* Length of current buffer when last read in, saved or auto-saved. 0 initially. @@ -5426,7 +5428,7 @@ If you set this to -2, that means don't turn off auto-saving in this buffer if its text size shrinks. If you use `buffer-swap-text' on a buffer, you probably should set this to -2 in that buffer. */); - DEFVAR_PER_BUFFER ("selective-display", &BVAR (current_buffer, selective_display), + DEFVAR_PER_BUFFER ("selective-display", selective_display, Qnil, doc: /* Non-nil enables selective display. @@ -5439,11 +5441,11 @@ in a file, save the ^M as a newline. This usage is obsolete; use overlays or text properties instead. */); DEFVAR_PER_BUFFER ("selective-display-ellipses", - &BVAR (current_buffer, selective_display_ellipses), + selective_display_ellipses, Qnil, doc: /* Non-nil means display ... on previous line when a line is invisible. */); - DEFVAR_PER_BUFFER ("overwrite-mode", &BVAR (current_buffer, overwrite_mode), + DEFVAR_PER_BUFFER ("overwrite-mode", overwrite_mode, Qoverwrite_mode, doc: /* Non-nil if self-insertion should replace existing text. The value should be one of `overwrite-mode-textual', @@ -5453,7 +5455,7 @@ inserts at the end of a line, and inserts when point is before a tab, until the tab is filled in. If `overwrite-mode-binary', self-insertion replaces newlines and tabs too. */); - DEFVAR_PER_BUFFER ("buffer-display-table", &BVAR (current_buffer, display_table), + DEFVAR_PER_BUFFER ("buffer-display-table", display_table, Qnil, doc: /* Display table that controls display of the contents of current buffer. @@ -5490,7 +5492,7 @@ In addition, a char-table has six extra slots to control the display of: See also the functions `display-table-slot' and `set-display-table-slot'. */); - DEFVAR_PER_BUFFER ("left-margin-width", &BVAR (current_buffer, left_margin_cols), + DEFVAR_PER_BUFFER ("left-margin-width", left_margin_cols, Qintegerp, doc: /* Width in columns of left marginal area for display of a buffer. A value of nil means no marginal area. @@ -5498,7 +5500,7 @@ A value of nil means no marginal area. Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); - DEFVAR_PER_BUFFER ("right-margin-width", &BVAR (current_buffer, right_margin_cols), + DEFVAR_PER_BUFFER ("right-margin-width", right_margin_cols, Qintegerp, doc: /* Width in columns of right marginal area for display of a buffer. A value of nil means no marginal area. @@ -5506,7 +5508,7 @@ A value of nil means no marginal area. Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); - DEFVAR_PER_BUFFER ("left-fringe-width", &BVAR (current_buffer, left_fringe_width), + DEFVAR_PER_BUFFER ("left-fringe-width", left_fringe_width, Qintegerp, doc: /* Width of this buffer's left fringe (in pixels). A value of 0 means no left fringe is shown in this buffer's window. @@ -5515,7 +5517,7 @@ A value of nil means to use the left fringe width from the window's frame. Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); - DEFVAR_PER_BUFFER ("right-fringe-width", &BVAR (current_buffer, right_fringe_width), + DEFVAR_PER_BUFFER ("right-fringe-width", right_fringe_width, Qintegerp, doc: /* Width of this buffer's right fringe (in pixels). A value of 0 means no right fringe is shown in this buffer's window. @@ -5524,7 +5526,7 @@ A value of nil means to use the right fringe width from the window's frame. Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); - DEFVAR_PER_BUFFER ("fringes-outside-margins", &BVAR (current_buffer, fringes_outside_margins), + DEFVAR_PER_BUFFER ("fringes-outside-margins", fringes_outside_margins, Qnil, doc: /* Non-nil means to display fringes outside display margins. A value of nil means to display fringes between margins and buffer text. @@ -5532,17 +5534,17 @@ A value of nil means to display fringes between margins and buffer text. Setting this variable does not take effect until a new buffer is displayed in a window. To make the change take effect, call `set-window-buffer'. */); - DEFVAR_PER_BUFFER ("scroll-bar-width", &BVAR (current_buffer, scroll_bar_width), + DEFVAR_PER_BUFFER ("scroll-bar-width", scroll_bar_width, Qintegerp, doc: /* Width of this buffer's vertical scroll bars in pixels. A value of nil means to use the scroll bar width from the window's frame. */); - DEFVAR_PER_BUFFER ("scroll-bar-height", &BVAR (current_buffer, scroll_bar_height), + DEFVAR_PER_BUFFER ("scroll-bar-height", scroll_bar_height, Qintegerp, doc: /* Height of this buffer's horizontal scroll bars in pixels. A value of nil means to use the scroll bar height from the window's frame. */); - DEFVAR_PER_BUFFER ("vertical-scroll-bar", &BVAR (current_buffer, vertical_scroll_bar_type), + DEFVAR_PER_BUFFER ("vertical-scroll-bar", vertical_scroll_bar_type, Qvertical_scroll_bar, doc: /* Position of this buffer's vertical scroll bar. The value takes effect whenever you tell a window to display this buffer; @@ -5552,7 +5554,7 @@ A value of `left' or `right' means put the vertical scroll bar at that side of the window; a value of nil means don't show any vertical scroll bars. A value of t (the default) means do whatever the window's frame specifies. */); - DEFVAR_PER_BUFFER ("horizontal-scroll-bar", &BVAR (current_buffer, horizontal_scroll_bar_type), + DEFVAR_PER_BUFFER ("horizontal-scroll-bar", horizontal_scroll_bar_type, Qnil, doc: /* Position of this buffer's horizontal scroll bar. The value takes effect whenever you tell a window to display this buffer; @@ -5564,14 +5566,14 @@ A value of t (the default) means do whatever the window's frame specifies. */); DEFVAR_PER_BUFFER ("indicate-empty-lines", - &BVAR (current_buffer, indicate_empty_lines), Qnil, + indicate_empty_lines, Qnil, doc: /* Visually indicate unused ("empty") screen lines after the buffer end. If non-nil, a bitmap is displayed in the left fringe of a window on graphical displays for each screen line that doesn't correspond to any buffer text. */); DEFVAR_PER_BUFFER ("indicate-buffer-boundaries", - &BVAR (current_buffer, indicate_buffer_boundaries), Qnil, + indicate_buffer_boundaries, Qnil, doc: /* Visually indicate buffer boundaries and scrolling. If non-nil, the first and last line of the buffer are marked in the fringe of a window on graphical displays with angle bitmaps, or if the window can be @@ -5596,7 +5598,7 @@ bitmaps in right fringe. To show just the angle bitmaps in the left fringe, but no arrow bitmaps, use ((top . left) (bottom . left)). */); DEFVAR_PER_BUFFER ("fringe-indicator-alist", - &BVAR (current_buffer, fringe_indicator_alist), Qnil, + fringe_indicator_alist, Qnil, doc: /* Mapping from logical to physical fringe indicator bitmaps. The value is an alist where each element (INDICATOR . BITMAPS) specifies the fringe bitmaps used to display a specific logical @@ -5615,7 +5617,7 @@ last (only) line has no final newline. BITMAPS may also be a single symbol which is used in both left and right fringes. */); DEFVAR_PER_BUFFER ("fringe-cursor-alist", - &BVAR (current_buffer, fringe_cursor_alist), Qnil, + fringe_cursor_alist, Qnil, doc: /* Mapping from logical to physical fringe cursor bitmaps. The value is an alist where each element (CURSOR . BITMAP) specifies the fringe bitmaps used to display a specific logical @@ -5630,7 +5632,7 @@ BITMAP is the corresponding fringe bitmap shown for the logical cursor type. */); DEFVAR_PER_BUFFER ("scroll-up-aggressively", - &BVAR (current_buffer, scroll_up_aggressively), Qfraction, + scroll_up_aggressively, Qfraction, doc: /* How far to scroll windows upward. If you move point off the bottom, the window scrolls automatically. This variable controls how far it scrolls. The value nil, the default, @@ -5643,7 +5645,7 @@ window scrolls by a full window height. Meaningful values are between 0.0 and 1.0, inclusive. */); DEFVAR_PER_BUFFER ("scroll-down-aggressively", - &BVAR (current_buffer, scroll_down_aggressively), Qfraction, + scroll_down_aggressively, Qfraction, doc: /* How far to scroll windows downward. If you move point off the top, the window scrolls automatically. This variable controls how far it scrolls. The value nil, the default, @@ -5694,7 +5696,7 @@ from happening repeatedly and making Emacs nonfunctional. */); The functions are run using the `run-hooks' function. */); Vfirst_change_hook = Qnil; - DEFVAR_PER_BUFFER ("buffer-undo-list", &BVAR (current_buffer, undo_list), Qnil, + DEFVAR_PER_BUFFER ("buffer-undo-list", undo_list, Qnil, doc: /* List of undo entries in current buffer. Recent changes come first; older changes follow newer. @@ -5740,10 +5742,10 @@ the changes between two undo boundaries as a single step to be undone. If the value of the variable is t, undo information is not recorded. */); - DEFVAR_PER_BUFFER ("mark-active", &BVAR (current_buffer, mark_active), Qnil, + DEFVAR_PER_BUFFER ("mark-active", mark_active, Qnil, doc: /* Non-nil means the mark and region are currently active in this buffer. */); - DEFVAR_PER_BUFFER ("cache-long-scans", &BVAR (current_buffer, cache_long_scans), Qnil, + DEFVAR_PER_BUFFER ("cache-long-scans", cache_long_scans, Qnil, doc: /* Non-nil means that Emacs should use caches in attempt to speedup buffer scans. There is no reason to set this to nil except for debugging purposes. @@ -5779,23 +5781,23 @@ maintained internally by the Emacs primitives. Enabling or disabling the cache should not affect the behavior of any of the motion functions; it should only affect their performance. */); - DEFVAR_PER_BUFFER ("point-before-scroll", &BVAR (current_buffer, point_before_scroll), Qnil, + DEFVAR_PER_BUFFER ("point-before-scroll", point_before_scroll, Qnil, doc: /* Value of point before the last series of scroll operations, or nil. */); - DEFVAR_PER_BUFFER ("buffer-file-format", &BVAR (current_buffer, file_format), Qnil, + DEFVAR_PER_BUFFER ("buffer-file-format", file_format, Qnil, doc: /* List of formats to use when saving this buffer. Formats are defined by `format-alist'. This variable is set when a file is visited. */); DEFVAR_PER_BUFFER ("buffer-auto-save-file-format", - &BVAR (current_buffer, auto_save_file_format), Qnil, + auto_save_file_format, Qnil, doc: /* Format in which to write auto-save files. Should be a list of symbols naming formats that are defined in `format-alist'. If it is t, which is the default, auto-save files are written in the same format as a regular save would use. */); DEFVAR_PER_BUFFER ("buffer-invisibility-spec", - &BVAR (current_buffer, invisibility_spec), Qnil, + invisibility_spec, Qnil, doc: /* Invisibility spec of this buffer. The default is t, which means that text is invisible if it has a non-nil `invisible' property. @@ -5809,12 +5811,12 @@ Setting this variable is very fast, much faster than scanning all the text in the buffer looking for properties to change. */); DEFVAR_PER_BUFFER ("buffer-display-count", - &BVAR (current_buffer, display_count), Qintegerp, + display_count, Qintegerp, doc: /* A number incremented each time this buffer is displayed in a window. The function `set-window-buffer' increments it. */); DEFVAR_PER_BUFFER ("buffer-display-time", - &BVAR (current_buffer, display_time), Qnil, + display_time, Qnil, doc: /* Time stamp updated each time this buffer is displayed in a window. The function `set-window-buffer' updates this variable to the value obtained by calling `current-time'. @@ -5850,7 +5852,7 @@ member of the list. Any other non-nil value means disregard `buffer-read-only' and all `read-only' text properties. */); Vinhibit_read_only = Qnil; - DEFVAR_PER_BUFFER ("cursor-type", &BVAR (current_buffer, cursor_type), Qnil, + DEFVAR_PER_BUFFER ("cursor-type", cursor_type, Qnil, doc: /* Cursor to use when this buffer is in the selected window. Values are interpreted as follows: @@ -5874,7 +5876,7 @@ cursor's appearance is instead controlled by the variable `cursor-in-non-selected-windows'. */); DEFVAR_PER_BUFFER ("line-spacing", - &BVAR (current_buffer, extra_line_spacing), Qnil, + extra_line_spacing, Qnil, doc: /* Additional space to put between lines when displaying a buffer. The space is measured in pixels, and put below lines on graphic displays, see `display-graphic-p'. @@ -5885,7 +5887,7 @@ it is interpreted as space above and below the line, respectively. A value of nil means add no extra space. */); DEFVAR_PER_BUFFER ("cursor-in-non-selected-windows", - &BVAR (current_buffer, cursor_in_non_selected_windows), Qnil, + cursor_in_non_selected_windows, Qnil, doc: /* Non-nil means show a cursor in non-selected windows. If nil, only shows a cursor in the selected window. If t, displays a cursor related to the usual cursor type @@ -5896,8 +5898,7 @@ Use Custom to set this variable and update the display. */); /* While this is defined here, each *term.c module must implement the logic itself. */ - DEFVAR_PER_BUFFER ("text-conversion-style", &BVAR (current_buffer, - text_conversion_style), + DEFVAR_PER_BUFFER ("text-conversion-style", text_conversion_style, Qnil, doc: /* How the on screen keyboard's input method should insert in this buffer. diff --git a/src/pdumper.c b/src/pdumper.c index bc3f3f3d63a..03a985f89d1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2395,13 +2395,13 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, const struct Lisp_Intfwd *fwd = in_field->fwdptr; dump_emacs_reloc_immediate_intmax_t (ctx, fwd->intvar, *fwd->intvar); } - break; + return; case Lisp_Fwd_Bool: { const struct Lisp_Boolfwd *fwd = in_field->fwdptr; dump_emacs_reloc_immediate_bool (ctx, fwd->boolvar, *fwd->boolvar); } - break; + return; case Lisp_Fwd_Obj: { const struct Lisp_Objfwd *fwd = in_field->fwdptr; @@ -2409,23 +2409,12 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, ctx->staticpro_table, Qnil))) dump_emacs_reloc_to_lv (ctx, fwd->objvar, *fwd->objvar); } - break; + return; case Lisp_Fwd_Kboard_Obj: - break; case Lisp_Fwd_Buffer_Obj: - { - const struct Lisp_Buffer_Objfwd *fwd = in_field->fwdptr; - dump_emacs_reloc_immediate (ctx, &fwd->type, &fwd->type, - sizeof fwd->type); - dump_emacs_reloc_immediate (ctx, &fwd->offset, &fwd->offset, - sizeof fwd->offset); - eassert (SYMBOLP (fwd->predicate)); - /* FIXME: assumes symbols are represented as offsets from lispsym */ - dump_emacs_reloc_immediate (ctx, &fwd->predicate, &fwd->predicate, - sizeof fwd->predicate); - } - break; + return; } + emacs_abort (); } static dump_off From 10befec978d1f1490f1eb43fd590e9474252063f Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 06:39:18 +0200 Subject: [PATCH 174/191] Introduce a struct Lisp_Fwd This contains the type and an union of Lisp_Objfwd, Lisp_Intfwd etc. lispfwd is now a pointer to a struct Lisp_Fwd; the void *fwdptr field is gone. * src/lisp.h (struct Lisp_Fwd): New. (Lisp_Intfwd, Lisp_Boolfwd, Lisp_Objfwd, Lisp_Buffer_Objfwd) (Lisp_Kboard_Objfwd): The type is in in Lisp_Fwd. (lispwfd): Is now a pointer to struct Lisp_Fwd. (SYMBOL_BLV, SET_SYMBOL_FWD, XFWDTYPE, BUFFER_OBJFWDP): Update accordingly. (defvar_lisp, defvar_lisp_nopro, defvar_bool, defvar_int) (defvar_kboard): These all take now a Lisp_Fwd. (DEFVAR_LISP, DEFVAR_LISP_NOPRO, DEFVAR_BOOL, DEFVAR_INT) (DEFVAR_KBOARD): Update for new types. * src/lread.c (defvar_int, defvar_bool, defvar_lisp_nopro) (defvar_lisp, defvar_kboard): Update for new types. * src/pdumper.c (dump_field_fwd, dump_blv): Update accordingly. (dump_fwd_int, dump_fwd_bool, dump_fwd_obj, dump_fwd_buffer_obj) (dump_fwd): Deleted. * src/buffer.c (DEFVAR_PER_BUFFER, defvar_per_buffer, buffer_local_value) (set_buffer_internal_1): Update accordingly for new types. * src/data.c (XBOOLFWD, XKBOARD_OBJFWD, XFIXNUMFWD, XOBJFWD, boundp) (store_symval_forwarding, swap_in_global_binding) (swap_in_symval_forwarding, find_symbol_value, set_internal) (default_value, set_default_internal, make_blv, Fmake_local_variable): Update accordingly. --- src/buffer.c | 17 +++++----- src/data.c | 39 ++++++++++----------- src/lisp.h | 94 ++++++++++++++++++++++++++++----------------------- src/lread.c | 17 ++++++---- src/pdumper.c | 91 +++---------------------------------------------- 5 files changed, 96 insertions(+), 162 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index 70ae2ba3d7b..9abce241897 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1379,7 +1379,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer) result = assq_no_quit (variable, BVAR (buf, local_var_alist)); if (!NILP (result)) { - if (blv->fwd.fwdptr) + if (blv->fwd) { /* What binding is loaded right now? */ Lisp_Object current_alist_element = blv->valcell; @@ -2380,7 +2380,7 @@ void set_buffer_internal_2 (register struct buffer *b) Lisp_Object var = XCAR (XCAR (tail)); struct Lisp_Symbol *sym = XSYMBOL (var); if (sym->u.s.redirect == SYMBOL_LOCALIZED /* Just to be sure. */ - && SYMBOL_BLV (sym)->fwd.fwdptr) + && SYMBOL_BLV (sym)->fwd) /* Just reference the variable to cause it to become set for this buffer. */ Fsymbol_value (var); @@ -4986,24 +4986,25 @@ do \ { \ const Lisp_Object sym = TAG_PTR_INITIALLY ( \ Lisp_Symbol, (intptr_t)((i##predicate_) * sizeof *lispsym)); \ - static const struct Lisp_Buffer_Objfwd bo_fwd = { \ + static const struct Lisp_Fwd bo_fwd = { \ .type = Lisp_Fwd_Buffer_Obj, \ - .offset = offsetof (struct buffer, vname##_), \ - .predicate = sym, \ + .u.bufobjfwd = { .offset = offsetof (struct buffer, vname##_), \ + .predicate = sym }, \ }; \ defvar_per_buffer (&bo_fwd, lname); \ } \ while (0) static void -defvar_per_buffer (const struct Lisp_Buffer_Objfwd *bo_fwd, - const char *namestring) +defvar_per_buffer (const struct Lisp_Fwd *fwd, const char *namestring) { + eassert (fwd->type == Lisp_Fwd_Buffer_Obj); + const struct Lisp_Buffer_Objfwd *bo_fwd = XBUFFER_OBJFWD (fwd); struct Lisp_Symbol *sym = XSYMBOL (intern (namestring)); sym->u.s.declared_special = true; sym->u.s.redirect = SYMBOL_FORWARDED; - SET_SYMBOL_FWD (sym, bo_fwd); + SET_SYMBOL_FWD (sym, fwd); XSETSYMBOL (PER_BUFFER_SYMBOL (bo_fwd->offset), sym); if (PER_BUFFER_IDX (bo_fwd->offset) == 0) diff --git a/src/data.c b/src/data.c index 903aac07538..952c686a466 100644 --- a/src/data.c +++ b/src/data.c @@ -57,25 +57,25 @@ static struct Lisp_Boolfwd const * XBOOLFWD (lispfwd a) { eassert (BOOLFWDP (a)); - return a.fwdptr; + return &a->u.boolfwd; } static struct Lisp_Kboard_Objfwd const * XKBOARD_OBJFWD (lispfwd a) { eassert (KBOARD_OBJFWDP (a)); - return a.fwdptr; + return &a->u.kboardobjfwd; } static struct Lisp_Intfwd const * XFIXNUMFWD (lispfwd a) { eassert (INTFWDP (a)); - return a.fwdptr; + return &a->u.intfwd; } static struct Lisp_Objfwd const * XOBJFWD (lispfwd a) { eassert (OBJFWDP (a)); - return a.fwdptr; + return &a->u.objfwd; } static void @@ -731,7 +731,7 @@ global value outside of any lexical scope. */) case SYMBOL_LOCALIZED: { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); - if (blv->fwd.fwdptr) + if (blv->fwd) /* In set_internal, we un-forward vars when their value is set to Qunbound. */ return Qt; @@ -1457,8 +1457,9 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, case Lisp_Fwd_Buffer_Obj: { - int offset = XBUFFER_OBJFWD (valcontents)->offset; - Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate; + const struct Lisp_Buffer_Objfwd *fwd = XBUFFER_OBJFWD (valcontents); + int offset = fwd->offset; + Lisp_Object predicate = fwd->predicate; if (!NILP (newval) && !NILP (predicate)) { @@ -1516,12 +1517,12 @@ swap_in_global_binding (struct Lisp_Symbol *symbol) struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol); /* Unload the previously loaded binding. */ - if (blv->fwd.fwdptr) + if (blv->fwd) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Select the global binding in the symbol. */ set_blv_valcell (blv, blv->defcell); - if (blv->fwd.fwdptr) + if (blv->fwd) store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL); /* Indicate that the global binding is set up now. */ @@ -1551,7 +1552,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ /* Unload the previously loaded binding. */ tem1 = blv->valcell; - if (blv->fwd.fwdptr) + if (blv->fwd) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Choose the new binding. */ { @@ -1565,7 +1566,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ /* Load the new binding. */ set_blv_valcell (blv, tem1); - if (blv->fwd.fwdptr) + if (blv->fwd) store_symval_forwarding (blv->fwd, blv_value (blv), NULL); } } @@ -1598,7 +1599,7 @@ find_symbol_value (Lisp_Object symbol) { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); swap_in_symval_forwarding (sym, blv); - return (blv->fwd.fwdptr + return (blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv)); } @@ -1688,7 +1689,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); - if (unbinding_p && blv->fwd.fwdptr) + if (unbinding_p && blv->fwd) /* Forbid unbinding built-in variables. */ error ("Built-in variables may not be unbound"); @@ -1707,7 +1708,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, We need to unload it, and choose a new binding. */ /* Write out `realvalue' to the old loaded binding. */ - if (blv->fwd.fwdptr) + if (blv->fwd) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Find the new binding. */ @@ -1755,7 +1756,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, /* Store the new value in the cons cell. */ set_blv_value (blv, newval); - if (blv->fwd.fwdptr) + if (blv->fwd) store_symval_forwarding (blv->fwd, newval, (BUFFERP (where) ? XBUFFER (where) : current_buffer)); @@ -1942,7 +1943,7 @@ default_value (Lisp_Object symbol) But the `realvalue' slot may be more up to date, since ordinary setq stores just that slot. So use that. */ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); - if (blv->fwd.fwdptr && BASE_EQ (blv->valcell, blv->defcell)) + if (blv->fwd && BASE_EQ (blv->valcell, blv->defcell)) return do_symval_forwarding (blv->fwd); else return XCDR (blv->defcell); @@ -2037,7 +2038,7 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, XSETCDR (blv->defcell, value); /* If the default binding is now loaded, set the REALVALUE slot too. */ - if (blv->fwd.fwdptr && BASE_EQ (blv->defcell, blv->valcell)) + if (blv->fwd && BASE_EQ (blv->defcell, blv->valcell)) store_symval_forwarding (blv->fwd, value, NULL); return; } @@ -2129,7 +2130,7 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded, if (forwarded) blv->fwd = valcontents.fwd; else - blv->fwd.fwdptr = NULL; + blv->fwd = NULL; set_blv_where (blv, Qnil); blv->local_if_set = 0; set_blv_defcell (blv, tem); @@ -2304,7 +2305,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) Otherwise, if C code modifies the variable before we load the binding in, then that new value would clobber the default binding the next time we unload it. See bug#34318. */ - if (blv->fwd.fwdptr) + if (blv->fwd) swap_in_symval_forwarding (sym, blv); } diff --git a/src/lisp.h b/src/lisp.h index 68d1226b2ee..6cb05141ea4 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -757,7 +757,7 @@ INLINE void union of the possible values (struct Lisp_Objfwd, struct Lisp_Intfwd, etc.). The pointer is packaged inside a struct to help static checking. */ -typedef struct { void const *fwdptr; } lispfwd; +typedef const struct Lisp_Fwd *lispfwd; /* Interned state of a symbol. */ @@ -2317,7 +2317,7 @@ SYMBOL_BLV (struct Lisp_Symbol *sym) INLINE lispfwd SYMBOL_FWD (struct Lisp_Symbol *sym) { - eassume (sym->u.s.redirect == SYMBOL_FORWARDED && sym->u.s.val.fwd.fwdptr); + eassume (sym->u.s.redirect == SYMBOL_FORWARDED && sym->u.s.val.fwd); return sym->u.s.val.fwd; } @@ -2341,10 +2341,10 @@ SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v) sym->u.s.val.blv = v; } INLINE void -SET_SYMBOL_FWD (struct Lisp_Symbol *sym, void const *v) +SET_SYMBOL_FWD (struct Lisp_Symbol *sym, lispfwd fwd) { - eassume (sym->u.s.redirect == SYMBOL_FORWARDED && v); - sym->u.s.val.fwd.fwdptr = v; + eassume (sym->u.s.redirect == SYMBOL_FORWARDED && fwd); + sym->u.s.val.fwd = fwd; } INLINE Lisp_Object @@ -3059,7 +3059,6 @@ make_uint (uintmax_t n) specified int variable. */ struct Lisp_Intfwd { - enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Int */ intmax_t *intvar; }; @@ -3069,7 +3068,6 @@ struct Lisp_Intfwd nil if it is false. */ struct Lisp_Boolfwd { - enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Bool */ bool *boolvar; }; @@ -3079,7 +3077,6 @@ struct Lisp_Boolfwd specified variable. */ struct Lisp_Objfwd { - enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Obj */ Lisp_Object *objvar; }; @@ -3087,7 +3084,6 @@ struct Lisp_Objfwd current buffer. Value is byte index of slot within buffer. */ struct Lisp_Buffer_Objfwd { - enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Buffer_Obj */ int offset; /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ Lisp_Object predicate; @@ -3140,15 +3136,26 @@ struct Lisp_Buffer_Local_Value current kboard. */ struct Lisp_Kboard_Objfwd { - enum Lisp_Fwd_Type type; /* = Lisp_Fwd_Kboard_Obj */ int offset; }; +struct Lisp_Fwd +{ + enum Lisp_Fwd_Type type; + union + { + struct Lisp_Intfwd intfwd; + struct Lisp_Boolfwd boolfwd; + struct Lisp_Objfwd objfwd; + struct Lisp_Buffer_Objfwd bufobjfwd; + struct Lisp_Kboard_Objfwd kboardobjfwd; + } u; +}; + INLINE enum Lisp_Fwd_Type XFWDTYPE (lispfwd a) { - enum Lisp_Fwd_Type const *p = a.fwdptr; - return *p; + return a->type; } INLINE bool @@ -3161,7 +3168,7 @@ INLINE struct Lisp_Buffer_Objfwd const * XBUFFER_OBJFWD (lispfwd a) { eassert (BUFFER_OBJFWDP (a)); - return a.fwdptr; + return &a->u.bufobjfwd; } INLINE bool @@ -3482,11 +3489,11 @@ call0 (Lisp_Object fn) return calln (fn); } -extern void defvar_lisp (struct Lisp_Objfwd const *, char const *); -extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *); -extern void defvar_bool (struct Lisp_Boolfwd const *, char const *); -extern void defvar_int (struct Lisp_Intfwd const *, char const *); -extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *); +extern void defvar_lisp (struct Lisp_Fwd const *, char const *); +extern void defvar_lisp_nopro (struct Lisp_Fwd const *, char const *); +extern void defvar_bool (struct Lisp_Fwd const *, char const *); +extern void defvar_int (struct Lisp_Fwd const *, char const *); +extern void defvar_kboard (struct Lisp_Fwd const *, char const *); /* Macros we use to define forwarded Lisp variables. These are used in the syms_of_FILENAME functions. @@ -3505,37 +3512,40 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *); All C code uses the `cons_cells_consed' name. This is all done this way to support indirection for multi-threaded Emacs. */ -#define DEFVAR_LISP(lname, vname, doc) \ - do { \ - static struct Lisp_Objfwd const o_fwd \ - = {Lisp_Fwd_Obj, &globals.f_##vname}; \ - defvar_lisp (&o_fwd, lname); \ +#define DEFVAR_LISP(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const o_fwd \ + = {Lisp_Fwd_Obj, .u.objfwd = {&globals.f_##vname}}; \ + defvar_lisp (&o_fwd, lname); \ } while (false) -#define DEFVAR_LISP_NOPRO(lname, vname, doc) \ - do { \ - static struct Lisp_Objfwd const o_fwd \ - = {Lisp_Fwd_Obj, &globals.f_##vname}; \ - defvar_lisp_nopro (&o_fwd, lname); \ +#define DEFVAR_LISP_NOPRO(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const o_fwd \ + = {Lisp_Fwd_Obj, .u.objfwd = {&globals.f_##vname}}; \ + defvar_lisp_nopro (&o_fwd, lname); \ } while (false) -#define DEFVAR_BOOL(lname, vname, doc) \ - do { \ - static struct Lisp_Boolfwd const b_fwd \ - = {Lisp_Fwd_Bool, &globals.f_##vname}; \ - defvar_bool (&b_fwd, lname); \ +#define DEFVAR_BOOL(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const b_fwd \ + = {Lisp_Fwd_Bool, .u.boolfwd = {&globals.f_##vname}}; \ + defvar_bool (&b_fwd, lname); \ } while (false) -#define DEFVAR_INT(lname, vname, doc) \ - do { \ - static struct Lisp_Intfwd const i_fwd \ - = {Lisp_Fwd_Int, &globals.f_##vname}; \ - defvar_int (&i_fwd, lname); \ +#define DEFVAR_INT(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const i_fwd \ + = {Lisp_Fwd_Int, .u.intfwd = {&globals.f_##vname}}; \ + defvar_int (&i_fwd, lname); \ } while (false) #define DEFVAR_KBOARD(lname, vname, doc) \ - do { \ - static struct Lisp_Kboard_Objfwd const ko_fwd \ - = {Lisp_Fwd_Kboard_Obj, offsetof (KBOARD, vname##_)}; \ +do \ + { \ + static struct Lisp_Fwd const ko_fwd \ + = { Lisp_Fwd_Kboard_Obj, \ + .u.kboardobjfwd = {offsetof (KBOARD, vname##_)}}; \ defvar_kboard (&ko_fwd, lname); \ - } while (false) + } \ +while (false) /* Elisp uses multiple stacks: diff --git a/src/lread.c b/src/lread.c index 85c0c107e53..f8c41bd80b8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -5241,8 +5241,9 @@ defsubr (union Aligned_Lisp_Subr *aname) C variable of type intmax_t. Sample call (with "xx" to fool make-docfile): DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */ void -defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring) +defvar_int (struct Lisp_Fwd const *i_fwd, char const *namestring) { + eassert (i_fwd->type == Lisp_Fwd_Int); Lisp_Object sym = intern_c_string (namestring); XBARE_SYMBOL (sym)->u.s.declared_special = true; XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; @@ -5251,8 +5252,9 @@ defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring) /* Similar but define a variable whose value is t if 1, nil if 0. */ void -defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring) +defvar_bool (struct Lisp_Fwd const *b_fwd, char const *namestring) { + eassert (b_fwd->type == Lisp_Fwd_Bool); Lisp_Object sym = intern_c_string (namestring); XBARE_SYMBOL (sym)->u.s.declared_special = true; XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; @@ -5266,8 +5268,9 @@ defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring) gc-marked for some other reason, since marking the same slot twice can cause trouble with strings. */ void -defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring) +defvar_lisp_nopro (struct Lisp_Fwd const *o_fwd, char const *namestring) { + eassert (o_fwd->type == Lisp_Fwd_Obj); Lisp_Object sym = intern_c_string (namestring); XBARE_SYMBOL (sym)->u.s.declared_special = true; XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; @@ -5275,18 +5278,20 @@ defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring) } void -defvar_lisp (struct Lisp_Objfwd const *o_fwd, char const *namestring) +defvar_lisp (struct Lisp_Fwd const *o_fwd, char const *namestring) { + eassert (o_fwd->type == Lisp_Fwd_Obj); defvar_lisp_nopro (o_fwd, namestring); - staticpro (o_fwd->objvar); + staticpro (o_fwd->u.objfwd.objvar); } /* Similar but define a variable whose value is the Lisp Object stored at a particular offset in the current kboard object. */ void -defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring) +defvar_kboard (struct Lisp_Fwd const *ko_fwd, char const *namestring) { + eassert (ko_fwd->type == Lisp_Fwd_Kboard_Obj); Lisp_Object sym = intern_c_string (namestring); XBARE_SYMBOL (sym)->u.s.declared_special = true; XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; diff --git a/src/pdumper.c b/src/pdumper.c index 03a985f89d1..45da1074006 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2300,89 +2300,6 @@ dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat) return dump_object_finish (ctx, &out, sizeof (out)); } -static void -dump_fwd_int (struct dump_context *ctx, const struct Lisp_Intfwd *intfwd) -{ -#if CHECK_STRUCTS && !defined HASH_Lisp_Intfwd_4D887A7387 -# error "Lisp_Intfwd changed. See CHECK_STRUCTS comment in config.h." -#endif - dump_emacs_reloc_immediate_intmax_t (ctx, intfwd->intvar, *intfwd->intvar); -} - -static void -dump_fwd_bool (struct dump_context *ctx, const struct Lisp_Boolfwd *boolfwd) -{ -#if CHECK_STRUCTS && !defined (HASH_Lisp_Boolfwd_0EA1C7ADCC) -# error "Lisp_Boolfwd changed. See CHECK_STRUCTS comment in config.h." -#endif - dump_emacs_reloc_immediate_bool (ctx, boolfwd->boolvar, *boolfwd->boolvar); -} - -static void -dump_fwd_obj (struct dump_context *ctx, const struct Lisp_Objfwd *objfwd) -{ -#if CHECK_STRUCTS && !defined (HASH_Lisp_Objfwd_45D3E513DC) -# error "Lisp_Objfwd changed. See CHECK_STRUCTS comment in config.h." -#endif - if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (objfwd->objvar)), - ctx->staticpro_table, - Qnil))) - dump_emacs_reloc_to_lv (ctx, objfwd->objvar, *objfwd->objvar); -} - -static void -dump_fwd_buffer_obj (struct dump_context *ctx, - const struct Lisp_Buffer_Objfwd *buffer_objfwd) -{ -#if CHECK_STRUCTS && !defined (HASH_Lisp_Buffer_Objfwd_611EBD13FF) -# error "Lisp_Buffer_Objfwd changed. See CHECK_STRUCTS comment in config.h." -#endif - struct Lisp_Buffer_Objfwd out; - dump_off off; - - dump_object_start (ctx, &out, sizeof (out)); - DUMP_FIELD_COPY (&out, buffer_objfwd, type); - DUMP_FIELD_COPY (&out, buffer_objfwd, offset); - dump_field_lv (ctx, &out, buffer_objfwd, &buffer_objfwd->predicate, - WEIGHT_NORMAL); - off = dump_object_finish (ctx, &out, sizeof out); - - /* Copy this fwd from the dump to the buffer fwd in Emacs. */ - dump_emacs_reloc_copy_from_dump (ctx, off, (void *) buffer_objfwd, - sizeof out); -} - -static void -dump_fwd (struct dump_context *ctx, lispfwd fwd) -{ -#if CHECK_STRUCTS && !defined (HASH_Lisp_Fwd_Type_9CBA6EE55E) -# error "Lisp_Fwd_Type changed. See CHECK_STRUCTS comment in config.h." -#endif - void const *p = fwd.fwdptr; - - switch (XFWDTYPE (fwd)) - { - case Lisp_Fwd_Int: - dump_fwd_int (ctx, p); - break; - case Lisp_Fwd_Bool: - dump_fwd_bool (ctx, p); - break; - case Lisp_Fwd_Obj: - dump_fwd_obj (ctx, p); - break; - case Lisp_Fwd_Buffer_Obj: - dump_fwd_buffer_obj (ctx, p); - break; - /* The default kboard's contents are not meant to appear in the - dump file. */ - case Lisp_Fwd_Kboard_Obj: - break; - default: - emacs_abort (); - } -} - static void dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, const lispfwd *in_field) @@ -2392,19 +2309,19 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, { case Lisp_Fwd_Int: { - const struct Lisp_Intfwd *fwd = in_field->fwdptr; + const struct Lisp_Intfwd *fwd = &(*in_field)->u.intfwd; dump_emacs_reloc_immediate_intmax_t (ctx, fwd->intvar, *fwd->intvar); } return; case Lisp_Fwd_Bool: { - const struct Lisp_Boolfwd *fwd = in_field->fwdptr; + const struct Lisp_Boolfwd *fwd = &(*in_field)->u.boolfwd; dump_emacs_reloc_immediate_bool (ctx, fwd->boolvar, *fwd->boolvar); } return; case Lisp_Fwd_Obj: { - const struct Lisp_Objfwd *fwd = in_field->fwdptr; + const struct Lisp_Objfwd *fwd = &(*in_field)->u.objfwd; if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (fwd->objvar)), ctx->staticpro_table, Qnil))) dump_emacs_reloc_to_lv (ctx, fwd->objvar, *fwd->objvar); @@ -2428,7 +2345,7 @@ dump_blv (struct dump_context *ctx, dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, blv, local_if_set); DUMP_FIELD_COPY (&out, blv, found); - if (blv->fwd.fwdptr) + if (blv->fwd) { eassert (XFWDTYPE (blv->fwd) != Lisp_Fwd_Buffer_Obj); dump_field_fwd (ctx, &out, blv, &blv->fwd); From 6d9ba8e7bf045155bdd6dfbf8126fe866fd3e3aa Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 11:25:35 +0200 Subject: [PATCH 175/191] Remove struct Lisp_Intfwd It was a struct with a single field. * src/lisp.h (struct Lisp_Intfwd): Deleted. (struct Lisp_Fwd): Add an intvar field instead. (DEFVAR_INT): Update accordingly. * src/data.c (XINTVAR): Updated and renamed from XFIXNUMFWD. (do_symval_forwarding, store_symval_forwarding): Use it. --- src/data.c | 10 +++++----- src/lisp.h | 22 ++++++---------------- src/pdumper.c | 4 ++-- 3 files changed, 13 insertions(+), 23 deletions(-) diff --git a/src/data.c b/src/data.c index 952c686a466..4334c8dabcb 100644 --- a/src/data.c +++ b/src/data.c @@ -65,11 +65,11 @@ XKBOARD_OBJFWD (lispfwd a) eassert (KBOARD_OBJFWDP (a)); return &a->u.kboardobjfwd; } -static struct Lisp_Intfwd const * -XFIXNUMFWD (lispfwd a) +static intmax_t * +XINTVAR (lispfwd a) { eassert (INTFWDP (a)); - return &a->u.intfwd; + return a->u.intvar; } static struct Lisp_Objfwd const * XOBJFWD (lispfwd a) @@ -1332,7 +1332,7 @@ do_symval_forwarding (lispfwd valcontents) switch (XFWDTYPE (valcontents)) { case Lisp_Fwd_Int: - return make_int (*XFIXNUMFWD (valcontents)->intvar); + return make_int (*XINTVAR (valcontents)); case Lisp_Fwd_Bool: return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil); @@ -1418,7 +1418,7 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, CHECK_INTEGER (newval); if (! integer_to_intmax (newval, &i)) xsignal1 (Qoverflow_error, newval); - *XFIXNUMFWD (valcontents)->intvar = i; + *XINTVAR (valcontents) = i; } break; diff --git a/src/lisp.h b/src/lisp.h index 6cb05141ea4..d35450df5fd 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3053,15 +3053,6 @@ make_uint (uintmax_t n) (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr)) -/* Forwarding pointer to an int variable. - This is allowed only in the value cell of a symbol, - and it means that the symbol's value really lives in the - specified int variable. */ -struct Lisp_Intfwd - { - intmax_t *intvar; - }; - /* Boolean forwarding pointer to an int variable. This is like Lisp_Intfwd except that the ostensible "value" of the symbol is t if the bool variable is true, @@ -3144,7 +3135,7 @@ struct Lisp_Fwd enum Lisp_Fwd_Type type; union { - struct Lisp_Intfwd intfwd; + intmax_t *intvar; struct Lisp_Boolfwd boolfwd; struct Lisp_Objfwd objfwd; struct Lisp_Buffer_Objfwd bufobjfwd; @@ -3530,13 +3521,12 @@ extern void defvar_kboard (struct Lisp_Fwd const *, char const *); = {Lisp_Fwd_Bool, .u.boolfwd = {&globals.f_##vname}}; \ defvar_bool (&b_fwd, lname); \ } while (false) -#define DEFVAR_INT(lname, vname, doc) \ - do { \ - static struct Lisp_Fwd const i_fwd \ - = {Lisp_Fwd_Int, .u.intfwd = {&globals.f_##vname}}; \ - defvar_int (&i_fwd, lname); \ +#define DEFVAR_INT(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const i_fwd \ + = {Lisp_Fwd_Int, .u.intvar = &globals.f_##vname}; \ + defvar_int (&i_fwd, lname); \ } while (false) - #define DEFVAR_KBOARD(lname, vname, doc) \ do \ { \ diff --git a/src/pdumper.c b/src/pdumper.c index 45da1074006..bd1e5655f81 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2309,8 +2309,8 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, { case Lisp_Fwd_Int: { - const struct Lisp_Intfwd *fwd = &(*in_field)->u.intfwd; - dump_emacs_reloc_immediate_intmax_t (ctx, fwd->intvar, *fwd->intvar); + const intmax_t *intvar = (*in_field)->u.intvar; + dump_emacs_reloc_immediate_intmax_t (ctx, intvar, *intvar); } return; case Lisp_Fwd_Bool: From 9d9189f74c5bd23b249833d70c4390cdbf16fc68 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 11:37:58 +0200 Subject: [PATCH 176/191] Remove struct Lisp_Boolfwd * src/lisp.h (struct Lisp Boolfwd): Deleted (struct Lisp_Fwd): Replaced it with a boolvar field. (DEFVAR_BOOL): Update. * src/data.c (XBOOLVAR): Renamed from XBOOLFWD. (do_symval_forwarding, store_symval_forwarding): Use it. * src/pdumper.c (dump_field_fwd): Use boolvar field. --- src/data.c | 10 +++++----- src/lisp.h | 13 ++----------- src/pdumper.c | 4 ++-- 3 files changed, 9 insertions(+), 18 deletions(-) diff --git a/src/data.c b/src/data.c index 4334c8dabcb..e33f4c92d35 100644 --- a/src/data.c +++ b/src/data.c @@ -53,11 +53,11 @@ OBJFWDP (lispfwd a) return XFWDTYPE (a) == Lisp_Fwd_Obj; } -static struct Lisp_Boolfwd const * -XBOOLFWD (lispfwd a) +static bool * +XBOOLVAR (lispfwd a) { eassert (BOOLFWDP (a)); - return &a->u.boolfwd; + return a->u.boolvar; } static struct Lisp_Kboard_Objfwd const * XKBOARD_OBJFWD (lispfwd a) @@ -1335,7 +1335,7 @@ do_symval_forwarding (lispfwd valcontents) return make_int (*XINTVAR (valcontents)); case Lisp_Fwd_Bool: - return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil); + return (*XBOOLVAR (valcontents) ? Qt : Qnil); case Lisp_Fwd_Obj: return *XOBJFWD (valcontents)->objvar; @@ -1423,7 +1423,7 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, break; case Lisp_Fwd_Bool: - *XBOOLFWD (valcontents)->boolvar = !NILP (newval); + *XBOOLVAR (valcontents) = !NILP (newval); break; case Lisp_Fwd_Obj: diff --git a/src/lisp.h b/src/lisp.h index d35450df5fd..24bd20d1562 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3053,15 +3053,6 @@ make_uint (uintmax_t n) (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr)) -/* Boolean forwarding pointer to an int variable. - This is like Lisp_Intfwd except that the ostensible - "value" of the symbol is t if the bool variable is true, - nil if it is false. */ -struct Lisp_Boolfwd - { - bool *boolvar; - }; - /* Forwarding pointer to a Lisp_Object variable. This is allowed only in the value cell of a symbol, and it means that the symbol's value really lives in the @@ -3136,7 +3127,7 @@ struct Lisp_Fwd union { intmax_t *intvar; - struct Lisp_Boolfwd boolfwd; + bool *boolvar; struct Lisp_Objfwd objfwd; struct Lisp_Buffer_Objfwd bufobjfwd; struct Lisp_Kboard_Objfwd kboardobjfwd; @@ -3518,7 +3509,7 @@ extern void defvar_kboard (struct Lisp_Fwd const *, char const *); #define DEFVAR_BOOL(lname, vname, doc) \ do { \ static struct Lisp_Fwd const b_fwd \ - = {Lisp_Fwd_Bool, .u.boolfwd = {&globals.f_##vname}}; \ + = {Lisp_Fwd_Bool, .u.boolvar = &globals.f_##vname}; \ defvar_bool (&b_fwd, lname); \ } while (false) #define DEFVAR_INT(lname, vname, doc) \ diff --git a/src/pdumper.c b/src/pdumper.c index bd1e5655f81..d23eaa82696 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2315,8 +2315,8 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, return; case Lisp_Fwd_Bool: { - const struct Lisp_Boolfwd *fwd = &(*in_field)->u.boolfwd; - dump_emacs_reloc_immediate_bool (ctx, fwd->boolvar, *fwd->boolvar); + const bool *boolvar = (*in_field)->u.boolvar; + dump_emacs_reloc_immediate_bool (ctx, boolvar, *boolvar); } return; case Lisp_Fwd_Obj: From d109bcf86e870d003b45930c82f8140e8ba415ac Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 15:34:55 +0200 Subject: [PATCH 177/191] Remove struct Lisp_Objfwd * src/lisp.h (struct Lisp_Objfwd): Deleted. (struct Lisp_Fwd): Replace it with objvar field. (DEFVAR_LISP, DEFVAR_LISP_NOPRO, DEFVAR_LISP_NOPROX): Use the field. * src/lread.c (defvar_lisp): Updated as needed. * src/pdumper.c (dump_field_fwd): Use the field. * src/data.c (XOBJVAR): Renamed and updated from XOBJFWD. (do_symval_forwarding, store_symval_forwarding): Use it. --- src/data.c | 16 ++++++++-------- src/lisp.h | 25 ++++++++----------------- src/lread.c | 2 +- src/pdumper.c | 6 +++--- 4 files changed, 20 insertions(+), 29 deletions(-) diff --git a/src/data.c b/src/data.c index e33f4c92d35..337d640b2b5 100644 --- a/src/data.c +++ b/src/data.c @@ -71,11 +71,11 @@ XINTVAR (lispfwd a) eassert (INTFWDP (a)); return a->u.intvar; } -static struct Lisp_Objfwd const * -XOBJFWD (lispfwd a) +static Lisp_Object * +XOBJVAR (lispfwd a) { eassert (OBJFWDP (a)); - return &a->u.objfwd; + return a->u.objvar; } static void @@ -1338,7 +1338,7 @@ do_symval_forwarding (lispfwd valcontents) return (*XBOOLVAR (valcontents) ? Qt : Qnil); case Lisp_Fwd_Obj: - return *XOBJFWD (valcontents)->objvar; + return *XOBJVAR (valcontents); case Lisp_Fwd_Buffer_Obj: return per_buffer_value (current_buffer, @@ -1427,16 +1427,16 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, break; case Lisp_Fwd_Obj: - *XOBJFWD (valcontents)->objvar = newval; + *XOBJVAR (valcontents) = newval; /* If this variable is a default for something stored in the buffer itself, such as default-fill-column, find the buffers that don't have local values for it and update them. */ - if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults - && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1)) + if (XOBJVAR (valcontents) > (Lisp_Object *) &buffer_defaults + && XOBJVAR (valcontents) < (Lisp_Object *) (&buffer_defaults + 1)) { - int offset = ((char *) XOBJFWD (valcontents)->objvar + int offset = ((char *) XOBJVAR (valcontents) - (char *) &buffer_defaults); int idx = PER_BUFFER_IDX (offset); diff --git a/src/lisp.h b/src/lisp.h index 24bd20d1562..40556527d3a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3053,15 +3053,6 @@ make_uint (uintmax_t n) (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr)) -/* Forwarding pointer to a Lisp_Object variable. - This is allowed only in the value cell of a symbol, - and it means that the symbol's value really lives in the - specified variable. */ -struct Lisp_Objfwd - { - Lisp_Object *objvar; - }; - /* Like Lisp_Objfwd except that value lives in a slot in the current buffer. Value is byte index of slot within buffer. */ struct Lisp_Buffer_Objfwd @@ -3128,7 +3119,7 @@ struct Lisp_Fwd { intmax_t *intvar; bool *boolvar; - struct Lisp_Objfwd objfwd; + Lisp_Object *objvar; struct Lisp_Buffer_Objfwd bufobjfwd; struct Lisp_Kboard_Objfwd kboardobjfwd; } u; @@ -3494,16 +3485,16 @@ extern void defvar_kboard (struct Lisp_Fwd const *, char const *); All C code uses the `cons_cells_consed' name. This is all done this way to support indirection for multi-threaded Emacs. */ -#define DEFVAR_LISP(lname, vname, doc) \ - do { \ - static struct Lisp_Fwd const o_fwd \ - = {Lisp_Fwd_Obj, .u.objfwd = {&globals.f_##vname}}; \ - defvar_lisp (&o_fwd, lname); \ +#define DEFVAR_LISP(lname, vname, doc) \ + do { \ + static struct Lisp_Fwd const o_fwd \ + = {Lisp_Fwd_Obj, .u.objvar = &globals.f_##vname}; \ + defvar_lisp (&o_fwd, lname); \ } while (false) #define DEFVAR_LISP_NOPRO(lname, vname, doc) \ do { \ - static struct Lisp_Fwd const o_fwd \ - = {Lisp_Fwd_Obj, .u.objfwd = {&globals.f_##vname}}; \ + static struct Lisp_Fwd const o_fwd \ + = {Lisp_Fwd_Obj, .u.objvar = &globals.f_##vname}; \ defvar_lisp_nopro (&o_fwd, lname); \ } while (false) #define DEFVAR_BOOL(lname, vname, doc) \ diff --git a/src/lread.c b/src/lread.c index f8c41bd80b8..9d91ac8909d 100644 --- a/src/lread.c +++ b/src/lread.c @@ -5282,7 +5282,7 @@ defvar_lisp (struct Lisp_Fwd const *o_fwd, char const *namestring) { eassert (o_fwd->type == Lisp_Fwd_Obj); defvar_lisp_nopro (o_fwd, namestring); - staticpro (o_fwd->u.objfwd.objvar); + staticpro (o_fwd->u.objvar); } /* Similar but define a variable whose value is the Lisp Object stored diff --git a/src/pdumper.c b/src/pdumper.c index d23eaa82696..c21af24d9f1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2321,10 +2321,10 @@ dump_field_fwd (struct dump_context *ctx, void *out, const void *in_start, return; case Lisp_Fwd_Obj: { - const struct Lisp_Objfwd *fwd = &(*in_field)->u.objfwd; - if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (fwd->objvar)), + const Lisp_Object *objvar = (*in_field)->u.objvar; + if (NILP (Fgethash (dump_off_to_lisp (emacs_offset (objvar)), ctx->staticpro_table, Qnil))) - dump_emacs_reloc_to_lv (ctx, fwd->objvar, *fwd->objvar); + dump_emacs_reloc_to_lv (ctx, objvar, *objvar); } return; case Lisp_Fwd_Kboard_Obj: From 163dd21e7305bbd91aecb87cb4968970d1e1e873 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 16:36:13 +0200 Subject: [PATCH 178/191] Remove struct Lisp_Kboard_Objfwd * src/lisp.h (struct Lisp_Kboard_Objfwd): Deleted ... (struct Lisp_Fwd): ... replaced with field kbdoffset. (DEFVAR_KBOARD): Use new field. * src/data.c (XKBOARD_OFFSET): Renamed from XKBOARD_OBJFWD. (do_symval_forwarding, store_symval_forwarding (set_default_internal): Use it . --- src/data.c | 12 ++++++------ src/lisp.h | 17 ++++------------- 2 files changed, 10 insertions(+), 19 deletions(-) diff --git a/src/data.c b/src/data.c index 337d640b2b5..6b46a771ba8 100644 --- a/src/data.c +++ b/src/data.c @@ -59,11 +59,11 @@ XBOOLVAR (lispfwd a) eassert (BOOLFWDP (a)); return a->u.boolvar; } -static struct Lisp_Kboard_Objfwd const * -XKBOARD_OBJFWD (lispfwd a) +static int +XKBOARD_OFFSET (lispfwd a) { eassert (KBOARD_OBJFWDP (a)); - return &a->u.kboardobjfwd; + return a->u.kbdoffset; } static intmax_t * XINTVAR (lispfwd a) @@ -1345,7 +1345,7 @@ do_symval_forwarding (lispfwd valcontents) XBUFFER_OBJFWD (valcontents)->offset); case Lisp_Fwd_Kboard_Obj: - return *(Lisp_Object *) (XKBOARD_OBJFWD (valcontents)->offset + return *(Lisp_Object *) (XKBOARD_OFFSET (valcontents) + (char *) kboard_for_bindings ()); default: emacs_abort (); } @@ -1496,7 +1496,7 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, case Lisp_Fwd_Kboard_Obj: { char *base = (char *) kboard_for_bindings (); - char *p = base + XKBOARD_OBJFWD (valcontents)->offset; + char *p = base + XKBOARD_OFFSET (valcontents); *(Lisp_Object *) p = newval; } break; @@ -2081,7 +2081,7 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, { char *base = (char *) (where ? where : kboard_for_bindings ()); - char *p = base + XKBOARD_OBJFWD (valcontents)->offset; + char *p = base + XKBOARD_OFFSET (valcontents); *(Lisp_Object *) p = value; } else diff --git a/src/lisp.h b/src/lisp.h index 40556527d3a..bf446256774 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3105,13 +3105,6 @@ struct Lisp_Buffer_Local_Value Lisp_Object valcell; }; -/* Like Lisp_Objfwd except that value lives in a slot in the - current kboard. */ -struct Lisp_Kboard_Objfwd - { - int offset; - }; - struct Lisp_Fwd { enum Lisp_Fwd_Type type; @@ -3121,7 +3114,7 @@ struct Lisp_Fwd bool *boolvar; Lisp_Object *objvar; struct Lisp_Buffer_Objfwd bufobjfwd; - struct Lisp_Kboard_Objfwd kboardobjfwd; + int kbdoffset; } u; }; @@ -3510,14 +3503,12 @@ extern void defvar_kboard (struct Lisp_Fwd const *, char const *); defvar_int (&i_fwd, lname); \ } while (false) #define DEFVAR_KBOARD(lname, vname, doc) \ -do \ - { \ + do { \ static struct Lisp_Fwd const ko_fwd \ = { Lisp_Fwd_Kboard_Obj, \ - .u.kboardobjfwd = {offsetof (KBOARD, vname##_)}}; \ + .u.kbdoffset = offsetof (KBOARD, vname##_)}; \ defvar_kboard (&ko_fwd, lname); \ - } \ -while (false) + } while (false) /* Elisp uses multiple stacks: From 3442fdd2a2d9702bf9ed856b9bf0a0b1d0992747 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 17:25:21 +0200 Subject: [PATCH 179/191] Remove struct Lisp_Buffer_Objfwd * src/lisp.h (struct Lisp_Buffer_Objfwd): Deleted. (struct Lisp_Fwd): Add the fields bufoffset and bufpredicate. Make the type a 1-byte bitfield so that the entire struct still fits in two words. (XBUFFER_OFFSET): Renamed from XBUFFER_OBJFWD. * src/buffer.c (DEFVAR_PER_BUFFER, defvar_per_buffer) (buffer_local_value): Update accordingly. * src/data.c (do_symval_forwarding, store_symval_forwarding) (set_internal, default_value, set_default_internal) (Fmake_local_variable, Fkill_local_variable, Flocal_variable_): Use XBUFFER_OFFSET. --- src/buffer.c | 29 ++++++++++++++--------------- src/data.c | 19 +++++++++---------- src/lisp.h | 30 ++++++++++++++++-------------- 3 files changed, 39 insertions(+), 39 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index 9abce241897..cc559ad0ad6 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1402,7 +1402,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer) { lispfwd fwd = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (fwd)) - result = per_buffer_value (buf, XBUFFER_OBJFWD (fwd)->offset); + result = per_buffer_value (buf, XBUFFER_OFFSET (fwd)); else result = Fdefault_value (variable); break; @@ -4982,32 +4982,31 @@ init_buffer (void) /* FIXME: use LISPSYM_INITIALLY instead of TAG_PTR_INITIALLY */ #define DEFVAR_PER_BUFFER(lname, vname, predicate_, doc) \ -do \ - { \ - const Lisp_Object sym = TAG_PTR_INITIALLY ( \ - Lisp_Symbol, (intptr_t)((i##predicate_) * sizeof *lispsym)); \ - static const struct Lisp_Fwd bo_fwd = { \ - .type = Lisp_Fwd_Buffer_Obj, \ - .u.bufobjfwd = { .offset = offsetof (struct buffer, vname##_), \ - .predicate = sym }, \ - }; \ + do { \ + const Lisp_Object sym \ + = TAG_PTR_INITIALLY (Lisp_Symbol, (intptr_t)((i##predicate_) \ + * sizeof *lispsym)); \ + static const struct Lisp_Fwd bo_fwd \ + = { .type = Lisp_Fwd_Buffer_Obj, \ + .bufoffset = offsetof (struct buffer, vname##_), \ + .u.bufpredicate = sym }; \ + static_assert (offsetof (struct buffer, vname##_) \ + < (1 << 8 * sizeof bo_fwd.bufoffset)); \ defvar_per_buffer (&bo_fwd, lname); \ - } \ -while (0) + } while (0) static void defvar_per_buffer (const struct Lisp_Fwd *fwd, const char *namestring) { eassert (fwd->type == Lisp_Fwd_Buffer_Obj); - const struct Lisp_Buffer_Objfwd *bo_fwd = XBUFFER_OBJFWD (fwd); struct Lisp_Symbol *sym = XSYMBOL (intern (namestring)); sym->u.s.declared_special = true; sym->u.s.redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (sym, fwd); - XSETSYMBOL (PER_BUFFER_SYMBOL (bo_fwd->offset), sym); + XSETSYMBOL (PER_BUFFER_SYMBOL (XBUFFER_OFFSET (fwd)), sym); - if (PER_BUFFER_IDX (bo_fwd->offset) == 0) + if (PER_BUFFER_IDX (XBUFFER_OFFSET (fwd)) == 0) /* Did a DEFVAR_PER_BUFFER without initializing the corresponding slot of buffer_local_flags. */ emacs_abort (); diff --git a/src/data.c b/src/data.c index 6b46a771ba8..5eda4f2f599 100644 --- a/src/data.c +++ b/src/data.c @@ -1342,7 +1342,7 @@ do_symval_forwarding (lispfwd valcontents) case Lisp_Fwd_Buffer_Obj: return per_buffer_value (current_buffer, - XBUFFER_OBJFWD (valcontents)->offset); + XBUFFER_OFFSET (valcontents)); case Lisp_Fwd_Kboard_Obj: return *(Lisp_Object *) (XKBOARD_OFFSET (valcontents) @@ -1457,9 +1457,8 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, case Lisp_Fwd_Buffer_Obj: { - const struct Lisp_Buffer_Objfwd *fwd = XBUFFER_OBJFWD (valcontents); - int offset = fwd->offset; - Lisp_Object predicate = fwd->predicate; + int offset = XBUFFER_OFFSET (valcontents); + Lisp_Object predicate = valcontents->u.bufpredicate; if (!NILP (newval) && !NILP (predicate)) { @@ -1774,7 +1773,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, if (BUFFER_OBJFWDP (innercontents)) { - int offset = XBUFFER_OBJFWD (innercontents)->offset; + int offset = XBUFFER_OFFSET (innercontents); int idx = PER_BUFFER_IDX (offset); if (idx > 0 && bindflag == SET_INTERNAL_SET && !PER_BUFFER_VALUE_P (buf, idx)) @@ -1956,7 +1955,7 @@ default_value (Lisp_Object symbol) rather than letting do_symval_forwarding get the current value. */ if (BUFFER_OBJFWDP (valcontents)) { - int offset = XBUFFER_OBJFWD (valcontents)->offset; + int offset = XBUFFER_OFFSET (valcontents); if (PER_BUFFER_IDX (offset) != 0) return per_buffer_default (offset); } @@ -2051,7 +2050,7 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, Make them work apparently like Lisp_Buffer_Local_Value variables. */ if (BUFFER_OBJFWDP (valcontents)) { - int offset = XBUFFER_OBJFWD (valcontents)->offset; + int offset = XBUFFER_OFFSET (valcontents); int idx = PER_BUFFER_IDX (offset); set_per_buffer_default (offset, value); @@ -2263,7 +2262,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) { if (forwarded && BUFFER_OBJFWDP (valcontents.fwd)) { - int offset = XBUFFER_OBJFWD (valcontents.fwd)->offset; + int offset = XBUFFER_OFFSET (valcontents.fwd); int idx = PER_BUFFER_IDX (offset); eassert (idx); if (idx > 0) @@ -2335,7 +2334,7 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) lispfwd valcontents = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (valcontents)) { - int offset = XBUFFER_OBJFWD (valcontents)->offset; + int offset = XBUFFER_OFFSET (valcontents); int idx = PER_BUFFER_IDX (offset); if (idx > 0) @@ -2416,7 +2415,7 @@ Also see `buffer-local-boundp'.*/) lispfwd valcontents = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (valcontents)) { - int offset = XBUFFER_OBJFWD (valcontents)->offset; + int offset = XBUFFER_OFFSET (valcontents); int idx = PER_BUFFER_IDX (offset); if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) return Qt; diff --git a/src/lisp.h b/src/lisp.h index bf446256774..8a8f27b0271 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3053,15 +3053,6 @@ make_uint (uintmax_t n) (EXPR_SIGNED (expr) ? make_int (expr) : make_uint (expr)) -/* Like Lisp_Objfwd except that value lives in a slot in the - current buffer. Value is byte index of slot within buffer. */ -struct Lisp_Buffer_Objfwd - { - int offset; - /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp. */ - Lisp_Object predicate; - }; - /* struct Lisp_Buffer_Local_Value is used in a symbol value cell when the symbol has buffer-local bindings. (Exception: some buffer-local variables are built-in, with their values stored @@ -3105,15 +3096,26 @@ struct Lisp_Buffer_Local_Value Lisp_Object valcell; }; +/* A struct Lisp_Fwd is used to locate a variable. See Lisp_Fwd_Type + for the various types of variables. + + Lisp_Fwd structs are created by macros like DEFVAR_INT, DEFVAR_BOOL etc. + and are always kept in static variables. They are never allocated + dynamically. */ + struct Lisp_Fwd { - enum Lisp_Fwd_Type type; + enum Lisp_Fwd_Type type : 8; + uint16_t bufoffset; /* used if type == Lisp_Fwd_Buffer_Obj */ union { intmax_t *intvar; bool *boolvar; Lisp_Object *objvar; - struct Lisp_Buffer_Objfwd bufobjfwd; + /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp, Qnumberp, + Qfraction, Qvertical_scroll_bar, or Qoverwrite_mode. + */ + Lisp_Object bufpredicate; int kbdoffset; } u; }; @@ -3130,11 +3132,11 @@ BUFFER_OBJFWDP (lispfwd a) return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj; } -INLINE struct Lisp_Buffer_Objfwd const * -XBUFFER_OBJFWD (lispfwd a) +INLINE int +XBUFFER_OFFSET (lispfwd a) { eassert (BUFFER_OBJFWDP (a)); - return &a->u.bufobjfwd; + return a->bufoffset; } INLINE bool From 9008e6a9d7f041875c2fe9f58d5b5b44e84f649f Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Sun, 23 Jun 2024 21:46:16 +0200 Subject: [PATCH 180/191] Introduce an enum Lisp_Fwd_Predicate Using an enum instead of a symbol makes it obvious that this field is of no concern to the GC. * src/lisp.h (enum Lisp_Fwd_Predicate): New. (struct Lisp_Fwd): Use it instead of a symbol. * src/buffer.c (DEFVAR_PER_BUFFER): Create the necessary enum constant instead of a symbol. * src/data.c (check_fwd_predicate, check_choice): New helpers. (store_symval_forwarding): Use it. --- src/buffer.c | 22 ++++++-------- src/data.c | 83 ++++++++++++++++++++++++++++++++++------------------ src/lisp.h | 17 ++++++++--- 3 files changed, 77 insertions(+), 45 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index cc559ad0ad6..afc2f0f4d89 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -4980,19 +4980,15 @@ init_buffer (void) that nil is allowed too). DOC is a dummy where you write the doc string as a comment. */ -/* FIXME: use LISPSYM_INITIALLY instead of TAG_PTR_INITIALLY */ -#define DEFVAR_PER_BUFFER(lname, vname, predicate_, doc) \ - do { \ - const Lisp_Object sym \ - = TAG_PTR_INITIALLY (Lisp_Symbol, (intptr_t)((i##predicate_) \ - * sizeof *lispsym)); \ - static const struct Lisp_Fwd bo_fwd \ - = { .type = Lisp_Fwd_Buffer_Obj, \ - .bufoffset = offsetof (struct buffer, vname##_), \ - .u.bufpredicate = sym }; \ - static_assert (offsetof (struct buffer, vname##_) \ - < (1 << 8 * sizeof bo_fwd.bufoffset)); \ - defvar_per_buffer (&bo_fwd, lname); \ +#define DEFVAR_PER_BUFFER(lname, vname, predicate, doc) \ + do { \ + static const struct Lisp_Fwd bo_fwd \ + = { .type = Lisp_Fwd_Buffer_Obj, \ + .bufoffset = offsetof (struct buffer, vname##_), \ + .u.bufpredicate = FWDPRED_##predicate }; \ + static_assert (offsetof (struct buffer, vname##_) \ + < (1 << 8 * sizeof bo_fwd.bufoffset)); \ + defvar_per_buffer (&bo_fwd, lname); \ } while (0) static void diff --git a/src/data.c b/src/data.c index 5eda4f2f599..e86bc378471 100644 --- a/src/data.c +++ b/src/data.c @@ -1398,6 +1398,59 @@ wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong) wrong); } +static void +check_choice (Lisp_Object choice, Lisp_Object val) +{ + eassert (CONSP (choice)); + if (NILP (Fmemq (val, choice))) + wrong_choice (choice, val); +} + +static void +check_fwd_predicate (enum Lisp_Fwd_Predicate p, Lisp_Object val) +{ + switch (p) + { + case FWDPRED_Qnil: + return; + case FWDPRED_Qstringp: + if (!STRINGP (val)) + wrong_type_argument (Qstringp, val); + return; + case FWDPRED_Qsymbolp: + if (!SYMBOLP (val)) + wrong_type_argument (Qsymbolp, val); + return; + case FWDPRED_Qintegerp: + if (!INTEGERP (val)) + wrong_type_argument (Qintegerp, val); + return; + case FWDPRED_Qnumberp: + if (!NUMBERP (val)) + wrong_type_argument (Qnumberp, val); + return; + case FWDPRED_Qfraction: + { + if (!NUMBERP (val)) + wrong_type_argument (Qnumberp, val); + Lisp_Object range = Fget (Qfraction, Qrange); + eassert (CONSP (range)); + Lisp_Object min = XCAR (range); + Lisp_Object max = XCDR (range); + if (NILP (CALLN (Fleq, min, val, max))) + wrong_range (min, max, val); + } + return; + case FWDPRED_Qvertical_scroll_bar: + check_choice (Fget (Qvertical_scroll_bar, Qchoice), val); + return; + case FWDPRED_Qoverwrite_mode: + check_choice (Fget (Qoverwrite_mode, Qchoice), val); + return; + } + emacs_abort (); +} + /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the buffer-independent contents of the value cell: forwarded just one @@ -1458,34 +1511,8 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, case Lisp_Fwd_Buffer_Obj: { int offset = XBUFFER_OFFSET (valcontents); - Lisp_Object predicate = valcontents->u.bufpredicate; - - if (!NILP (newval) && !NILP (predicate)) - { - eassert (SYMBOLP (predicate)); - Lisp_Object choiceprop = Fget (predicate, Qchoice); - if (!NILP (choiceprop)) - { - if (NILP (Fmemq (newval, choiceprop))) - wrong_choice (choiceprop, newval); - } - else - { - Lisp_Object rangeprop = Fget (predicate, Qrange); - if (CONSP (rangeprop)) - { - Lisp_Object min = XCAR (rangeprop), max = XCDR (rangeprop); - if (! NUMBERP (newval) - || NILP (CALLN (Fleq, min, newval, max))) - wrong_range (min, max, newval); - } - else if (FUNCTIONP (predicate)) - { - if (NILP (calln (predicate, newval))) - wrong_type_argument (predicate, newval); - } - } - } + if (!NILP (newval)) + check_fwd_predicate (valcontents->u.bufpredicate, newval); if (buf == NULL) buf = current_buffer; set_per_buffer_value (buf, offset, newval); diff --git a/src/lisp.h b/src/lisp.h index 8a8f27b0271..2d813282bc6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3096,6 +3096,18 @@ struct Lisp_Buffer_Local_Value Lisp_Object valcell; }; +enum Lisp_Fwd_Predicate +{ + FWDPRED_Qnil, + FWDPRED_Qintegerp, + FWDPRED_Qsymbolp, + FWDPRED_Qstringp, + FWDPRED_Qnumberp, + FWDPRED_Qfraction, + FWDPRED_Qvertical_scroll_bar, + FWDPRED_Qoverwrite_mode, +}; + /* A struct Lisp_Fwd is used to locate a variable. See Lisp_Fwd_Type for the various types of variables. @@ -3112,10 +3124,7 @@ struct Lisp_Fwd intmax_t *intvar; bool *boolvar; Lisp_Object *objvar; - /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp, Qnumberp, - Qfraction, Qvertical_scroll_bar, or Qoverwrite_mode. - */ - Lisp_Object bufpredicate; + enum Lisp_Fwd_Predicate bufpredicate; int kbdoffset; } u; }; From 40f696757c2afe15a583945992955429b00de563 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Mon, 24 Jun 2024 10:06:54 +0200 Subject: [PATCH 181/191] Move the Lisp_Fwd.bufoffset field back to the union * src/lisp.h (struct Lisp_Fwd): With the predicate enum, we can now pack the offset and the predicate into a one-word struct. (XBUFFER_OFFSET): Use the new field name. * src/buffer.c (DEFVAR_PER_BUFFER): Create the one-word struct. * src/data.c (store_symval_forwarding): Use the new field name. --- src/buffer.c | 15 +++++++++------ src/data.c | 2 +- src/lisp.h | 9 ++++++--- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index afc2f0f4d89..b1a835b7ac5 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -4980,14 +4980,17 @@ init_buffer (void) that nil is allowed too). DOC is a dummy where you write the doc string as a comment. */ -#define DEFVAR_PER_BUFFER(lname, vname, predicate, doc) \ +#define DEFVAR_PER_BUFFER(lname, vname, predicate_, doc) \ do { \ - static const struct Lisp_Fwd bo_fwd \ - = { .type = Lisp_Fwd_Buffer_Obj, \ - .bufoffset = offsetof (struct buffer, vname##_), \ - .u.bufpredicate = FWDPRED_##predicate }; \ + static const struct Lisp_Fwd bo_fwd = { \ + .type = Lisp_Fwd_Buffer_Obj, \ + .u.buf = { \ + .offset = offsetof (struct buffer, vname##_), \ + .predicate = FWDPRED_##predicate_ \ + } \ + }; \ static_assert (offsetof (struct buffer, vname##_) \ - < (1 << 8 * sizeof bo_fwd.bufoffset)); \ + < (1 << 8 * sizeof bo_fwd.u.buf.offset)); \ defvar_per_buffer (&bo_fwd, lname); \ } while (0) diff --git a/src/data.c b/src/data.c index e86bc378471..da8ca42e565 100644 --- a/src/data.c +++ b/src/data.c @@ -1512,7 +1512,7 @@ store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, { int offset = XBUFFER_OFFSET (valcontents); if (!NILP (newval)) - check_fwd_predicate (valcontents->u.bufpredicate, newval); + check_fwd_predicate (valcontents->u.buf.predicate, newval); if (buf == NULL) buf = current_buffer; set_per_buffer_value (buf, offset, newval); diff --git a/src/lisp.h b/src/lisp.h index 2d813282bc6..f1ab29ef2f2 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3118,13 +3118,16 @@ enum Lisp_Fwd_Predicate struct Lisp_Fwd { enum Lisp_Fwd_Type type : 8; - uint16_t bufoffset; /* used if type == Lisp_Fwd_Buffer_Obj */ union { intmax_t *intvar; bool *boolvar; Lisp_Object *objvar; - enum Lisp_Fwd_Predicate bufpredicate; + struct + { + uint16_t offset; + enum Lisp_Fwd_Predicate predicate : 8; + } buf; int kbdoffset; } u; }; @@ -3145,7 +3148,7 @@ INLINE int XBUFFER_OFFSET (lispfwd a) { eassert (BUFFER_OBJFWDP (a)); - return a->bufoffset; + return a->u.buf.offset; } INLINE bool From 737ad9080b40aafd9a38afa078eaf19a5bb7fbae Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Thu, 12 Feb 2026 18:40:44 +0100 Subject: [PATCH 182/191] Add tests for per-buffer variables with predicates * test/src/data-tests.el (data-tests-per-buffer-var-predicates): New. --- test/src/data-tests.el | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 0540a99f4c3..2fc971d0214 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -951,4 +951,38 @@ comparing the subr with a much slower Lisp implementation." (should-error (aset s 3 #x3fff80))) ; new char not ASCII ) +(ert-deftest data-tests-per-buffer-var-predicates () + (with-temp-buffer + ;; per buffer variable without predicate + (progn + (setq line-spacing 2.3) + (should (= line-spacing 2.3)) + (setq line-spacing "2.3") + (should (equal line-spacing "2.3")) + (setq line-spacing nil) + (should (equal line-spacing nil))) + ;; per buffer variable with 'fraction predicate + (progn + (dolist (v '(nil 0.7)) + (setq scroll-up-aggressively v) + (should (equal scroll-up-aggressively v))) + (should-error (setq scroll-up-aggressively 'abc) + :type 'wrong-type-argument) + (should-error (setq scroll-up-aggressively 2.7)) + (should (equal scroll-up-aggressively 0.7))) + ;; per buffer variable with 'vertical-scroll-bar predicate + (progn + (dolist (v (get 'vertical-scroll-bar 'choice)) + (setq vertical-scroll-bar v) + (should (equal vertical-scroll-bar v))) + (should-error (setq vertical-scroll-bar 'foo)) + (should (equal vertical-scroll-bar 'right))) + ;; per buffer variable with 'overwrite-mode predicate + (progn + (dolist (v (get 'overwrite-mode 'choice)) + (setq overwrite-mode v) + (should (equal overwrite-mode v))) + (should-error (setq overwrite-mode 'foo)) + (should (equal overwrite-mode 'overwrite-mode-binary))))) + ;;; data-tests.el ends here From eece2377dd2e2113f97b27d4ca43f718e6e3e2a7 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Thu, 12 Feb 2026 18:42:05 +0100 Subject: [PATCH 183/191] * src/lisp.h (struct Lisp_Fwd): Add comments. --- src/lisp.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lisp.h b/src/lisp.h index f1ab29ef2f2..6d2fd4b83f2 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3120,15 +3120,15 @@ struct Lisp_Fwd enum Lisp_Fwd_Type type : 8; union { - intmax_t *intvar; - bool *boolvar; - Lisp_Object *objvar; + intmax_t *intvar; /* when type == Lisp_Fwd_Int */ + bool *boolvar; /* when type == Lisp_Fwd_Bool */ + Lisp_Object *objvar; /* when type == Lisp_Fwd_Obj */ struct { uint16_t offset; enum Lisp_Fwd_Predicate predicate : 8; - } buf; - int kbdoffset; + } buf; /* when type == Lisp_Fwd_Buffer_Obj */ + int kbdoffset; /* when type == Lisp_Fwd_Kboard_Obj */ } u; }; From 0a1238ad28bbeeb90057de648168fc1004b3e7e9 Mon Sep 17 00:00:00 2001 From: Morgan Smith Date: Tue, 20 Jan 2026 20:45:02 -0500 Subject: [PATCH 184/191] battery.el: Update on "DisplayDevice" state change * lisp/battery.el (battery--upower-props-changed): Check if the "State" has changed. (battery--upower-subscribe): Subscribe to state changes of the "DisplayDevice" (bug#80229). --- lisp/battery.el | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/lisp/battery.el b/lisp/battery.el index 05f9c5ecadb..3db94920a96 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -782,7 +782,8 @@ See URL `https://upower.freedesktop.org/docs/Device.html'.") (defun battery--upower-props-changed (_interface changed _invalidated) "Update status when system starts/stops running on battery. Intended as a UPower PropertiesChanged signal handler." - (when (assoc "OnBattery" changed) + (when (or (assoc "OnBattery" changed) + (assoc "State" changed)) (battery--upower-signal-handler))) (defun battery--upower-unsubscribe () @@ -792,12 +793,22 @@ Intended as a UPower PropertiesChanged signal handler." (defun battery--upower-subscribe () "Subscribe to UPower device change signals." + ;; Listen for OnBattery signals (push (dbus-register-signal :system battery-upower-service battery-upower-path dbus-interface-properties "PropertiesChanged" #'battery--upower-props-changed) battery--upower-signals) + ;; Listen for state changes of DisplayDevice + (push (dbus-register-signal :system battery-upower-service + (concat + battery-upower-device-path + "/DisplayDevice") + dbus-interface-properties + "PropertiesChanged" + #'battery--upower-props-changed) + battery--upower-signals) (dolist (method '("DeviceAdded" "DeviceRemoved")) (push (dbus-register-signal :system battery-upower-service battery-upower-path From 0a02ab6db8d0451b0595520ee0814cc4a841a8d6 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 6 Feb 2026 14:55:10 +0100 Subject: [PATCH 185/191] Allow disabling battery-update-timer Now that battery--upower-subscribe registers to signals from DisplayDevice (bug#80229), it is possible to react to more than just State changes, including Percentage and IsPresent (although the latter may already be covered by the DeviceAdded and DeviceRemoved signals). That means that it should be possible to disable polling via battery-update-timer and still get timely mode line updates. * etc/NEWS (Changes in Specialized Modes and Packages in Emacs 31.1): Announce new battery-update-interval :type. * lisp/battery.el (battery-update-interval): Allow setting to nil. (display-battery-mode): Do not create battery-update-timer then. (battery-upower-display-device-path): New constant. (battery--upower-subscribe): Use it. (battery-upower-subscribe-properties): New variable. (battery--upower-props-changed): Use it for more flexibility over which DisplayDevice properties to react to. (battery--upower-signal-handler): Call battery-update-handler directly when there is no battery-update-timer. --- etc/NEWS | 11 +++++++++++ lisp/battery.el | 50 ++++++++++++++++++++++++++++++++++++------------- 2 files changed, 48 insertions(+), 13 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 076a4e2c15e..3e5bc88fbbe 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3545,6 +3545,17 @@ value. Previously, only 'hi-lock-face-buffer' supported this. *** 'shadow-info-buffer' and 'shadow-todo-buffer' use ephemeral buffer names now. +** Display Battery mode + +--- +*** UPower battery status can update automatically without polling. +On systems where the user option 'battery-status-function' is set to +'battery-upower', it is now possible to get battery status updates on +the mode line without polling for changes every +'battery-update-interval' seconds. Setting this user option to nil +means the mode line will update only when the battery power state, +percentage, or presence in the bay changes. + * New Modes and Packages in Emacs 31.1 diff --git a/lisp/battery.el b/lisp/battery.el index 3db94920a96..aa0c0b81b62 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -207,8 +207,14 @@ The full `format-spec' formatting syntax is supported." :type '(choice string (const nil))) (defcustom battery-update-interval 60 - "Seconds after which the battery status will be updated." - :type 'integer) + "Seconds after which the battery status will be updated. +A value of nil means do not poll for battery status changes. +This can be useful when `battery-status-function' is set to +`battery-upower' and `battery-upower-subscribe' is non-nil, in +which case D-Bus automatically signals battery status changes." + :version "31.1" + :type '(choice (const :tag "Never" nil) + (integer :tag "Number of seconds"))) (defcustom battery-load-low 25 "Upper bound of low battery load percentage. @@ -305,8 +311,9 @@ trigger actions based on battery-related events." (and (eq battery-status-function #'battery-upower) battery-upower-subscribe (battery--upower-subscribe)) - (setq battery-update-timer (run-at-time nil battery-update-interval - #'battery-update-handler)) + (when battery-update-interval + (setq battery-update-timer (run-at-time nil battery-update-interval + #'battery-update-handler))) (battery-update)) (message "Battery status not available") (setq display-battery-mode nil))) @@ -772,18 +779,37 @@ See URL `https://upower.freedesktop.org/docs/Device.html'.") (defconst battery-upower-device-path "/org/freedesktop/UPower/devices" "D-Bus object providing `battery-upower-device-interface'.") +(defconst battery-upower-display-device-path + "/org/freedesktop/UPower/devices/DisplayDevice" + "D-Bus object providing a subset of `battery-upower-device-interface'. +This is a composite device for displaying a digest of overall state. +In particular, it is not listed by the EnumerateDevices method.") + +(defvar battery-upower-subscribe-properties + '(;; `battery-upower-path' properties. + "OnBattery" + ;; `battery-upower-display-device-path' properties. + "State" "Percentage" "IsPresent") + "List of UPower device properties to listen for. +Each value is a string property of `battery-upower-path' +or `battery-upower-display-device-path'. +A D-Bus signal that any of them changed results in a `battery-update'.") + (defvar battery--upower-signals nil "Handles for UPower signal subscriptions.") (defun battery--upower-signal-handler (&rest _) "Update battery status on receiving a UPower D-Bus signal." - (timer-event-handler battery-update-timer)) + (if battery-update-timer + (timer-event-handler battery-update-timer) + (battery-update-handler))) (defun battery--upower-props-changed (_interface changed _invalidated) - "Update status when system starts/stops running on battery. + "Update status when UPower device properties change. +Respond only to those in `battery-upower-subscribe-properties'. Intended as a UPower PropertiesChanged signal handler." - (when (or (assoc "OnBattery" changed) - (assoc "State" changed)) + (when (any (lambda (prop) (assoc prop changed)) + battery-upower-subscribe-properties) (battery--upower-signal-handler))) (defun battery--upower-unsubscribe () @@ -793,18 +819,16 @@ Intended as a UPower PropertiesChanged signal handler." (defun battery--upower-subscribe () "Subscribe to UPower device change signals." - ;; Listen for OnBattery signals + ;; Listen for OnBattery changes. (push (dbus-register-signal :system battery-upower-service battery-upower-path dbus-interface-properties "PropertiesChanged" #'battery--upower-props-changed) battery--upower-signals) - ;; Listen for state changes of DisplayDevice + ;; Listen for DisplayDevice property changes. (push (dbus-register-signal :system battery-upower-service - (concat - battery-upower-device-path - "/DisplayDevice") + battery-upower-display-device-path dbus-interface-properties "PropertiesChanged" #'battery--upower-props-changed) From aa9acfacf0aa04f7339b4fbdaf1138b65192903c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 25 Jan 2026 11:21:02 +0100 Subject: [PATCH 186/191] Check that a UPower battery device IsPresent The composite DisplayDevice is meant to be presented to the user only if it IsPresent. It is not entirely clear whether PowerSupply implies IsPresent, so check both (bug#80229). * lisp/battery.el (battery-upower): Skip hot-removable batteries that are missing from the bay. --- lisp/battery.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/battery.el b/lisp/battery.el index aa0c0b81b62..ee3e24b196c 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -914,8 +914,10 @@ The following %-sequences are provided: ((and (eq type 1) (not (eq line-status 'online))) ;; It's a line power device: `online' if currently providing ;; power, any other non-nil value if simply present. - (setq line-status (if (cdr (assoc "Online" props)) 'online t))) - ((and (eq type 2) (cdr (assoc "IsPresent" props))) + (setq line-status (or (not (cdr (assoc "Online" props))) 'online))) + ((and (eq type 2) + (cdr (assoc "PowerSupply" props)) + (cdr (assoc "IsPresent" props))) ;; It's a battery. (setq count (1+ count)) (setq state (battery--upower-state props state)) From 80a52e118dba6ccf63fc4e8d9ee2a84db8ed3a3a Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 6 Feb 2026 17:22:22 +0100 Subject: [PATCH 187/191] ; List my areas of interest in maintaining. --- admin/MAINTAINERS | 5 +++++ etc/tutorials/TUTORIAL.translators | 1 + 2 files changed, 6 insertions(+) diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index dd339f9af80..41bc780d1cc 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -405,6 +405,11 @@ Spencer Baugh Yuan Fu lisp/progmodes/c-ts-mode.el +Basil L. Contovounesios + lisp/battery.el (UPower support) + lisp/json.el + src/image.c (WebP support) + ============================================================================== 3. Externally maintained packages. ============================================================================== diff --git a/etc/tutorials/TUTORIAL.translators b/etc/tutorials/TUTORIAL.translators index 2b1444b13b8..bbae2809f2e 100644 --- a/etc/tutorials/TUTORIAL.translators +++ b/etc/tutorials/TUTORIAL.translators @@ -31,6 +31,7 @@ Maintainer: Rafael SepĂșlveda * TUTORIAL.el_GR: Author: Protesilaos Stavrou Maintainer: Protesilaos Stavrou + Basil L. Contovounesios * TUTORIAL.fa: Author: Mohsen BANAN From e0e0e95f5be6beb4e0a528e95ac466751b2f6a31 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 12 Feb 2026 19:24:10 +0100 Subject: [PATCH 188/191] Tramp signals 'remote-file-error' consequently * doc/misc/tramp.texi (External packages): Mention also special events. Emphasise, that Tramp raises remote-file-error. * etc/NEWS: Tramp signals 'remote-file-error' consequently. Presentational fixes and improvements. * lisp/net/tramp.el (tramp-skeleton-process-file) (tramp-handle-make-symbolic-link, tramp-process-actions) (tramp-wait-for-regexp, tramp-send-string): * lisp/net/tramp-adb.el (tramp-adb-get-device) (tramp-adb-send-command-and-check, tramp-adb-barf-unless-okay) (tramp-adb-wait-for-output, tramp-adb-maybe-open-connection): * lisp/net/tramp-archive.el (tramp-archive-handle-not-implemented): * lisp/net/tramp-crypt.el (tramp-crypt-do-encrypt-or-decrypt-file-name) (tramp-crypt-do-encrypt-or-decrypt-file): * lisp/net/tramp-gvfs.el (tramp-gvfs-dbus-event-error) (tramp-gvfs-maybe-open-connection): * lisp/net/tramp-sh.el (tramp-do-directory-files-and-attributes-with-perl) (tramp-do-copy-or-rename-file-directly) (tramp-do-copy-or-rename-file-out-of-band) (tramp-sh-handle-file-local-copy, tramp-sh-handle-write-region) (tramp-bundle-read-file-names, tramp-maybe-send-script) (tramp-find-file-exists-command, tramp-barf-if-no-shell-prompt) (tramp-maybe-open-connection, tramp-wait-for-output) (tramp-send-command-and-check, tramp-barf-unless-okay) (tramp-send-command-and-read, tramp-get-ls-command): * lisp/net/tramp-smb.el (tramp-smb-handle-file-attributes) (tramp-smb-handle-make-symbolic-link) (tramp-smb-maybe-open-connection, tramp-smb-call-winexe): * lisp/net/tramp-sshfs.el (tramp-sshfs-maybe-open-connection): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-send-command-and-read): Raise a `remote-file-error' in case of connection problems. * lisp/net/tramp-rclone.el (tramp-rclone-maybe-open-connection): Improve check for host. * lisp/net/tramp-smb.el (tramp-smb-get-localname): Improve error message. * lisp/net/tramp-sudoedit.el (tramp-default-host-alist): Set a default for "sudoedit" method. (tramp-sudoedit-maybe-open-connection): Check for proper host name. (tramp-sudoedit-send-command): Do not expand ?h. * lisp/net/tramp.el (tramp-compute-multi-hops): Check for cycle proxy definition. * test/lisp/net/tramp-archive-tests.el (tramp-archive-test20-file-modes) (tramp-archive-test21-file-links): Check for `rmote-file-error'. * test/lisp/net/tramp-tests.el (tramp-file-name-with-sudo): Declare. (tramp--test-ignore-make-symbolic-link-error): Check for `rmote-file-error'. (tramp-test03-file-name-method-rules): Delete. (tramp-test03-file-error): New test. (tramp--test-supports-processes-p): Make it more rebust. --- doc/misc/tramp.texi | 10 +++- etc/NEWS | 14 ++++- lisp/net/tramp-adb.el | 23 ++++---- lisp/net/tramp-archive.el | 2 +- lisp/net/tramp-crypt.el | 4 +- lisp/net/tramp-gvfs.el | 10 ++-- lisp/net/tramp-rclone.el | 84 ++++++++++++++-------------- lisp/net/tramp-sh.el | 53 ++++++++++-------- lisp/net/tramp-smb.el | 20 ++++--- lisp/net/tramp-sshfs.el | 2 +- lisp/net/tramp-sudoedit.el | 11 +++- lisp/net/tramp.el | 19 ++++--- test/lisp/net/tramp-archive-tests.el | 6 +- test/lisp/net/tramp-tests.el | 52 ++++++++++------- 14 files changed, 181 insertions(+), 129 deletions(-) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index c916588a060..73c3e1ed326 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -6658,7 +6658,7 @@ root directory, it is most likely sufficient to make the @code{default-directory} of the process buffer as the root directory. -@subsection Timers, process filters, process sentinels, redisplay +@subsection Timers, process filters, process sentinels, special events, redisplay @vindex remote-file-error Timers run asynchronously at any time when Emacs is waiting for @@ -6678,7 +6678,13 @@ wrapping the timer function body as follows: @end lisp A similar problem could happen with process filters, process -sentinels, and redisplay (updating the mode line). +sentinels, special event handlers, and redisplay (updating the mode +line). + +@strong{Note} that @value{tramp} raises a @code{remote-file-error} +error for any connection-related problem. You can protect against all +such problems with the code snippet above (or with a +@code{condition-case} form with a @code{remote-file-error} handler). @node Extension packages diff --git a/etc/NEWS b/etc/NEWS index 076a4e2c15e..02185050e12 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -62,7 +62,7 @@ You can keep the old behavior by putting '(xterm-mouse-mode -1)' in your init file. +++ -** 'site-start.el' is now loaded before the user's early init file. +** site-start.el is now loaded before the user's early init file. Previously, the order was early-init.el, site-start.el and then the user's regular init file, but now site-start.el comes first. This allows site administrators to customize things that can normally only be @@ -2182,6 +2182,12 @@ To unconditionally enable 'flyspell-mode' from a hook, use this instead: ** Tramp ++++ +*** Tramp signals 'remote-file-error' in case of connection problems. +This is a subcategory of 'file-error'. Therefore, all checks for +'file-error' in 'condition-case', 'ignore-error', 'error-conditions' and +alike still work. + +++ *** New command 'tramp-cleanup-bufferless-connections'. Connection-related objects for which no associated buffers exist, except @@ -3352,7 +3358,7 @@ changing the marking state in the calendar buffer. A new library has been added to the calendar for handling iCalendar (RFC5545) data. The library is designed for reuse in other parts of Emacs and in third-party packages. Package authors can find the new -library in the Emacs distribution under lisp/calendar/icalendar-*.el. +library in the Emacs distribution under "lisp/calendar/icalendar-*.el". Most of the functions and variables in the older icalendar.el have been marked obsolete and now suggest appropriate replacements from the new @@ -3605,7 +3611,7 @@ This package provides platform-neutral interfaces to block your system from entering idle sleep and a hook to process pre-sleep and post-wake events. You can use this to avoid the system entering an idle sleep state and interrupting a long-running process due to lack of user -activity. The sleep event hook lets you, for example close external +activity. The sleep event hook lets you, for example, close external connections or serial ports before sleeping, and reestablish them when the system wakes up. @@ -3615,6 +3621,7 @@ blocking requires org.freedesktop.Screensaver service), macOS (sleep/display blocking requires version 10.9 or later, sleep events are supported on all versions), MS-Windows (sleep blocking is supported on all versions, sleep events require Windows 8 or later). + * Incompatible Lisp Changes in Emacs 31.1 @@ -3788,6 +3795,7 @@ When no tags file is loaded, symbol completion just won't provide any suggestions. So the 'M-?' command now works without a tags table. And the 'M-.' will show a message describing the several built-in options that will provide an Xref backend when used. + * Lisp Changes in Emacs 31.1 diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5bcb92536fd..c20b5df9b59 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -974,7 +974,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (sleep-for 0.1) host) (t (tramp-error - vec 'file-error "Could not find device %s" host))))))) + vec 'remote-file-error "Could not find device %s" host))))))) (defun tramp-adb-execute-adb-command (vec &rest args) "Execute an adb command. @@ -1047,7 +1047,7 @@ the exit status." (with-current-buffer (tramp-get-connection-buffer vec) (unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit))) (tramp-error - vec 'file-error "Couldn't find exit status of `%s'" command)) + vec 'remote-file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 (if exit-status @@ -1060,13 +1060,14 @@ the exit status." "Run COMMAND, check exit status, throw error if exit status not okay. FMT and ARGS are passed to `error'." (unless (tramp-adb-send-command-and-check vec command) - (apply #'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'remote-file-error fmt args))) (defun tramp-adb-wait-for-output (proc &optional timeout) "Wait for output from remote command." (unless (buffer-live-p (process-buffer proc)) (delete-process proc) - (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) + (tramp-error + proc 'remote-file-error "Process `%s' not available, try again" proc)) (let ((prompt (tramp-get-connection-property proc "prompt" tramp-adb-prompt))) (with-current-buffer (process-buffer proc) (if (tramp-wait-for-regexp proc timeout prompt) @@ -1085,10 +1086,11 @@ FMT and ARGS are passed to `error'." (delete-region (point) (point-max)))) (if timeout (tramp-error - proc 'file-error + proc 'remote-file-error "[[Remote prompt `%s' not found in %d secs]]" prompt timeout) (tramp-error - proc 'file-error "[[Remote prompt `%s' not found]]" prompt)))))) + proc 'remote-file-error + "[[Remote prompt `%s' not found]]" prompt)))))) (defun tramp-adb-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1110,13 +1112,14 @@ connection if a previous connection has died for some reason." ;; whether it is still the same device. (when (and user (not (tramp-get-connection-property vec " su-command-p" t))) - (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) + (tramp-error vec 'remote-file-error "Cannot switch to user `%s'" user)) (unless (process-live-p p) (save-match-data (when (and p (processp p)) (delete-process p)) (if (tramp-string-empty-or-nil-p device) - (tramp-error vec 'file-error "Device %s not connected" host)) + (tramp-error + vec 'remote-file-error "Device %s not connected" host)) (with-tramp-progress-reporter vec 3 "Opening adb shell connection" (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? (process-connection-type tramp-process-connection-type) @@ -1137,7 +1140,7 @@ connection if a previous connection has died for some reason." (tramp-send-string vec tramp-rsh-end-of-line) (tramp-adb-wait-for-output p 30) (unless (process-live-p p) - (tramp-error vec 'file-error "Terminated!")) + (tramp-error vec 'remote-file-error "Terminated!")) ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1193,7 +1196,7 @@ connection if a previous connection has died for some reason." ;; Do not flush, we need the nil value. (tramp-set-connection-property vec " su-command-p" nil) (tramp-error - vec 'file-error "Cannot switch to user `%s'" user))) + vec 'remote-file-error "Cannot switch to user `%s'" user))) ;; Mark it as connected. (tramp-set-connection-property p "connected" t)))))))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index a4323156c2a..e970fd1cd56 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -737,7 +737,7 @@ offered." (apply #'tramp-archive-file-name-for-operation operation args))))) (tramp-message v 10 "%s" (cons operation args)) (tramp-error - v 'file-error + v 'remote-file-error "Operation `%s' not implemented for file archives" operation))) (add-hook 'tramp-unload-hook diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 565b9f0a5aa..59e4cea2edb 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -446,7 +446,7 @@ Otherwise, return NAME." crypt-vec (if (eq op 'encrypt) "encode" "decode") tramp-compat-temporary-file-directory localname) (tramp-error - crypt-vec 'file-error "%s of file name %s failed" + crypt-vec 'remote-file-error "%s of file name %s failed" (if (eq op 'encrypt) "Encoding" "Decoding") name)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (goto-char (point-min)) @@ -481,7 +481,7 @@ Raise an error if this fails." (file-name-directory infile) (concat "/" (file-name-nondirectory infile))) (tramp-error - crypt-vec 'file-error "%s of file %s failed" + crypt-vec 'remote-file-error "%s of file %s failed" (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) (with-current-buffer (tramp-get-connection-buffer crypt-vec) (write-region nil nil outfile))))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 64efce227d6..0f68e4d768a 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1006,7 +1006,7 @@ The global value will always be nil; it is bound where needed.") "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) - (tramp-error tramp-gvfs-dbus-event-vector 'file-error (cadr err)))) + (tramp-error tramp-gvfs-dbus-event-vector 'remote-file-error (cadr err)))) (add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) (add-hook 'tramp-gvfs-unload-hook @@ -2234,7 +2234,7 @@ connection if a previous connection has died for some reason." method) tramp-gvfs-mounttypes) (tramp-error - vec 'file-error "Method `%s' not supported by GVFS" method))) + vec 'remote-file-error "Method `%s' not supported by GVFS" method))) ;; For password handling, we need a process bound to the ;; connection buffer. Therefore, we create a dummy process. @@ -2332,10 +2332,10 @@ connection if a previous connection has died for some reason." vec 'tramp-connection-timeout tramp-connection-timeout) (if (tramp-string-empty-or-nil-p user-domain) (tramp-error - vec 'file-error + vec 'remote-file-error "Timeout reached mounting %s using %s" host-port method) (tramp-error - vec 'file-error + vec 'remote-file-error "Timeout reached mounting %s@%s using %s" user-domain host-port method))) (while (not (tramp-get-file-property vec "/" "fuse-mountpoint")) @@ -2345,7 +2345,7 @@ connection if a previous connection has died for some reason." ;; is marked with the fuse-mountpoint "/". We shall react. (when (string-equal (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") - (tramp-error vec 'file-error "FUSE mount denied")) + (tramp-error vec 'remote-file-error "FUSE mount denied")) ;; Save the password. (ignore-errors diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 6b0daeba2ac..cd5c3f46f54 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -381,53 +381,53 @@ connection if a previous connection has died for some reason." (with-tramp-debug-message vec "Opening connection" (let ((host (tramp-file-name-host vec))) - (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) - (if (tramp-string-empty-or-nil-p host) - (tramp-error vec 'file-error "Storage %s not connected" host)) - ;; We need a process bound to the connection buffer. - ;; Therefore, we create a dummy process. Maybe there is a - ;; better solution? - (unless (get-buffer-process (tramp-get-connection-buffer vec)) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec) + (when (or (tramp-string-empty-or-nil-p host) + (not (rassoc `(,host) (tramp-rclone-parse-device-names nil)))) + (tramp-error vec 'remote-file-error "Storage %s not connected" host)) - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec))) + ;; We need a process bound to the connection buffer. Therefore, + ;; we create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec) - ;; Create directory. - (unless (file-directory-p (tramp-fuse-mount-point vec)) - (make-directory (tramp-fuse-mount-point vec) 'parents)) + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) - ;; Mount. This command does not return, so we use 0 as - ;; DESTINATION of `tramp-call-process'. - (unless (tramp-fuse-mounted-p vec) - (apply - #'tramp-call-process - vec tramp-rclone-program nil 0 nil - "mount" (tramp-fuse-mount-spec vec) - (tramp-fuse-mount-point vec) - (tramp-get-method-parameter vec 'tramp-mount-args)) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) - (tramp-cleanup-connection vec 'keep-debug 'keep-password)) - (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))) + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) - ;; Mark it as connected. - (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t))) + ;; Mount. This command does not return, so we use 0 as + ;; DESTINATION of `tramp-call-process'. + (unless (tramp-fuse-mounted-p vec) + (apply + #'tramp-call-process + vec tramp-rclone-program nil 0 nil + "mount" (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-get-method-parameter vec 'tramp-mount-args)) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) + (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))) - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (with-tramp-connection-property - vec "uid-integer" (tramp-get-local-uid 'integer)) - (with-tramp-connection-property - vec "gid-integer" (tramp-get-local-gid 'integer)) - (with-tramp-connection-property - vec "uid-string" (tramp-get-local-uid 'string)) - (with-tramp-connection-property - vec "gid-string" (tramp-get-local-gid 'string)))) + ;; Mark it as connected. + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) (defun tramp-rclone-send-command (vec &rest args) "Send a command to connection VEC. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 97b72ba00ad..13e886b2c13 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1969,7 +1969,7 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-send-command-and-read vec (format "tramp_perl_directory_files_and_attributes %s" (tramp-shell-quote-argument localname))))) - (when (stringp object) (tramp-error vec 'file-error object)) + (when (stringp object) (tramp-error vec 'remote-file-error object)) object)) ;; FIXME: Fix function to work with count parameter. @@ -2378,7 +2378,7 @@ the uid and gid from FILENAME." ((eq op 'copy) "cp -f") ((eq op 'rename) "mv -f") (t (tramp-error - v 'file-error + v 'remote-file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) (localname1 (tramp-file-local-name filename)) @@ -2608,7 +2608,7 @@ The method used must be an out-of-band method." ;; Check for local copy program. (unless (executable-find copy-program) (tramp-error - v 'file-error "Cannot find local copy program: %s" copy-program)) + v 'remote-file-error "Cannot find local copy program: %s" copy-program)) ;; Install listener on the remote side. The prompt must be ;; consumed later on, when the process does not listen anymore. @@ -2618,7 +2618,7 @@ The method used must be an out-of-band method." (tramp-find-executable v remote-copy-program (tramp-get-remote-path v))) (tramp-error - v 'file-error + v 'remote-file-error "Cannot find remote listener: %s" remote-copy-program)) (setq remote-copy-program (string-join @@ -2629,7 +2629,7 @@ The method used must be an out-of-band method." (tramp-send-command v remote-copy-program) (with-timeout (60 (tramp-error - v 'file-error + v 'remote-file-error "Listener process not running on remote host: `%s'" remote-copy-program)) (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) @@ -3468,7 +3468,8 @@ will be used." ;; Oops, I don't know what to do. (t (tramp-error - v 'file-error "Wrong method specification for `%s'" method))) + v 'remote-file-error + "Wrong method specification for `%s'" method))) ;; Error handling. ((error quit) @@ -3663,7 +3664,7 @@ will be used." ;; That's not expected. (t (tramp-error - v 'file-error + v 'remote-file-error (concat "Method `%s' should specify both encoding and " "decoding command or an scp program") method))))))))) @@ -3689,7 +3690,7 @@ are \"file-exists-p\", \"file-readable-p\", \"file-directory-p\" and tramp-end-of-heredoc (mapconcat #'tramp-shell-quote-argument files "\n") tramp-end-of-heredoc)) - (tramp-error vec 'file-error "%s" (tramp-get-buffer-string))) + (tramp-error vec 'remote-file-error "%s" (tramp-get-buffer-string))) ;; Read the expression. (goto-char (point-min)) (read (current-buffer)))) @@ -4165,7 +4166,7 @@ Only send the definition if it has not already been done." ;; Expand format specifiers. (unless (setq script (tramp-expand-script vec script)) (tramp-error - vec 'file-error + vec 'remote-file-error (format "Script %s is not applicable on remote host" name))) ;; Send it. (tramp-barf-unless-okay @@ -4325,13 +4326,15 @@ file exists and nonzero exit status otherwise." ;; We cannot use `tramp-get-ls-command', this results in an infloop. ;; (Bug#65321) (ignore-errors - (and (setq result (format "ls -d >%s" (tramp-get-remote-null-device vec))) + (and (setq + result + (format "ls -d >%s" (tramp-get-remote-null-device vec))) (tramp-send-command-and-check vec (format "%s %s" result existing)) (not (tramp-send-command-and-check vec (format "%s %s" result nonexistent)))))) (tramp-error - vec 'file-error "Couldn't find command to check if file exists")) + vec 'remote-file-error "Couldn't find command to check if file exists")) (tramp-set-file-property vec existing "file-exists-p" t) result)) @@ -4484,7 +4487,8 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." (error (delete-process proc) (apply #'tramp-error-with-buffer - (tramp-get-connection-buffer vec) vec 'file-error error-args))))) + (tramp-get-connection-buffer vec) vec + 'remote-file-error error-args))))) (defvar tramp-config-check nil "A function to be called with one argument, VEC. @@ -5293,8 +5297,8 @@ connection if a previous connection has died for some reason." (unless (and (process-live-p p) (tramp-wait-for-output p 10)) ;; The error will be caught locally. - (tramp-error vec 'file-error "Awake did fail"))) - (file-error + (tramp-error vec 'remote-file-error "Awake did fail"))) + (remote-file-error (tramp-cleanup-connection vec t) (setq p nil))) @@ -5314,7 +5318,8 @@ connection if a previous connection has died for some reason." (setenv "HISTFILESIZE" "0") (setenv "HISTSIZE" "0")))) (unless (stringp tramp-encoding-shell) - (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) + (tramp-error + vec 'remote-file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) (previous-hop tramp-null-hop) @@ -5520,7 +5525,8 @@ function waits for output unless NOOUTPUT is set." "Wait for output from remote command." (unless (buffer-live-p (process-buffer proc)) (delete-process proc) - (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) + (tramp-error + proc 'remote-file-error "Process `%s' not available, try again" proc)) (with-current-buffer (process-buffer proc) (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might ;; be leading ANSI control escape sequences, which must be @@ -5551,11 +5557,11 @@ function waits for output unless NOOUTPUT is set." (delete-region (point) (point-max)))) (if timeout (tramp-error - proc 'file-error + proc 'remote-file-error "[[Remote prompt `%s' not found in %d secs]]" tramp-end-of-output timeout) (tramp-error - proc 'file-error + proc 'remote-file-error "[[Remote prompt `%s' not found]]" tramp-end-of-output))) ;; Return value is whether end-of-output sentinel was found. found))) @@ -5594,7 +5600,7 @@ the exit status." (with-current-buffer (tramp-get-connection-buffer vec) (unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit))) (tramp-error - vec 'file-error "Couldn't find exit status of `%s'" command)) + vec 'remote-file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 (if exit-status @@ -5608,7 +5614,7 @@ the exit status." Similar to `tramp-send-command-and-check' but accepts two more arguments FMT and ARGS which are passed to `error'." (or (tramp-send-command-and-check vec command) - (apply #'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'remote-file-error fmt args))) (defun tramp-send-command-and-read (vec command &optional noerror marker) "Run COMMAND and return the output, which must be a Lisp expression. @@ -5627,7 +5633,7 @@ raises an error." (search-forward-regexp marker) (error (unless noerror (tramp-error - vec 'file-error + vec 'remote-file-error "`%s' does not return the marker `%s': `%s'" command marker (buffer-string)))))) ;; Read the expression. @@ -5641,7 +5647,7 @@ raises an error." (error nil))) (error (unless noerror (tramp-error - vec 'file-error + vec 'remote-file-error "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) @@ -5854,7 +5860,8 @@ Nonexistent directories are removed from spec." (setq result (concat result " --color=never"))) (throw 'ls-found result)) (setq dl (cdr dl)))))) - (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) + (tramp-error + vec 'remote-file-error "Couldn't find a proper `ls' command")))) (defun tramp-get-ls-command-with (vec option) "Return OPTION, if the remote `ls' command supports the OPTION option." diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index b87eee0fcce..554aa354c00 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -821,7 +821,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil (tramp-convert-file-attributes v localname id-format - (ignore-errors + (condition-case err (if (tramp-smb-get-stat-capability v) (tramp-smb-do-file-attributes-with-stat v) ;; Reading just the filename entry via "dir localname" is @@ -851,7 +851,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (nth 1 entry) ;8 mode nil ;9 gid weird inode ;10 inode number - device)))))))) ;11 file system number + device)))) ;11 file system number + (remote-file-error (signal (car err) (cdr err))) + (error))))) (defun tramp-smb-do-file-attributes-with-stat (vec) "Implement `file-attributes' for Tramp files using `stat' command." @@ -1382,7 +1384,7 @@ will be used." "Like `make-symbolic-link' for Tramp files." (let ((v (tramp-dissect-file-name (expand-file-name linkname)))) (unless (tramp-smb-get-cifs-capabilities v) - (tramp-error v 'file-error "make-symbolic-link not supported"))) + (tramp-error v 'remote-file-error "make-symbolic-link not supported"))) (tramp-skeleton-make-symbolic-link target linkname ok-if-already-exists (unless (tramp-smb-send-command @@ -1571,8 +1573,7 @@ will be used." (tramp-search-regexp (rx "tramp_exit_status " (+ digit))) (tramp-error v 'file-error - "Couldn't find exit status of `%s'" - tramp-smb-acl-program)) + "Couldn't find exit status of `%s'" tramp-smb-acl-program)) (skip-chars-forward "^ ") (when (zerop (read (current-buffer))) ;; Success. @@ -1705,7 +1706,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (when (string-match-p (rx blank eol) localname) (tramp-error vec 'file-error - "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) + "Invalid file name `%s'" (tramp-make-tramp-file-name vec localname))) localname))) @@ -1988,7 +1989,7 @@ If ARGUMENT is non-nil, use it as argument for (unless tramp-smb-version (unless (executable-find tramp-smb-program) (tramp-error - vec 'file-error + vec 'remote-file-error "Cannot find command %s in %s" tramp-smb-program exec-path)) (setq tramp-smb-version (shell-command-to-string command)) (tramp-message vec 6 command) @@ -2165,11 +2166,12 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; Check for program. (unless (executable-find tramp-smb-winexe-program) (tramp-error - vec 'file-error "Cannot find program: %s" tramp-smb-winexe-program)) + vec 'remote-file-error "Cannot find program: %s" tramp-smb-winexe-program)) ;; winexe does not supports ports. (when (tramp-file-name-port vec) - (tramp-error vec 'file-error "Port not supported for remote processes")) + (tramp-error + vec 'remote-file-error "Port not supported for remote processes")) ;; Check share. (unless (tramp-smb-get-share vec) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 338d128cc4e..2cb5b5b1ed1 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -359,7 +359,7 @@ connection if a previous connection has died for some reason." vec 'tramp-mount-args nil ?p (or (tramp-file-name-port vec) "")))))) (tramp-error - vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) + vec 'remote-file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) ;; Mark it as connected. (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index d3bb8b8478e..9511c899b2b 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -52,6 +52,10 @@ `(,(rx bos (literal tramp-sudoedit-method) eos) nil ,tramp-root-id-string)) + (add-to-list 'tramp-default-host-alist + `(,(rx bos (literal tramp-sudoedit-method) eos) + nil ,(system-name))) + (tramp-set-completion-function tramp-sudoedit-method tramp-completion-function-alist-su)) @@ -742,6 +746,10 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) + (unless (string-match-p tramp-local-host-regexp (tramp-file-name-host vec)) + (tramp-error + vec 'remote-file-error "%s is not a local host" (tramp-file-name-host vec))) + (with-tramp-debug-message vec "Opening connection" ;; We need a process bound to the connection buffer. Therefore, ;; we create a dummy process. Maybe there is a better solution? @@ -775,7 +783,6 @@ in case of error, t otherwise." (append (tramp-expand-args vec 'tramp-sudo-login nil - ?h (or (tramp-file-name-host vec) "") ?u (or (tramp-file-name-user vec) "")) (flatten-tree args)))) ;; We suppress the messages `Waiting for prompts from remote shell'. @@ -817,7 +824,7 @@ In case there is no valid Lisp expression, it raises an error." (when (search-forward-regexp (rx (not blank)) (line-end-position) t) (error nil))) (error (tramp-error - vec 'file-error + vec 'remote-file-error "`%s' does not return a valid Lisp expression: `%s'" (car args) (buffer-string))))))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f57b572532a..5281d8e4db5 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3931,7 +3931,7 @@ BODY is the backend specific code." ;; The implementation is not complete yet. (when (and (numberp ,destination) (zerop ,destination)) (tramp-error - v 'file-error "Implementation does not handle immediate return")) + v 'remote-file-error "Implementation does not handle immediate return")) (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Determine input. @@ -5239,6 +5239,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ?u (or (tramp-file-name-user (car target-alist)) "") ?h (or (tramp-file-name-host (car target-alist)) "")))) (with-parsed-tramp-file-name proxy l + (when (member l target-alist) + (tramp-user-error + vec "Cycle proxy definition `%s' in multi-hop" proxy)) ;; Add the hop. (push l target-alist) ;; Start next search. @@ -5505,7 +5508,7 @@ processes." This is the fallback implementation for backends which do not support symbolic links." (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + (tramp-dissect-file-name (expand-file-name linkname)) 'remote-file-error "make-symbolic-link not supported")) (defun tramp-handle-memory-info () @@ -6255,7 +6258,7 @@ performed successfully. Any other value means an error." (tramp-clear-passwd vec) (delete-process proc) (tramp-error-with-buffer - (tramp-get-connection-buffer vec) vec 'file-error + (tramp-get-connection-buffer vec) vec 'remote-file-error (cond ((eq exit 'permission-denied) "Permission denied") ((eq exit 'out-of-band-failed) @@ -6402,7 +6405,7 @@ nil." (tramp-accept-process-output proc) (unless (process-live-p proc) (tramp-error-with-buffer - nil proc 'file-error "Process has died")) + nil proc 'remote-file-error "Process has died")) (setq found (tramp-check-for-regexp proc regexp)))) ;; The process could have timed out, for example due to session ;; timeout of sudo. The process buffer does not exist any longer then. @@ -6412,9 +6415,10 @@ nil." (unless found (if timeout (tramp-error - proc 'file-error "[[Regexp `%s' not found in %d secs]]" + proc 'remote-file-error "[[Regexp `%s' not found in %d secs]]" regexp timeout) - (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) + (tramp-error + proc 'remote-file-error "[[Regexp `%s' not found]]" regexp))) found)) ;; It seems that Tru64 Unix does not like it if long strings are sent @@ -6431,7 +6435,8 @@ the remote host use line-endings as defined in the variable (chunksize (tramp-get-connection-property p "chunksize"))) (unless p (tramp-error - vec 'file-error "Can't send string to remote host -- not logged in")) + vec 'remote-file-error + "Can't send string to remote host -- not logged in")) (tramp-set-connection-property p "last-cmd-time" (current-time)) (tramp-message vec 10 "%s" string) (with-current-buffer (tramp-get-connection-buffer vec) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index f3bfaac005c..79fbe38b299 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -757,7 +757,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; `set-file-modes' is not implemented. (should-error (set-file-modes tmp-name1 #o777) - :type 'file-error) + :type 'remote-file-error) (should (= (file-modes tmp-name1) #o400)) (should-not (file-executable-p tmp-name1)) (should-not (file-writable-p tmp-name1)) @@ -766,7 +766,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; `set-file-modes' is not implemented. (should-error (set-file-modes tmp-name2 #o777) - :type 'file-error) + :type 'remote-file-error) (should (= (file-modes tmp-name2) #o500)) (should (file-executable-p tmp-name2)) (should-not (file-writable-p tmp-name2))) @@ -796,7 +796,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; `make-symbolic-link' is not implemented. (should-error (make-symbolic-link tmp-name1 tmp-name2) - :type 'file-error) + :type 'remote-file-error) (should (file-symlink-p tmp-name2)) (should (file-regular-p tmp-name2)) (should diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index bbfe15d2f59..28d773ca616 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -71,6 +71,7 @@ (declare-function edebug-mode "edebug") (declare-function project-mode-line-format "project") (declare-function tramp-check-remote-uname "tramp-sh") +(declare-function tramp-file-name-with-sudo "tramp-cmds") (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-chmod-h "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") @@ -185,7 +186,7 @@ The temporary file is not created." (declare (indent defun) (debug (body))) `(condition-case err (progn ,@body) - (file-error + (remote-file-error (unless (string-match-p (rx bol (| "make-symbolic-link not supported" (: "Making symbolic link" @@ -2203,19 +2204,31 @@ being the result.") m)) :type 'user-error))))) -(ert-deftest tramp-test03-file-name-method-rules () - "Check file name rules for some methods." - (skip-unless (eq tramp-syntax 'default)) - (skip-unless (tramp--test-enabled)) - - ;; Multi hops are allowed for inline methods only. - (let (non-essential) - (should-error - (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") - :type 'user-error) - (should-error - (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") - :type 'user-error))) +(ert-deftest tramp-test03-file-error () + "Check that Tramp signals an error in case of connection problems." + ;; Connect to a non-existing host. + (let ((vec (copy-tramp-file-name tramp-test-vec)) + ;; Don't poison it. + (tramp-default-proxies-alist tramp-default-proxies-alist) + (tramp-show-ad-hoc-proxies t)) + (cl-letf* (((symbol-function #'read-string) #'ignore) ; Suppress password. + ((tramp-file-name-host vec) "example.com.invalid")) + (should-error + (file-exists-p (tramp-make-tramp-file-name vec)) + ;; `user-error' is raised if the host shall be local. + ;; `remote-file-error' is raised if the host cannot be connected. + :type (if (tramp--test-ange-ftp-p) + 'ftp-error '(user-error remote-file-error))) + (should-error + (file-exists-p (tramp-make-tramp-file-name vec)) + ;; `ftp-error' and `remote-file-error' are subcategories of + ;; `file-error'. Let's check this as well. + :type '(user-error file-error)) + ;; Check multi-hop. + (should-error + (file-exists-p + (tramp-file-name-with-sudo (tramp-make-tramp-file-name vec))) + :type '(user-error file-error))))) (ert-deftest tramp-test04-substitute-in-file-name () "Check `substitute-in-file-name'." @@ -7637,11 +7650,12 @@ This requires restrictions of file name syntax." (unless (tramp--test-crypt-p) (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p) (and (tramp--test-smb-p) - (file-writable-p - (file-name-concat - (file-remote-p ert-remote-temporary-file-directory) - ;; We check a directory on the "ADMIN$" share. - "ADMIN$" "Boot")))))) + (ignore-errors + (file-writable-p + (file-name-concat + (file-remote-p ert-remote-temporary-file-directory) + ;; We check a directory on the "ADMIN$" share. + "ADMIN$" "Boot"))))))) (defun tramp--test-supports-set-file-modes-p () "Return whether the method under test supports setting file modes." From 8e71dc6bac590753473f3cc5294d7b998bd156bc Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Mon, 13 Oct 2025 16:37:17 +0200 Subject: [PATCH 189/191] Use new 'sort' calling convention in json.el * lisp/json.el (json--print-alist): Use new 'sort' calling convention for simplicity and potential performance gains. --- lisp/json.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lisp/json.el b/lisp/json.el index f2086474a8b..82cc9c71bf5 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -609,12 +609,11 @@ transforms an unsortable MAP into a sortable alist." "Insert a JSON representation of ALIST at point. Sort ALIST first if `json-encoding-object-sort-predicate' is non-nil. Sorting can optionally be DESTRUCTIVE for speed." - (json--print-map (if (and json-encoding-object-sort-predicate alist) - (sort (if destructive alist (copy-sequence alist)) - (lambda (a b) - (funcall json-encoding-object-sort-predicate - (car a) (car b)))) - alist))) + (json--print-map (let ((pred json-encoding-object-sort-predicate)) + (if (and pred alist) + (sort alist :key #'car :lessp pred + :in-place destructive) + alist)))) ;; The following two are unused but useful to keep around due to the ;; inherent ambiguity of lists. From 69a7f6f60505a192a3d165336b385e607094d806 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 12 Feb 2026 22:17:31 +0200 Subject: [PATCH 190/191] ; * src/dispnew.c (box_default): Shut up compilation warnings (bug#80386). --- src/dispnew.c | 2 +- src/fileio.c | 2 +- src/frame.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/dispnew.c b/src/dispnew.c index f0e451f5baa..85dd622802f 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -3649,7 +3649,7 @@ box_from_display_table (struct frame *f, enum box box, GLYPH *g) static void box_default (struct frame *f, enum box box, GLYPH *g) { - int dflt; + int dflt UNINIT; switch (box) { case BOX_VERTICAL: diff --git a/src/fileio.c b/src/fileio.c index d7186f3d995..cc6590130f7 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -4520,7 +4520,7 @@ by calling `format-decode', which see. */) /* Find the end position, which is end_offset if given, the file's end otherwise. */ - off_t endpos; + off_t endpos UNINIT; if (!giveup_match_end) { endpos = end_offset; diff --git a/src/frame.c b/src/frame.c index d197e4d5351..8dff1470149 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2603,7 +2603,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) struct frame *f = decode_any_frame (frame); struct frame *sf; struct kboard *kb; - Lisp_Object frames, frame1; + Lisp_Object frames, frame1 UNINIT; int is_tooltip_frame; bool nochild = !FRAME_PARENT_FRAME (f); Lisp_Object minibuffer_child_frame = Qnil; From f1fe4d46190263e164ccd1e066095d46a156297f Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Fri, 13 Feb 2026 05:19:58 +0200 Subject: [PATCH 191/191] Fix new eglot test failure due to project cache * test/lisp/progmodes/eglot-tests.el (eglot-test-project-wide-diagnostics-rust-analyzer): Bind project-vc-non-essential-cache-timeout to 0 so that the result of project-current is refreshed (bug#80387). --- test/lisp/progmodes/eglot-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 7267754dc7d..ffc097fee74 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -1017,7 +1017,8 @@ int main() { "fn main() -> i32 { return 42.2;}") ("other-file.rs" . "fn foo() -> () { let hi=3; }")))) - (let ((eglot-server-programs '((rust-mode . ("rust-analyzer"))))) + (let ((eglot-server-programs '((rust-mode . ("rust-analyzer")))) + (project-vc-non-essential-cache-timeout 0)) ;; Open other-file.rs, and see diagnostics arrive for main.rs, ;; which we didn't open. (with-current-buffer (eglot--find-file-noselect "project/other-file.rs")