Function: describe-package-1
describe-package-1 is a byte-compiled function defined in
package.el.gz.
Signature
(describe-package-1 PKG)
Documentation
Insert the package description for PKG.
Helper function for describe-package.
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/package.el.gz
(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))))