Package: emacs;
Reported by: Daniel Mendler <mail <at> daniel-mendler.de>
Date: Fri, 29 Nov 2024 15:40:02 UTC
Severity: wishlist
Found in version 30.0.92
Message #68 received at 74604 <at> debbugs.gnu.org (full text, mbox):
From: Philip Kaludercic <philipk <at> posteo.net> To: Nobuyuki Kamimoto <kamimoto527 <at> gmail.com> Cc: Daniel Mendler <mail <at> daniel-mendler.de>, 74604 <at> debbugs.gnu.org Subject: Re: bug#74604: [PATCH v1] package.el: Add diff display and confirmation for package upgrades (Bug#74604) Date: Sat, 13 Sep 2025 12:17:31 +0000
Nobuyuki Kamimoto <kamimoto527 <at> gmail.com> writes:
> Hello Philip and Daniel,
>
> Thank you for your detailed feedback on the initial patch. You raised
> excellent points about avoiding
> duplication of existing VC functionality and improving the overall approach.
(Not to start a unrelated discussion, but parts of your message sound
like they might have been written by generative AI. I don't mind that,
but it might be an issue if you used GenAI to prepare the patch as well,
as TTBOMK is not yet a resolved matter for the GNU project. Related to
that, have you signed the FSF copyright assignment?)
[...]
>
> From a41c934b9c39e99e9aaf379519f0d66a71b39966 Mon Sep 17 00:00:00 2001
> From: Nobuyuki Kamimoto <kamimoto527 <at> gmail.com>
> Date: Fri, 12 Sep 2025 21:12:53 +0900
> Subject: [PATCH] Enhance package upgrade UI with interactive y/n/d/c prompts
>
> Add interactive confirmation system for package upgrades with options for:
> - Yes/No upgrade decisions
> - Diff display between package versions
> - Changelog viewing with file exclusion patterns
> - Configurable confirmation policy per package/archive
>
> Includes comprehensive diff utilities for tarball packages and VC packages,
> with proper error handling and user-friendly display buffers.
It would be nice if you could rewrite the commit message to align with
the style described in the CONTRIBUTE file (see the section "Commit
messages"). The main thing here is that you explicitly annotate how
which functions have been changed in which files.
> ---
> doc/emacs/package.texi | 42 ++++
> etc/NEWS | 10 +
> lisp/package/package-core.el | 158 ++++++++++++++
How much of these changes really have to be part of package-core? The
idea behind the ongoing refactoring is to keep that file as small as
possible, so that it contains just what is necessary to activate
packages on startup.
> lisp/package/package-install.el | 356 +++++++++++++++++++++++++++++++-
> lisp/package/package-menu.el | 48 +++--
> lisp/package/package-vc.el | 218 +++++++++++++++----
> 6 files changed, 774 insertions(+), 58 deletions(-)
>
> diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
> index 5aa9f9a74bf..3b2a59dda23 100644
> --- a/doc/emacs/package.texi
> +++ b/doc/emacs/package.texi
> @@ -389,6 +389,38 @@ Package Installation
> use these bulk commands if you want to update only a small number of
> built-in packages.
>
> +@vindex package-upgrade-confirmation-policy
> + By default, Emacs shows a diff of the changes when upgrading
> +packages, allowing you to review what has changed between the current
> +and new version before proceeding. This is controlled by the
> +@code{package-upgrade-confirmation-policy} user option. When set to @code{t} (the
> +default), package upgrades will display the differences and ask for
> +confirmation before proceeding. You can disable this behavior by
> +setting @code{package-upgrade-confirmation-policy} to @code{nil} to upgrade
> +all packages automatically without showing diffs.
> +
> + You can also specify which packages or archives require confirmation by
> +setting @code{package-upgrade-confirmation-policy} to a list of specific
> +packages and archives. Only the packages and archives in the list will show
> +confirmation prompts, while all others will upgrade automatically.
> +
> +@noindent
> +Examples of list-based configuration:
> +
> +@example
> +;; Only confirm magit and helm upgrades, auto-upgrade everything else
> +(setq package-upgrade-confirmation-policy
> + '((package magit) (package helm)))
> +
> +;; Only confirm packages from melpa archive, auto-upgrade others
> +(setq package-upgrade-confirmation-policy
> + '((archive "melpa")))
> +
> +;; Mixed: confirm org package and all melpa-stable packages
> +(setq package-upgrade-confirmation-policy
> + '((package org) (archive "melpa-stable")))
> +@end example
> +
> @cindex package requirements
> A package may @dfn{require} certain other packages to be installed,
> because it relies on functionality provided by them. When Emacs
> @@ -655,6 +687,16 @@ Fetching Package Sources
> Note that currently, built-in packages cannot be upgraded using
> @code{package-vc-install}.
>
> + Like regular package upgrades, VC package upgrades can also show
> +diffs before proceeding. This behavior is controlled by the same
> +@code{package-upgrade-confirmation-policy} user option that controls regular
> +package upgrades. When set to @code{t} (the default), upgrading VC
> +packages will display the differences between the current and updated
> +versions, allowing you to review the changes before confirming the upgrade.
> +
> + VC packages use the same confirmation policy and file exclusion patterns
> +as regular packages, ensuring consistent behavior across all package types.
> +
> @findex package-report-bug
> @findex package-vc-prepare-patch
> With the source checkout, you might want to reproduce a bug against
> diff --git a/etc/NEWS b/etc/NEWS
> index ac8e56326bf..904592577a0 100644
> --- a/etc/NEWS
> +++ b/etc/NEWS
> @@ -74,6 +74,16 @@ done from early-init.el, such as adding to 'package-directory-list'.
> ** 'prettify-symbols-mode' attempts to ignore undisplayable characters.
> Previously, such characters would be rendered as, e.g., white boxes.
>
> ++++
> +** Package management now shows diffs before upgrades.
> +Package upgrades will now display differences between the current and
> +new version before proceeding. This applies to both regular packages
> +and VC packages installed from version control repositories.
> +
> +Users will see a diff buffer showing changes and can choose whether to
> +proceed with or cancel the upgrade. This behavior can be controlled
> +through the 'package-upgrade-confirmation-policy' user option.
> +
> +++
> ** 'standard-display-table' now has more extra slots.
> 'standard-display-table' has been extended to allow specifying glyphs
> diff --git a/lisp/package/package-core.el b/lisp/package/package-core.el
> index e52654aa53d..b0b1831e1ed 100644
> --- a/lisp/package/package-core.el
> +++ b/lisp/package/package-core.el
> @@ -284,6 +284,164 @@ package-selected-packages
> :version "25.1"
> :type '(repeat symbol))
>
> +;; Interactive upgrade prompt constants
> +(defconst package-upgrade-interactive-commands
> + '((?y . upgrade)
> + (?n . cancel)
> + (?d . show-diff)
> + (?c . show-changelog)
> + (?q . quit))
> + "Interactive commands for package upgrade confirmation.")
> +
> +(defconst package-upgrade-prompt-message
> + "Upgrade %s? (y)es, (n)o, (d)iff, (c)hangelog, (q)uit: "
> + "Prompt message format for package upgrade confirmation.")
> +
> +(defconst package-diff-context-lines 3
> + "Number of context lines to show in package and changelog diffs.")
I don't think that we need these declarations as constants?
> +(defconst package-changelog-max-size (* 1024 1024)
> + "Maximum size in bytes for changelog files to process.")
> +
> +(defcustom package-upgrade-confirmation-policy t
As Eli said, the default is probably too invasive.
> + "Policy for confirming packages during upgrades.
> +This determines which packages require user confirmation before upgrading.
> +
> +Possible values:
> +
> +\\=`t\\=' - Default
> + Show diffs and prompt for all package upgrades.
> +
> +\\=`nil\\='
> + Automatically upgrade all packages without showing diffs.
> +
> +A list of specific packages/archives to confirm
> + Only the packages and archives listed will show confirmation prompts.
> + All others will be upgraded automatically.
> +
> + List format:
> + (package PACKAGE-SYMBOL) - Show diff for this specific package
Do you think that it would also be acceptable to have symbols
interpreted as synonyms to (package ...)?
> + (archive ARCHIVE-NAME) - Show diff for all packages in this archive
> +
> +Examples:
> + \\='((package magit) (package helm))
> + - Only confirm magit and helm upgrades
> + - All other packages upgrade automatically
> +
> + \\='((archive \"melpa\") (package org))
> + - Confirm all melpa archive packages
> + - Confirm org package upgrades
> + - All other packages upgrade automatically
> +
> + \\='((package magit))
> + - Only confirm magit upgrades
> + - All other packages upgrade automatically"
> + :type '(choice
> + (const :tag "Always show diffs" t)
> + (const :tag "Never show diffs" nil)
> + (repeat :tag "Specific packages/archives to confirm"
> + (choice
> + (list :tag "Package rule" (const package) symbol)
> + (list :tag "Archive rule" (const archive) string))))
> + :version "31.1")
> +
> +(defun package--match-rule-p (rule package-name package-archive)
I think it would be cleaner to pass the package-desc object here, than
to have to extract the information before invoking the function.
> + "Check if RULE matches PACKAGE-NAME and PACKAGE-ARCHIVE."
> + (pcase rule
> + (`(package ,name) (eq name package-name))
> + (`(archive ,archive) (string= archive package-archive))
> + (_ nil)))
> +
> +(defun package--should-show-diff-p (pkg-desc)
> + "Check if diff should be shown for PKG-DESC based on confirmation policy."
> + (let ((package-name (package-desc-name pkg-desc))
> + (package-archive (package-desc-archive pkg-desc))
> + (policy package-upgrade-confirmation-policy))
> + (cond
Feel free to use `pcase' here as well, to avoid the trivial binding.
> + ((eq policy t) t)
> + ((eq policy nil) nil)
This is redundant, as if the policy is nil, (listp nil) is true, and
(seq-some ... nil) is always nil.
> + ((listp policy)
> + ;; List mode: only show diff for packages/archives in the list
> + (seq-some (lambda (rule)
> + (package--match-rule-p rule package-name package-archive))
As the function is used only once, I would actually even inline it here.
> + policy))
> + (t t))))
> +
> +(defcustom package-changelog-patterns
> + '("CHANGELOG*" "NEWS*" "ChangeLog*" "CHANGES*" "HISTORY*")
> + "File patterns to match changelog files."
> + :type '(repeat string)
> + :version "31.1")
> +
> +(defvar package-changelog-file-regex
> + (concat "\\(" (mapconcat (lambda (pattern)
> + (replace-regexp-in-string "\\*" ".*" pattern))
> + package-changelog-patterns "\\|") "\\)")
> + "Regular expression to match changelog files based on patterns.")
I think it would be better to check for a designated "news" file, the
way that `describe-package-1' does.
> +;; Changelog file utilities
> +(declare-function diff-no-select "diff" (old new &optional switches no-async))
> +
> +(defun package--find-changelog-files (directory)
> + "Find all changelog files in DIRECTORY using regular expression matching.
> +Returns a list of paths to all matching changelog files found, or nil if none."
> + (when (and directory (stringp directory) (file-directory-p directory))
> + (condition-case err
> + (let ((files (directory-files directory t "^[^.]" t))
> + (candidates nil))
> + ;; Collect all matching files
> + (dolist (file files)
> + (when (and (file-regular-p file)
> + (file-readable-p file)
> + (let ((basename (file-name-nondirectory file)))
> + (string-match-p package-changelog-file-regex
> + (downcase basename))))
You can also just bind `case-fold-search' to nil, that way you don't
have to allocate a new string.
> + (push file candidates)))
> + ;; Return all candidates sorted by name for consistent ordering
> + (sort candidates #'string<))
> + (file-error
> + (message "File access error searching for changelog files in %s: %s"
> + directory (error-message-string err))
> + nil)
> + (error
> + (message "Error searching for changelog files in %s: %s"
> + directory (error-message-string err))
> + nil))))
I think that you can simplify this using `with-demoted-errors'.
> +
> +(defun package--diff-available-p ()
> + "Check if diff functionality is available.
> +Since we use built-in Emacs diff functions, this always returns t."
> + (require 'diff)
> + t)
Why do we need this?
> +(defun package--diff-changelog-files (old-file new-file)
> + "Generate unified diff between OLD-FILE and NEW-FILE.
> +Returns diff output as string, or nil if diff is not available."
> + (when (and old-file new-file
> + (file-exists-p old-file)
> + (file-exists-p new-file)
> + (package--diff-available-p))
> + (let ((old-size (nth 7 (file-attributes old-file)))
> + (new-size (nth 7 (file-attributes new-file))))
> + ;; Check file size limits
> + (when (and (< old-size package-changelog-max-size)
> + (< new-size package-changelog-max-size))
> + (let ((diff-buffer (diff-no-select old-file new-file
> + (format "--unified=%d" package-diff-context-lines) t)))
> + (when diff-buffer
> + (with-current-buffer diff-buffer
> + (let ((diff-output (buffer-string)))
> + (kill-buffer diff-buffer)
> + (when (> (length diff-output) 0)
> + diff-output)))))))))
> +
> +(defun package--format-changelog-diff ()
> + "Format and highlight diff output in current buffer.
> +Uses diff-mode features for syntax highlighting."
> + (when (fboundp 'diff-mode)
> + (diff-mode)
> + (font-lock-ensure)))
> +
> ;; Pseudo fields.
> (defun package-version-join (vlist)
> "Return the version string corresponding to the list VLIST.
> diff --git a/lisp/package/package-install.el b/lisp/package/package-install.el
> index 8401a7769b7..34468c109b5 100644
> --- a/lisp/package/package-install.el
> +++ b/lisp/package/package-install.el
> @@ -380,6 +380,7 @@ package-install
> (message "`%s' is already installed" name))))
>
> (declare-function package-vc-upgrade "package-vc" (pkg))
> +(declare-function diff-no-select "diff" (old new &optional switches no-async))
>
> ;;;###autoload
> (defun package-upgrade (name)
> @@ -392,16 +393,26 @@ package-upgrade
> (package--upgradeable-packages t) nil t))))
> (cl-check-type name symbol)
> (let* ((pkg-desc (cadr (assq name package-alist)))
> - (package-install-upgrade-built-in (not pkg-desc)))
> + (package-install-upgrade-built-in (not pkg-desc))
> + (new-pkg-desc (cadr (assq name package-archive-contents))))
> ;; `pkg-desc' will be nil when the package is an "active built-in".
> (if (and pkg-desc (package-vc-p pkg-desc))
> (package-vc-upgrade pkg-desc)
> - (when pkg-desc
> - (package-delete pkg-desc 'force 'dont-unselect))
> - (package-install name
> - ;; An active built-in has never been "selected"
> - ;; before. Mark it as installed explicitly.
> - (and pkg-desc 'dont-select)))))
> + ;; Check if this is a tarball package upgrade that needs diff confirmation
> + (if (and pkg-desc new-pkg-desc
> + (eq (package-desc-kind new-pkg-desc) 'tar))
> + ;; For tarball packages, show diff and ask for confirmation
> + ;; The function now handles the complete upgrade process internally
> + (unless (package--confirm-tarball-upgrade pkg-desc new-pkg-desc)
> + (message "Package upgrade cancelled"))
> + ;; For non-tarball packages, proceed with normal upgrade
> + (progn
You can drop the `progn' here, Elisp's if has an implicit trailing progn.
> + (when pkg-desc
> + (package-delete pkg-desc 'force 'dont-unselect))
> + (package-install name
> + ;; An active built-in has never been "selected"
> + ;; before. Mark it as installed explicitly.
> + (and pkg-desc 'dont-select)))))))
>
> (defun package--upgradeable-packages (&optional include-builtins)
> ;; Initialize the package system to get the list of package
> @@ -1108,5 +1119,336 @@ package-recompile-all
> (with-demoted-errors "Error while recompiling: %S"
> (package-recompile pkg-desc))))
>
> +;; Package upgrade diff utilities
> +
> +(defun package--safe-insert-file (file &optional error-msg)
> + "Safely insert FILE contents, showing ERROR-MSG on failure."
> + (condition-case err
Same comment here as above.
> + (when (and file (file-readable-p file))
> + (insert-file-contents file))
> + (file-error
> + (insert (or error-msg
> + (format "File access error: %s" (error-message-string err)))))
How can this happen, if we have established prior to
`insert-file-contents' that the file is readable -- excluding the
possibility of corrupted permissions due the involvement of multiple
users or race conditions?
> + (error
> + (insert (or error-msg
> + (format "Error reading file: %s" (error-message-string err)))))))
> +
> +(defun package--show-changelog (old-dir new-dir)
> + "Show diff of all changelog files between OLD-DIR and NEW-DIR.
> +Displays unified diff showing what changed in all matched changelog files.
> +Returns t if any changelog diff was displayed, nil otherwise."
> + (let ((old-changelogs (when old-dir (package--find-changelog-files old-dir)))
> + (new-changelogs (when new-dir (package--find-changelog-files new-dir)))
> + (displayed-any nil))
> + (cond
> + ;; Both directories have changelog files
> + ((or old-changelogs new-changelogs)
> + (setq displayed-any (package--display-all-changelog-diffs old-changelogs new-changelogs)))
> + ;; No changelog files found in either directory
> + (t
> + (message "No changelog files found")
> + nil))
> + displayed-any))
> +
> +(defun package--display-all-changelog-diffs (old-files new-files)
> + "Display diffs for all changelog files between OLD-FILES and NEW-FILES.
> +Returns t if any diff was displayed, nil otherwise."
> + (let ((buffer-name "*Package Changelog Diff*")
> + (displayed-any nil)
> + (unique-filenames nil))
> + ;; Kill existing buffer if it exists
> + (when (get-buffer buffer-name)
> + (kill-buffer buffer-name))
> +
> + ;; Get unique filenames from both lists
> + (setq unique-filenames
> + (delete-dups
> + (append (mapcar #'file-name-nondirectory old-files)
> + (mapcar #'file-name-nondirectory new-files))))
> +
> + (with-current-buffer (get-buffer-create buffer-name)
> + (let ((inhibit-read-only t))
> + (erase-buffer)
> + (insert "Changelog differences between old and new versions:\n")
> + (insert (make-string 55 ?=))
> + (insert "\n\n")
> +
> + ;; Process each unique filename
> + (dolist (filename unique-filenames)
> + (let ((old-file (car (seq-filter (lambda (f)
> + (string= filename (file-name-nondirectory f)))
> + old-files)))
> + (new-file (car (seq-filter (lambda (f)
> + (string= filename (file-name-nondirectory f)))
> + new-files))))
> + (cond
> + ;; Both old and new versions exist: show diff
> + ((and old-file new-file)
> + (package--insert-file-diff filename old-file new-file)
> + (setq displayed-any t))
> + ;; Only new file exists: show as new addition
> + ((and (not old-file) new-file)
> + (package--insert-new-file filename new-file)
> + (setq displayed-any t))
> + ;; Only old file exists: show as removal
> + ((and old-file (not new-file))
> + (insert (format "--- %s (REMOVED in new version) ---\n\n" filename))
> + (setq displayed-any t)))))
> +
> + (if displayed-any
> + (progn
> + (package--format-changelog-diff)
> + (goto-char (point-min))
> + (read-only-mode 1))
> + (insert "No changelog differences found.\n")
> + (read-only-mode 1)))
> +
> + (display-buffer buffer-name)
> + displayed-any)))
IMO it might be nicer if we could use an existing interface like
tabulated-list-mode. But just generating a plain, recursive diff would
also be fine.
> +(defun package--insert-file-diff (filename old-file new-file)
> + "Insert diff content for a single file into current buffer."
> + (insert (format "--- %s ---\n" filename))
> + (let ((diff-output (package--diff-changelog-files old-file new-file)))
> + (if diff-output
> + (insert diff-output)
> + ;; Fallback if diff is unavailable
> + (insert "Diff unavailable. Showing full new content:\n")
> + (package--safe-insert-file new-file))
> + (insert "\n\n")))
> +
> +(defun package--insert-new-file (filename new-file)
> + "Insert new file content into current buffer."
> + (insert (format "--- %s (NEW in this version) ---\n" filename))
> + (package--safe-insert-file new-file)
> + (insert "\n\n"))
> +
> +(defun package--show-package-diff (old-dir new-dir pkg-desc)
> + "Show diff between OLD-DIR and NEW-DIR package directories for PKG-DESC.
> +This function only displays the diff without prompting for user confirmation."
> + ;; Ensure diff is loaded and ready before proceeding
> + (require 'diff)
> + ;; Ensure diff feature is fully loaded on first run
> + (unless (featurep 'diff)
> + (sit-for 0.1))
require is not asynchronous! This is not an issue.
> + ;; Additional safety: ensure diff functions are available
> + (unless (fboundp 'diff-mode)
> + (autoload 'diff-mode "diff" "Diff major mode" t))
This is als not necessary, diff-mode is part of Emacs and you can rely
on the above require to do the right thing™.
> + (condition-case outer-err
> + (let ((diff-buffer-name "*Package Diff*"))
> + ;; Kill existing buffer to avoid read-only issues
> + (when (get-buffer diff-buffer-name)
> + (kill-buffer diff-buffer-name))
> +
> + ;; Check if directories exist before proceeding
> + (unless (and (file-directory-p old-dir) (file-directory-p new-dir))
> + (error "One or both directories do not exist: %s, %s" old-dir new-dir))
> +
> + (condition-case diff-err
> + ;; Use built-in diff-no-select instead of external commands
Why?
> + (let ((diff-buffer (diff-no-select old-dir new-dir "--unified" t)))
> + (if diff-buffer
> + (progn
> + ;; Safely configure diff buffer before renaming
> + (with-current-buffer diff-buffer
> + ;; Ensure diff-mode is properly initialized first
> + (when (fboundp 'diff-mode)
> + (diff-mode))
> + ;; Configure buffer for stable scrolling
> + (setq buffer-read-only t)
> + (setq truncate-lines nil) ; Allow line wrapping
> + ;; Disable potentially problematic diff features
> + (when (boundp 'diff-refine-hunk)
> + (set (make-local-variable 'diff-refine-hunk) nil))
Why disable this? This is a useful feature when reading the file.
> + (goto-char (point-min))
> + ;; Now safely rename the buffer
> + (rename-buffer diff-buffer-name t))
> + ;; Display the properly configured buffer
> + (display-buffer diff-buffer-name))
> + ;; No differences found
> + (with-current-buffer (get-buffer-create diff-buffer-name)
> + (let ((inhibit-read-only t))
> + (erase-buffer)
> + (insert (format "No significant differences found between old and new versions of %s.\n"
> + (package-desc-name pkg-desc)))
> + (goto-char (point-min))
> + (read-only-mode 1))
> + (display-buffer diff-buffer-name))))
> + (error
> + ;; If diff fails, create a simple error message
> + (with-current-buffer (get-buffer-create diff-buffer-name)
> + (let ((inhibit-read-only t))
> + (erase-buffer)
> + (insert (format "Error running diff operation: %s\n\n" (error-message-string diff-err)))
> + (insert "This may be due to:\n")
> + (insert "- File access permissions\n")
> + (insert "- Directory structure issues\n")
> + (insert "- Memory limitations for large diffs\n")
> + (read-only-mode 1))
> + (display-buffer diff-buffer-name))))
> + ;; Return t to indicate success
> + t)
> + (error
> + (message "Error showing package diff: %s (Retry may work)" (error-message-string outer-err))
> + ;; Return nil to indicate failure but allow retry
> + nil)))
> +
> +(defun package--handle-interactive-command (command pkg-desc old-dir new-dir)
> + "Handle interactive COMMAND for PKG-DESC upgrade."
> + (pcase command
> + ('upgrade 'upgrade)
You don't need to quote upgrade here?
> + ('cancel 'cancel)
> + ('show-diff
> + (condition-case err
> + (if (and old-dir new-dir)
> + (progn
> + (let ((result (package--show-package-diff old-dir new-dir pkg-desc)))
> + (if result
> + (message "Diff displayed. Press y to upgrade, n to cancel, c for changelog.")
> + (message "Diff display failed. Please try again or use changelog (c)."))))
> + (message "Package directories not available for diff."))
> + (error
> + (message "Error displaying diff: %s (Try again with 'd' or use changelog with 'c')"
> + (error-message-string err))))
> + ;; Always return nil to prevent process termination
> + nil)
> + ('show-changelog
> + (condition-case err
> + (if (package--show-changelog old-dir new-dir)
> + (message "Changelog displayed. Press y to upgrade, n to cancel, d for full diff.")
> + (message "No changelog differences found. Press y to upgrade, n to cancel."))
> + (error
> + (message "Error displaying changelog: %s" (error-message-string err))))
> + nil)
> + ('quit 'quit)
> + (_
> + (message "Invalid choice. Use: y=upgrade, n=cancel, d=diff, c=changelog, q=quit")
> + (sit-for 1.5)
> + nil)))
> +
> +(defun package--upgrade-interactive-prompt (pkg-desc &optional old-dir new-dir)
> + "Interactive prompt for package upgrade confirmation."
> + (let ((package-name (package-desc-name pkg-desc))
> + (prompt-choices (mapcar #'car package-upgrade-interactive-commands)))
> + (catch 'result
> + (while t
> + (condition-case err
> + (let* ((choice (read-char-choice
> + (format package-upgrade-prompt-message package-name)
> + prompt-choices))
> + (command (cdr (assq choice package-upgrade-interactive-commands)))
> + (result (package--handle-interactive-command command pkg-desc old-dir new-dir)))
> + (when result
> + (throw 'result result)))
> + (quit
> + (message "Package upgrade cancelled by user")
> + (throw 'result 'cancel))
> + (error
> + (message "Error during input: %s" (error-message-string err))
> + (sit-for 1)))))))
You have reimplemented `read-multiple-choice'...
> +
> +(defun package--get-installed-package-dir (pkg-desc)
> + "Get directory of installed PKG-DESC package."
> + (expand-file-name (package-desc-full-name pkg-desc) package-user-dir))
> +
> +(defun package-extract (pkg-desc)
> + "Extract package PKG-DESC files without generating autoloads or descriptors.
> +Only performs file extraction based on package kind. Returns the package
> +directory path where files were extracted."
> + (let* ((name (package-desc-name pkg-desc))
> + (dirname (package-desc-full-name pkg-desc))
> + (pkg-dir (expand-file-name dirname package-user-dir)))
> + ;; Extract files based on package kind
> + (pcase (package-desc-kind pkg-desc)
> + ('dir
> + (make-directory pkg-dir t)
> + (let ((file-list
> + (or (and (derived-mode-p 'dired-mode)
> + (dired-get-marked-files))
> + (directory-files-recursively default-directory "" nil))))
> + (dolist (source-file file-list)
> + (let ((target (expand-file-name
> + (file-relative-name source-file default-directory)
> + pkg-dir)))
> + (make-directory (file-name-directory target) t)
> + (copy-file source-file target t)))
> + ;; Now that the files have been installed, this package is
> + ;; indistinguishable from a `tar' or a `single'. Let's make
> + ;; things simple by ensuring we're one of them.
> + (setf (package-desc-kind pkg-desc)
> + (if (length> file-list 1) 'tar 'single))))
> + ('tar
> + (make-directory package-user-dir t)
> + (let* ((default-directory (file-name-as-directory package-user-dir)))
> + (package-untar-buffer dirname)))
> + ('single
> + (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir)))
> + (make-directory pkg-dir t)
> + (package--write-file-no-coding el-file)))
> + (kind (error "Unknown package kind: %S" kind)))
> + ;; Return the directory path (no autoloads generation yet)
> + pkg-dir))
> +
> +(defun package--download-and-extract (new-pkg-desc)
> + "Download and extract NEW-PKG-DESC. Return extraction directory."
> + (let ((location (package-archive-base new-pkg-desc))
> + (file (concat (package-desc-full-name new-pkg-desc)
> + (package-desc-suffix new-pkg-desc))))
> + (package--with-response-buffer location :file file
> + (package-extract new-pkg-desc))))
> +
> +(defun package--confirm-upgrade (_pkg-desc new-pkg-desc old-dir new-dir)
> + "Ask user to confirm upgrade from _PKG-DESC to NEW-PKG-DESC."
> + (if (file-exists-p old-dir)
> + (let ((result (package--upgrade-interactive-prompt new-pkg-desc old-dir new-dir)))
> + (cond
> + ((eq result 'upgrade) t)
> + ((eq result 'quit) (user-error "Package upgrade cancelled by user"))
> + (t nil)))
> + (yes-or-no-p (format "New package installation: %s. Continue? "
> + (package-desc-name new-pkg-desc)))))
> +
> +(defun package--complete-upgrade (pkg-desc new-pkg-desc new-dir)
> + "Complete the upgrade process from PKG-DESC to NEW-PKG-DESC."
> + (when pkg-desc
> + (package-delete pkg-desc 'force 'dont-unselect))
> + (when (and new-dir (file-directory-p new-dir))
> + (delete-directory new-dir t))
> + (package-install-from-archive new-pkg-desc))
> +
> +(defun package--confirm-tarball-upgrade (pkg-desc new-pkg-desc)
> + "Confirm and execute tarball package upgrade.
> +
> +This function handles the complete tarball upgrade workflow:
> +1. Check if diff display is required based on trust policy
> +2. Download and extract new package for comparison
> +3. Show diff and get user confirmation
> +4. Complete upgrade or clean up on cancellation
> +
> +Args:
> + PKG-DESC: Current installed package descriptor
> + NEW-PKG-DESC: New package descriptor to upgrade to
> +
> +Returns:
> + t if upgrade was confirmed and completed, nil otherwise."
> + (if (package--should-show-diff-p new-pkg-desc)
> + (let* ((old-dir (package--get-installed-package-dir pkg-desc))
> + (new-dir nil)
> + (confirmed nil))
> + (unwind-protect
> + (progn
> + (setq new-dir (package--download-and-extract new-pkg-desc))
> + (setq confirmed (package--confirm-upgrade pkg-desc new-pkg-desc old-dir new-dir))
> + (when confirmed
> + (package--complete-upgrade pkg-desc new-pkg-desc new-dir)))
> + ;; Cleanup: remove temporary extraction directory if upgrade was cancelled
> + (when (and new-dir (not confirmed) (file-exists-p new-dir))
> + (ignore-errors (delete-directory new-dir t))))
> + confirmed)
> + ;; Trust policy says skip diff - proceed directly with upgrade
> + (progn
> + (package--complete-upgrade pkg-desc new-pkg-desc nil)
> + t)))
> +
> (provide 'package-install)
> ;;; package-install.el ends here
> diff --git a/lisp/package/package-menu.el b/lisp/package/package-menu.el
> index c57086112c4..3ffdb940554 100644
> --- a/lisp/package/package-menu.el
> +++ b/lisp/package/package-menu.el
> @@ -653,22 +653,38 @@ package-menu--perform-transaction
> (format status-format (incf i)))
> (force-mode-line-update)
> (redisplay 'force)
> - ;; Don't mark as selected, `package-menu-execute' already
> - ;; does that.
> - (package-install pkg 'dont-select))))
> - (let ((package-menu--transaction-status ":Deleting"))
> - (force-mode-line-update)
> - (redisplay 'force)
> - (dolist (elt (package--sort-by-dependence delete-list))
> - (condition-case-unless-debug err
> - (let ((inhibit-message (or inhibit-message package-menu-async)))
> - (package-delete elt nil 'nosave))
> - (error
> - (push (package-desc-full-name elt) errors)
> - (message "Error trying to delete `%s': %s"
> - (package-desc-full-name elt)
> - (error-message-string err))))))
> - errors))
> + ;; Check if this is a package upgrade and needs confirmation
> + (let* ((pkg-name (package-desc-name pkg))
> + (old-pkg (cl-find-if (lambda (del-pkg)
> + (eq (package-desc-name del-pkg) pkg-name))
> + delete-list)))
> + (cond
> + ;; Tarball package upgrade - use tarball confirmation
> + ((and old-pkg (eq (package-desc-kind pkg) 'tar))
> + (if (package--confirm-tarball-upgrade old-pkg pkg)
> + (package-install pkg 'dont-select)
> + (push (package-desc-full-name pkg) errors)))
> + ;; VC package upgrade - use VC confirmation
> + ((and old-pkg (package-vc-p old-pkg))
> + (if (package-vc--confirm-upgrade old-pkg)
> + (package-install pkg 'dont-select)
> + (push (package-desc-full-name pkg) errors)))
> + ;; Normal installation or upgrade
> + (t
> + (package-install pkg 'dont-select))))))
> + (let ((package-menu--transaction-status ":Deleting"))
> + (force-mode-line-update)
> + (redisplay 'force)
> + (dolist (elt (package--sort-by-dependence delete-list))
> + (condition-case-unless-debug err
> + (let ((inhibit-message (or inhibit-message package-menu-async)))
> + (package-delete elt nil 'nosave))
> + (error
> + (push (package-desc-full-name elt) errors)
> + (message "Error trying to delete `%s': %s"
> + (package-desc-full-name elt)
> + (error-message-string err))))))
> + errors)))
>
> (defun package--update-selected-packages (add remove)
> "Update the `package-selected-packages' list according to ADD and REMOVE.
> diff --git a/lisp/package/package-vc.el b/lisp/package/package-vc.el
> index 03767b99729..3579c9d69b5 100644
> --- a/lisp/package/package-vc.el
> +++ b/lisp/package/package-vc.el
> @@ -53,6 +53,7 @@
> (require 'package-elpa)
> (require 'lisp-mnt)
> (require 'vc)
> +(require 'vc-git)
Err, package-vc is intentionally vc agnostic, so we shouldn't depend on
a specific backend, unless we are providing a speedup (in which case it
would be better to implement the feature more generally in vc-git).
> (require 'seq)
>
> (defgroup package-vc nil
> @@ -737,6 +738,8 @@ package-vc-upgrade-all
>
> (declare-function vc-dir-prepare-status-buffer "vc-dir"
> (bname dir backend &optional create-new))
> +(declare-function vc-diff-incoming "vc" (&optional remote-location fileset))
> +(declare-function vc-log-incoming "vc" (&optional remote-location))
You shouldn't need this, as we are requiring vc above!
>
> ;;;###autoload
> (defun package-vc-upgrade (pkg-desc)
> @@ -745,40 +748,42 @@ package-vc-upgrade
> This may fail if the local VCS state of the package conflicts
> with the remote repository state."
> (interactive (list (package-vc--read-package-desc "Upgrade VC package: " t)))
> - ;; HACK: To run `package-vc--unpack-1' after checking out the new
> - ;; revision, we insert a hook into `vc-post-command-functions', and
> - ;; remove it right after it ran. To avoid running the hook multiple
> - ;; times or even for the wrong repository (as `vc-pull' is often
> - ;; asynchronous), we extract the relevant arguments using a pseudo
> - ;; filter for `vc-filter-command-function', executed only for the
> - ;; side effect, and store them in the lexical scope. When the hook
> - ;; is run, we check if the arguments are the same (`eq') as the ones
> - ;; previously extracted, and only in that case will be call
> - ;; `package-vc--unpack-1'. Ugh...
> - ;;
> - ;; If there is a better way to do this, it should be done.
> - (cl-assert (package-vc-p pkg-desc))
> - (letrec ((pkg-dir (package-desc-dir pkg-desc))
> - (vc-flags)
> - (vc-filter-command-function
> - (lambda (command file-or-list flags)
> - (setq vc-flags flags)
> - (list command file-or-list flags)))
> - (post-upgrade
> - (lambda (_command _file-or-list flags)
> - (when (and (file-equal-p pkg-dir default-directory)
> - (eq flags vc-flags))
> - (unwind-protect
> - (with-demoted-errors "Failed to activate: %S"
> - (package-vc--unpack-1 pkg-desc pkg-dir))
> - (remove-hook 'vc-post-command-functions post-upgrade))))))
> - (add-hook 'vc-post-command-functions post-upgrade)
> - (with-demoted-errors "Failed to fetch: %S"
> - (require 'vc-dir)
> - (with-current-buffer (vc-dir-prepare-status-buffer
> - (format " *package-vc-dir: %s*" pkg-dir)
> - pkg-dir (vc-responsible-backend pkg-dir))
> - (vc-pull)))))
> + ;; Check if user wants to see diff and confirm upgrade
> + (when (package-vc--confirm-upgrade pkg-desc)
> + ;; HACK: To run `package-vc--unpack-1' after checking out the new
> + ;; revision, we insert a hook into `vc-post-command-functions', and
> + ;; remove it right after it ran. To avoid running the hook multiple
> + ;; times or even for the wrong repository (as `vc-pull' is often
> + ;; asynchronous), we extract the relevant arguments using a pseudo
> + ;; filter for `vc-filter-command-function', executed only for the
> + ;; side effect, and store them in the lexical scope. When the hook
> + ;; is run, we check if the arguments are the same (`eq') as the ones
> + ;; previously extracted, and only in that case will be call
> + ;; `package-vc--unpack-1'. Ugh...
> + ;;
> + ;; If there is a better way to do this, it should be done.
> + (cl-assert (package-vc-p pkg-desc))
This assertion should remain at the beginning of the function.
> + (letrec ((pkg-dir (package-desc-dir pkg-desc))
> + (vc-flags)
> + (vc-filter-command-function
> + (lambda (command file-or-list flags)
> + (setq vc-flags flags)
> + (list command file-or-list flags)))
> + (post-upgrade
> + (lambda (_command _file-or-list flags)
> + (when (and (file-equal-p pkg-dir default-directory)
> + (eq flags vc-flags))
> + (unwind-protect
> + (with-demoted-errors "Failed to activate: %S"
> + (package-vc--unpack-1 pkg-desc pkg-dir))
> + (remove-hook 'vc-post-command-functions post-upgrade))))))
> + (add-hook 'vc-post-command-functions post-upgrade)
> + (with-demoted-errors "Failed to fetch: %S"
> + (require 'vc-dir)
> + (with-current-buffer (vc-dir-prepare-status-buffer
> + (format " *package-vc-dir: %s*" pkg-dir)
> + pkg-dir (vc-responsible-backend pkg-dir))
> + (vc-pull))))))
>
> (defun package-vc--archives-initialize ()
> "Initialize package.el and fetch package specifications."
> @@ -997,7 +1002,150 @@ package-vc-log-incoming
> (interactive
> (list (package-vc--read-package-desc "Incoming log for package: " t)))
> (let ((default-directory (package-desc-dir pkg-desc)))
> - (call-interactively #'vc-log-incoming)))
> + ;; Call vc-log-incoming directly without interactive prompting
> + (vc-log-incoming nil)))
> +
> +;; Package upgrade diff utilities for VC packages
> +
> +(defun package-vc--show-changelog (pkg-desc from-rev to-rev)
> + "Show diff of all changelog files between FROM-REV and TO-REV for PKG-DESC.
> +Returns t if any changelog diff was displayed, nil otherwise."
> + (let* ((pkg-dir (package-desc-dir pkg-desc))
> + (default-directory pkg-dir)
> + (changelog-files (package--find-changelog-files pkg-dir)))
> + (if changelog-files
> + (package-vc--display-all-changelog-diffs changelog-files from-rev to-rev)
> + (message "No changelog files found in repository")
> + nil)))
> +
> +(defun package-vc--display-all-changelog-diffs (changelog-files from-rev to-rev)
> + "Display git diff for all CHANGELOG-FILES between FROM-REV and TO-REV."
> + (let ((diff-buffer-name "*Package VC Changelog Diff*")
> + (displayed-any nil))
> + ;; Kill existing buffer
> + (when (get-buffer diff-buffer-name)
> + (kill-buffer diff-buffer-name))
> +
> + (with-current-buffer (get-buffer-create diff-buffer-name)
> + (let ((inhibit-read-only t))
> + (erase-buffer)
> + (insert (format "Changelog differences between %s and %s:\n" from-rev to-rev))
> + (insert (make-string 60 ?=))
> + (insert "\n\n")
> +
> + ;; Process each changelog file
> + (dolist (changelog-file changelog-files)
> + (let ((filename (file-name-nondirectory changelog-file)))
> + (insert (format "--- %s ---\n" filename))
> + (condition-case err
> + (let ((diff-output
> + (with-output-to-string
> + (with-current-buffer standard-output
> + (vc-git-command
This is not acceptable.
> + (current-buffer) 0 changelog-file
> + "diff" from-rev to-rev
> + (format "--unified=%d" package-diff-context-lines)
> + "--" (file-relative-name changelog-file))))))
> + (if (> (length diff-output) 0)
> + (progn
> + (insert diff-output)
> + (setq displayed-any t))
> + (insert "No changes found in this file.\n")))
> + (error
> + (insert (format "Error running git diff: %s" (error-message-string err)))))
> + (insert "\n\n")))
> +
> + (if displayed-any
> + (progn
> + (package--format-changelog-diff)
> + (goto-char (point-min))
> + (read-only-mode 1))
> + (insert "No changelog changes found between the specified revisions.\n")
> + (read-only-mode 1)))
> +
> + (display-buffer diff-buffer-name)
> + displayed-any)))
> +
> +(defun package-vc--upgrade-interactive-prompt (pkg-desc)
> + "Interactive prompt for VC package upgrade confirmation.
> +PKG-DESC is the VC package descriptor.
> +Returns \\='upgrade to proceed with upgrade, \\='cancel to abort."
> + (condition-case err
> + (let ((package-name (package-desc-name pkg-desc))
> + (prompt-choices (mapcar #'car package-upgrade-interactive-commands))
> + (result nil)
> + (pkg-dir (package-desc-dir pkg-desc))
> + (current-rev nil)
> + (target-rev nil))
> +
> + ;; Initialize revisions for changelog comparison
> + (condition-case _
> + (let ((default-directory pkg-dir))
> + (setq current-rev (string-trim (shell-command-to-string "git rev-parse HEAD")))
> + (setq target-rev "origin/HEAD"))
> + (error
> + (setq current-rev "HEAD~1")
> + (setq target-rev "HEAD")))
> +
> + (while (not (memq result '(upgrade cancel quit)))
> + (condition-case input-err
> + (let ((choice (read-char-choice
> + (format package-upgrade-prompt-message package-name)
> + prompt-choices)))
> + (pcase (cdr (assq choice package-upgrade-interactive-commands))
> + ('upgrade
> + (setq result 'upgrade))
> + ('cancel
> + (setq result 'cancel))
> + ('quit
> + (setq result 'quit))
> + ('show-diff
> + ;; For VC packages, show both log and diff using separate standard VC functions
> + (condition-case log-err
> + (let ((default-directory (package-desc-dir pkg-desc)))
> + ;; Show incoming log
> + (vc-log-incoming nil)
> + ;; Also show incoming diff
> + (vc-root-diff-incoming nil))
> + (error
> + (message "Error showing incoming changes: %s" (error-message-string log-err)))))
> + ('show-changelog
> + (condition-case log-err
> + (package-vc--show-changelog pkg-desc current-rev target-rev)
> + (error
> + (message "Error showing changelog: %s" (error-message-string log-err)))))
> + (_
> + ;; Invalid choice, continue loop
> + (message "Invalid choice. Please press y, n, d, c, or q.")
> + (sit-for 1))))
> + (quit
> + ;; Handle user interruption (C-g)
> + (setq result 'cancel))
> + (error
> + (message "Error during input: %s" (error-message-string input-err))
> + (sit-for 1))))
> +
> + result)
> + (error
> + (message "Critical error in interactive prompt for %s: %s"
> + (package-desc-name pkg-desc) (error-message-string err))
> + 'cancel)))
> +
> +(defun package-vc--confirm-upgrade (pkg-desc)
> + "Show incoming changes for VC package upgrade and ask for confirmation.
> +PKG-DESC is the package descriptor to upgrade.
> +Return t if user wants to proceed, nil otherwise."
> + ;; Check trust policy
> + (let ((should-show-diff (package--should-show-diff-p pkg-desc)))
> + (if should-show-diff
> + ;; Use interactive prompt for upgrade confirmation
> + (let ((result (package-vc--upgrade-interactive-prompt pkg-desc)))
> + (cond
> + ((eq result 'upgrade) t)
> + ((eq result 'quit) (user-error "Package upgrade cancelled by user"))
> + (t nil)))
> + ;; Auto-upgrade without diff
> + t)))
I am sorry to say, but I am not convinced by the current approach. My
suggestion would be to first focus on upgrading tarball packages, and
then we can consider the matter again for vc-packages.
> (provide 'package-vc)
> ;;; package-vc.el ends here
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.