1 files changed, 419 insertions, 0 deletions

diff --git a/lisp/package/package-describe.el b/lisp/package/package-describe.el
new file mode 100644
index 00000000000..15a7f78ffaf
--- /dev/null
+++ b/lisp/package/package-describe.el
@@ -0,0 +1,419 @@
+;;; package-describe.el --- Help buffer for packages -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2025  Philip Kaludercic
+
+;; Author: Philip Kaludercic <philipk@posteo.net>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'package-core)
+(require 'package-elpa)
+(require 'package-misc)
+(require 'package-install)
+
+(require 'browse-url)
+(require 'lisp-mnt)
+
+(defface package-help-section-name
+  '((t :inherit (bold font-lock-function-name-face)))
+  "Face used on section names in package description buffers."
+  :version "25.1"
+  :group 'package)
+
+(defun package--print-help-section (name &rest strings)
+  "Print \"NAME: \", right aligned to the 13th column.
+If more STRINGS are provided, insert them followed by a newline.
+Otherwise no newline is inserted."
+  (declare (indent 1))
+  (insert (make-string (max 0 (- 11 (string-width name))) ?\s)
+          (propertize (concat name ": ") 'font-lock-face 'package-help-section-name))
+  (when strings
+    (apply #'insert strings)
+    (insert "\n")))
+
+(defun package--get-description (desc)
+  "Return a string containing the long description of the package DESC.
+The description is read from the installed package files."
+  ;; Installed packages have nil for kind, so we look for README
+  ;; first, then fall back to the Commentary header.
+
+  ;; We don’t include README.md here, because that is often the home
+  ;; page on a site like github, and not suitable as the package long
+  ;; description.
+  (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org"))
+        file
+        (srcdir (package-desc-dir desc))
+        result)
+    (while (and files
+                (not result))
+      (setq file (pop files))
+      (when (file-readable-p (expand-file-name file srcdir))
+        ;; Found a README.
+        (with-temp-buffer
+          (insert-file-contents (expand-file-name file srcdir))
+          (setq result (buffer-string)))))
+
+    (or
+     result
+
+     ;; Look for Commentary header.
+     (lm-commentary (expand-file-name
+                     (format "%s.el" (package-desc-name desc)) srcdir))
+     "")))
+
+(defun package--describe-add-library-links ()
+  "Add links to library names in package description."
+  (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
+    (if (locate-library (match-string 1))
+        (make-text-button (match-beginning 1) (match-end 1)
+                          'xref (match-string-no-properties 1)
+                          'help-echo "Read this file's commentary"
+                          :type 'package--finder-xref))))
+
+(defun package-install-button-action (button)
+  "Run `package-install' on the package BUTTON points to.
+Used for the `action' property of buttons in the buffer created by
+`describe-package'."
+  (let ((pkg-desc (button-get button 'package-desc)))
+    (when (y-or-n-p (format-message "Install package `%s'? "
+                                    (package-desc-full-name pkg-desc)))
+      (package-install pkg-desc nil)
+      (describe-package (package-desc-name pkg-desc)))))
+
+(defun package-delete-button-action (button)
+  "Run `package-delete' on the package BUTTON points to.
+Used for the `action' property of buttons in the buffer created by
+`describe-package'."
+  (let ((pkg-desc (button-get button 'package-desc)))
+    (when (y-or-n-p (format-message "Delete package `%s'? "
+                                    (package-desc-full-name pkg-desc)))
+      (package-delete pkg-desc)
+      (describe-package (package-desc-name pkg-desc)))))
+
+(defun package-keyword-button-action (button)
+  "Show filtered \"*Packages*\" buffer for BUTTON.
+The buffer is filtered by the `package-keyword' property of BUTTON.
+Used for the `action' property of buttons in the buffer created by
+`describe-package'."
+  (let ((pkg-keyword (button-get button 'package-keyword)))
+    (package-show-package-list t (list pkg-keyword))))
+
+(defun package-make-button (text &rest properties)
+  "Insert button labeled TEXT with button PROPERTIES at point.
+PROPERTIES are passed to `insert-text-button', for which this
+function is a convenience wrapper used by `describe-package-1'."
+  (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
+        (button-face (if (display-graphic-p)
+                         (progn
+                           (require 'cus-edit) ; for the custom-button face
+                           'custom-button)
+                       'link)))
+    (apply #'insert-text-button button-text 'face button-face 'follow-link t
+           properties)))
+
+(defun package--finder-goto-xref (button)
+  "Jump to a Lisp file for the BUTTON at point."
+  (let* ((file (button-get button 'xref))
+         (lib (locate-library file)))
+    (if lib (finder-commentary lib)
+      (message "Unable to locate `%s'" file))))
+
+(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref)
+
+(defun describe-package-1 (pkg)
+  "Insert the package description for PKG.
+Helper function for `describe-package'."
+  (require 'lisp-mnt)
+  (let* ((desc (or
+                (if (package-desc-p pkg) pkg)
+                (cadr (assq pkg package-alist))
+                (let ((built-in (assq pkg package--builtins)))
+                  (if built-in
+                      (package--from-builtin built-in)
+                    (cadr (assq pkg package-archive-contents))))))
+         (name (if desc (package-desc-name desc) pkg))
+         (pkg-dir (if desc (package-desc-dir desc)))
+         (reqs (if desc (package-desc-reqs desc)))
+         (required-by (if desc (package--used-elsewhere-p desc nil 'all)))
+         (version (if desc (package-desc-version desc)))
+         (archive (if desc (package-desc-archive desc)))
+         (extras (and desc (package-desc-extras desc)))
+         (website (cdr (assoc :url extras)))
+         (commit (cdr (assoc :commit extras)))
+         (keywords (if desc (package-desc--keywords desc)))
+         (built-in (eq pkg-dir 'builtin))
+         (installable (and archive (not built-in)))
+         (status (if desc (package-desc-status desc) "orphan"))
+         (incompatible-reason (package--incompatible-p desc))
+         (signed (if desc (package-desc-signed desc)))
+         (maintainers (or (cdr (assoc :maintainer extras))
+                          (cdr (assoc :maintainers extras))))
+         (authors (cdr (assoc :authors extras)))
+         (news (and-let* (pkg-dir
+                          ((not built-in))
+                          (file (expand-file-name "news" pkg-dir))
+                          ((file-regular-p file))
+                          ((file-readable-p file)))
+                 file)))
+    (when (string= status "avail-obso")
+      (setq status "available obsolete"))
+    (when incompatible-reason
+      (setq status "incompatible"))
+    (princ (format "Package %S is %s.\n\n" name status))
+
+    ;; TODO: Remove the string decorations and reformat the strings
+    ;; for future l10n.
+    (package--print-help-section "Status")
+    (cond (built-in
+           (insert (propertize (capitalize status)
+                               'font-lock-face 'package-status-built-in)
+                   "."))
+          (pkg-dir
+           (insert (propertize (if (member status '("unsigned" "dependency"))
+                                   "Installed"
+                                 (capitalize status))
+                               'font-lock-face 'package-status-built-in))
+           (insert (substitute-command-keys " in `"))
+           (let ((dir (abbreviate-file-name
+                       (file-name-as-directory
+                        (if (file-in-directory-p pkg-dir package-user-dir)
+                            (file-relative-name pkg-dir package-user-dir)
+                          pkg-dir)))))
+             (help-insert-xref-button dir 'help-package-def pkg-dir))
+           (if (and (package-built-in-p name)
+                    (not (package-built-in-p name version)))
+               (insert (substitute-command-keys
+                        "',\n             shadowing a ")
+                       (propertize "built-in package"
+                                   'font-lock-face 'package-status-built-in))
+             (insert (substitute-quotes "'")))
+           (if signed
+               (insert ".")
+             (insert " (unsigned)."))
+           (when (and (package-desc-p desc)
+                      (not required-by)
+                      (member status '("unsigned" "installed")))
+             (insert " ")
+             (package-make-button "Delete"
+                                  'action #'package-delete-button-action
+                                  'package-desc desc)))
+          (incompatible-reason
+           (insert (propertize "Incompatible" 'font-lock-face 'font-lock-warning-face)
+                   " because it depends on ")
+           (if (stringp incompatible-reason)
+               (insert "Emacs " incompatible-reason ".")
+             (insert "uninstallable packages.")))
+          (installable
+           (insert (capitalize status))
+           (insert " from " (format "%s" archive))
+           (insert " -- ")
+           (package-make-button
+            "Install"
+            'action 'package-install-button-action
+            'package-desc desc))
+          (t (insert (capitalize status) ".")))
+    (insert "\n")
+    (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive.
+      (package--print-help-section "Archive"
+        (or archive "n/a")))
+    (and version
+         (package--print-help-section "Version"
+           (package-version-join version)))
+    (when commit
+      (package--print-help-section "Commit" commit))
+    (when desc
+      (package--print-help-section "Summary"
+        (package-desc-summary desc)))
+
+    (setq reqs (if desc (package-desc-reqs desc)))
+    (when reqs
+      (package--print-help-section "Requires")
+      (let ((first t))
+        (dolist (req reqs)
+          (let* ((name (car req))
+                 (vers (cadr req))
+                 (text (format "%s-%s" (symbol-name name)
+                               (package-version-join vers)))
+                 (reason (if (and (listp incompatible-reason)
+                                  (assq name incompatible-reason))
+                             " (not available)" "")))
+            (cond (first (setq first nil))
+                  ((>= (+ 2 (current-column) (length text) (length reason))
+                       (window-width))
+                   (insert ",\n               "))
+                  (t (insert ", ")))
+            (help-insert-xref-button text 'help-package name)
+            (insert reason)))
+        (insert "\n")))
+    (when required-by
+      (package--print-help-section "Required by")
+      (let ((first t))
+        (dolist (pkg required-by)
+          (let ((text (package-desc-full-name pkg)))
+            (cond (first (setq first nil))
+                  ((>= (+ 2 (current-column) (length text))
+                       (window-width))
+                   (insert ",\n               "))
+                  (t (insert ", ")))
+            (help-insert-xref-button text 'help-package
+                                     (package-desc-name pkg))))
+        (insert "\n")))
+    (when website
+      ;; Prefer https for the website of packages on common domains.
+      (when (string-match-p (rx bol "http://" (or "elpa." "www." "git." "")
+                                (or "nongnu.org" "gnu.org" "sr.ht"
+                                    "emacswiki.org" "gitlab.com" "github.com")
+                                "/")
+                            website)
+        ;; But only if the user has "https" in `package-archives'.
+        (let ((gnu (cdr (assoc "gnu" package-archives))))
+          (and gnu (string-match-p "^https" gnu)
+               (setq website
+                     (replace-regexp-in-string "^http" "https" website)))))
+      (package--print-help-section "Website")
+      (help-insert-xref-button website 'help-url website)
+      (insert "\n"))
+    (when keywords
+      (package--print-help-section "Keywords")
+      (dolist (k keywords)
+        (package-make-button
+         k
+         'package-keyword k
+         'action 'package-keyword-button-action)
+        (insert " "))
+      (insert "\n"))
+    (when maintainers
+      (unless (and (listp (car maintainers)) (listp (cdr maintainers)))
+        (setq maintainers (list maintainers)))
+      (package--print-help-section
+          (if (cdr maintainers) "Maintainers" "Maintainer"))
+      (dolist (maintainer maintainers)
+        (when (bolp)
+          (insert (make-string 13 ?\s)))
+        (package--print-email-button maintainer)))
+    (when authors
+      (package--print-help-section (if (cdr authors) "Authors" "Author"))
+      (dolist (author authors)
+        (when (bolp)
+          (insert (make-string 13 ?\s)))
+        (package--print-email-button author)))
+    (let* ((all-pkgs (append (cdr (assq name package-alist))
+                             (cdr (assq name package-archive-contents))
+                             (let ((bi (assq name package--builtins)))
+                               (if bi (list (package--from-builtin bi))))))
+           (other-pkgs (delete desc all-pkgs)))
+      (when other-pkgs
+        (package--print-help-section "Other versions"
+          (mapconcat (lambda (opkg)
+                       (let* ((ov (package-desc-version opkg))
+                              (dir (package-desc-dir opkg))
+                              (from (or (package-desc-archive opkg)
+                                        (if (stringp dir) "installed" dir))))
+                         (if (not ov) (format "%s" from)
+                           (format "%s (%s)"
+                                   (make-text-button (package-version-join ov) nil
+                                                     'font-lock-face 'link
+                                                     'follow-link t
+                                                     'action
+                                                     (lambda (_button)
+                                                       (describe-package opkg)))
+                                   from))))
+                     other-pkgs ", ")
+          ".")))
+
+    (insert "\n")
+
+    (let ((start-of-description (point)))
+      (if built-in
+          ;; For built-in packages, get the description from the
+          ;; Commentary header.
+          (insert (or (lm-commentary (locate-file (format "%s.el" name)
+                                                  load-path
+                                                  load-file-rep-suffixes))
+                      ""))
+
+        (if (package-installed-p desc)
+            ;; For installed packages, get the description from the
+            ;; installed files.
+            (insert (package--get-description desc))
+
+          ;; For non-built-in, non-installed packages, get description from
+          ;; the archive.
+          (let* ((basename (format "%s-readme.txt" name))
+                 readme-string)
+
+            (package--with-response-buffer (package-archive-base desc)
+              :file basename :noerror t
+              (save-excursion
+                (goto-char (point-max))
+                (unless (bolp)
+                  (insert ?\n)))
+              (cl-assert (not enable-multibyte-characters))
+              (setq readme-string
+                    ;; The readme.txt files are defined to contain utf-8 text.
+                    (decode-coding-region (point-min) (point-max) 'utf-8 t))
+              t)
+            (insert (or readme-string
+                        "This package does not provide a description.")))))
+
+      ;; Insert news if available.
+      (when news
+        (insert "\n" (make-separator-line) "\n"
+                (propertize "* News" 'face 'package-help-section-name)
+                "\n\n")
+        (insert-file-contents news))
+
+      ;; Make library descriptions into links.
+      (goto-char start-of-description)
+      (package--describe-add-library-links)
+      ;; Make URLs in the description into links.
+      (goto-char start-of-description)
+      (browse-url-add-buttons))))
+
+;;;###autoload
+(defun describe-package (package)
+  "Display the full documentation of PACKAGE (a symbol)."
+  (interactive
+   (let* ((guess (or (function-called-at-point)
+                     (symbol-at-point))))
+     (require 'finder-inf nil t)
+     ;; Load the package list if necessary (but don't activate them).
+     (unless package--initialized
+       (package-initialize t))
+     (let ((packages (append (mapcar #'car package-alist)
+                             (mapcar #'car package-archive-contents)
+                             (mapcar #'car package--builtins))))
+       (unless (memq guess packages)
+         (setq guess nil))
+       (setq packages (mapcar #'symbol-name packages))
+       (let ((val
+              (completing-read (format-prompt "Describe package" guess)
+                               packages nil t nil nil (when guess
+                                                        (symbol-name guess)))))
+         (list (and (> (length val) 0) (intern val)))))))
+  (if (not (or (package-desc-p package) (and package (symbolp package))))
+      (message "No package specified")
+    (help-setup-xref (list #'describe-package package)
+                     (called-interactively-p 'interactive))
+    (with-help-window (help-buffer)
+      (with-current-buffer standard-output
+        (describe-package-1 package)))))
+
+
+(provide 'package-describe)
+;;; package-describe.el ends here