+++ /dev/null
-;;; package-x.el --- Package extras -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2025 Free Software Foundation, Inc.
-
-;; Author: Tom Tromey <tromey@redhat.com>
-;; Created: 10 Mar 2007
-;; Keywords: tools
-;; Package: package
-;; Obsolete-since: 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file currently contains parts of the package system that many
-;; won't need, such as package uploading.
-
-;; To upload to an archive, first set `package-archive-upload-base' to
-;; some desired directory. For testing purposes, you can specify any
-;; directory you want, but if you want the archive to be accessible to
-;; others via http, this is typically a directory in the /var/www tree
-;; (possibly one on a remote machine, accessed via Tramp).
-
-;; Then call M-x package-upload-file, which prompts for a file to
-;; upload. Alternatively, M-x package-upload-buffer uploads the
-;; current buffer, if it's visiting a package file.
-
-;; Once a package is uploaded, users can access it via the Package
-;; Menu, by adding the archive to `package-archives'.
-
-;;; Code:
-
-(require 'package)
-(defvar gnus-article-buffer)
-
-(defcustom package-archive-upload-base "/path/to/archive"
- "The base location of the archive to which packages are uploaded.
-The commands in the package-x library will use this as base
-location.
-This should be an absolute directory name. If the archive is on
-another machine, you may specify a remote name in the usual way,
-e.g. \"/ssh:foo@example.com:/var/www/packages/\".
-See Info node `(emacs)Remote Files'.
-
-Unlike `package-archives', you can't specify a HTTP URL."
- :type 'directory
- :group 'package
- :version "24.1")
-
-(defvar package-update-news-on-upload nil
- "Whether uploading a package should also update NEWS and RSS feeds.")
-
-(defun package--encode (string)
- "Encode a string by replacing some characters with XML entities."
- ;; We need a special case for translating "&" to "&".
- (let ((index))
- (while (setq index (string-match "[&]" string index))
- (setq string (replace-match "&" t nil string))
- (setq index (1+ index))))
- (while (string-match "[<]" string)
- (setq string (replace-match "<" t nil string)))
- (while (string-match "[>]" string)
- (setq string (replace-match ">" t nil string)))
- (while (string-match "[']" string)
- (setq string (replace-match "'" t nil string)))
- (while (string-match "[\"]" string)
- (setq string (replace-match """ t nil string)))
- string)
-
-(defun package--make-rss-entry (title text archive-url)
- (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
- (concat "<item>\n"
- "<title>" (package--encode title) "</title>\n"
- ;; FIXME: should have a link in the web page.
- "<link>" archive-url "news.html</link>\n"
- "<description>" (package--encode text) "</description>\n"
- "<pubDate>" date-string "</pubDate>\n"
- "</item>\n")))
-
-(defun package--make-html-entry (title text)
- (concat "<li> " (format-time-string "%B %e") " - "
- title " - " (package--encode text)
- " </li>\n"))
-
-(defun package--update-file (file tag text)
- "Update the package archive file named FILE.
-FILE should be relative to `package-archive-upload-base'.
-TAG is a string that can be found within the file; TEXT is
-inserted after its first occurrence in the file."
- (setq file (expand-file-name file package-archive-upload-base))
- (save-excursion
- (let ((old-buffer (find-buffer-visiting file)))
- (with-current-buffer (let ((find-file-visit-truename t))
- (or old-buffer (find-file-noselect file)))
- (goto-char (point-min))
- (search-forward tag)
- (forward-line)
- (insert text)
- (let ((file-precious-flag t))
- (save-buffer))
- (unless old-buffer
- (kill-buffer (current-buffer)))))))
-
-(defun package--archive-contents-from-url (archive-url)
- "Parse archive-contents file at ARCHIVE-URL.
-Return the file contents, as a string, or nil if unsuccessful."
- (when archive-url
- (with-temp-buffer
- (ignore-errors
- (url-insert-file-contents (concat archive-url "archive-contents"))
- (package-read-from-string
- (buffer-substring-no-properties (point-min) (point-max)))))))
-
-(defun package--archive-contents-from-file ()
- "Parse the archive-contents at `package-archive-upload-base'."
- (let ((file (expand-file-name "archive-contents"
- package-archive-upload-base)))
- (if (not (file-exists-p file))
- ;; No existing archive-contents means a new archive.
- (list package-archive-version)
- (let ((dont-kill (find-buffer-visiting file)))
- (with-current-buffer (let ((find-file-visit-truename t))
- (find-file-noselect file))
- (prog1
- (package-read-from-string
- (buffer-substring-no-properties (point-min) (point-max)))
- (unless dont-kill
- (kill-buffer (current-buffer)))))))))
-
-(defun package-maint-add-news-item (title description archive-url)
- "Add a news item to the webpages associated with the package archive.
-TITLE is the title of the news item.
-DESCRIPTION is the text of the news item."
- (interactive "sTitle: \nsText: ")
- (package--update-file "elpa.rss"
- "<description>"
- (package--make-rss-entry title description archive-url))
- (package--update-file "news.html"
- "New entries go here"
- (package--make-html-entry title description)))
-
-(defun package--update-news (package version description archive-url)
- "Update the ELPA web pages when a package is uploaded."
- (package-maint-add-news-item (concat package " version " version)
- description
- archive-url))
-
-(declare-function lm-commentary "lisp-mnt" (&optional file))
-(defvar tar-data-buffer)
-
-(defun package-upload-buffer-internal (pkg-desc extension &optional archive-url)
- "Upload a package whose contents are in the current buffer.
-PKG-DESC is the `package-desc'.
-EXTENSION is the file extension, a string. It can be either
-\"el\" or \"tar\".
-
-The upload destination is given by `package-archive-upload-base'.
-If its value is invalid, prompt for a directory.
-
-Optional arg ARCHIVE-URL is the URL of the destination archive.
-If it is non-nil, compute the new \"archive-contents\" file
-starting from the existing \"archive-contents\" at that URL. In
-addition, if `package-update-news-on-upload' is non-nil, call
-`package--update-news' to add a news item at that URL.
-
-If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
-from the \"archive-contents\" at `package-archive-upload-base',
-if it exists."
- (let ((package-archive-upload-base package-archive-upload-base))
- ;; Check if `package-archive-upload-base' is valid.
- (when (or (not (stringp package-archive-upload-base))
- (equal package-archive-upload-base
- (custom--standard-value 'package-archive-upload-base)))
- (setq package-archive-upload-base
- (read-directory-name
- "Base directory for package archive: ")))
- (unless (file-directory-p package-archive-upload-base)
- (if (y-or-n-p (format "%s does not exist; create it? "
- package-archive-upload-base))
- (make-directory package-archive-upload-base t)
- (error "Aborted")))
- (save-excursion
- (save-restriction
- (let* ((file-type (package-desc-kind pkg-desc))
- (pkg-name (package-desc-name pkg-desc))
- (requires (package-desc-reqs pkg-desc))
- (desc (if (eq (package-desc-summary pkg-desc)
- package--default-summary)
- (read-string "Description of package: ")
- (package-desc-summary pkg-desc)))
- (split-version (package-desc-version pkg-desc))
- (commentary
- (pcase file-type
- ('single (lm-commentary))
- ('tar nil))) ;; FIXME: Get it from the README file.
- (extras (package-desc-extras pkg-desc))
- (pkg-version (package-version-join split-version))
- (pkg-buffer (current-buffer)))
-
- ;; `package-upload-file' will error if given a directory,
- ;; but we check it here as well just in case.
- (when (eq 'dir file-type)
- (user-error "Can't upload directory, tar it instead"))
- ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
- ;; from `package-archive-upload-base' otherwise.
- (let ((contents (or (package--archive-contents-from-url archive-url)
- (package--archive-contents-from-file)))
- (new-desc (package-make-ac-desc
- split-version requires desc file-type extras)))
- (if (> (car contents) package-archive-version)
- (error "Unrecognized archive version %d" (car contents)))
- (let ((elt (assq pkg-name (cdr contents))))
- (if elt
- (if (version-list-<= split-version
- (package--ac-desc-version (cdr elt)))
- (error "New package has smaller version: %s" pkg-version)
- (setcdr elt new-desc))
- (setq contents (cons (car contents)
- (cons (cons pkg-name new-desc)
- (cdr contents))))))
-
- ;; Now CONTENTS is the updated archive contents. Upload
- ;; this and the package itself. For now we assume ELPA is
- ;; writable via file primitives.
- (let ((print-level nil)
- (print-quoted t)
- (print-length nil))
- (write-region (concat (pp-to-string contents) "\n")
- nil
- (expand-file-name "archive-contents"
- package-archive-upload-base)))
-
- ;; If there is a commentary section, write it.
- (when commentary
- (write-region commentary nil
- (expand-file-name
- (concat (symbol-name pkg-name) "-readme.txt")
- package-archive-upload-base)))
-
- (set-buffer (if (eq file-type 'tar) tar-data-buffer pkg-buffer))
- (write-region (point-min) (point-max)
- (expand-file-name
- (format "%s-%s.%s" pkg-name pkg-version extension)
- package-archive-upload-base)
- nil nil nil 'excl)
-
- ;; Write a news entry.
- (and package-update-news-on-upload
- archive-url
- (package--update-news (format "%s.%s" pkg-name extension)
- pkg-version desc archive-url))
-
- ;; special-case "package": write a second copy so that the
- ;; installer can easily find the latest version.
- (if (eq pkg-name 'package)
- (write-region (point-min) (point-max)
- (expand-file-name
- (format "%s.%s" pkg-name extension)
- package-archive-upload-base)
- nil nil nil 'ask))))))))
-
-(defun package-upload-buffer ()
- "Upload the current buffer as a single-file Emacs Lisp package.
-If `package-archive-upload-base' does not specify a valid upload
-destination, prompt for one.
-Signal an error if the current buffer is not visiting a simple
-package (a \".el\" file)."
- (interactive)
- (save-excursion
- (save-restriction
- ;; Find the package in this buffer.
- (let ((pkg-desc (package-buffer-info)))
- (package-upload-buffer-internal pkg-desc "el")))))
-
-;;;###autoload
-(defun package-upload-file (file)
- "Upload the Emacs Lisp package FILE to the package archive.
-Interactively, prompt for FILE. The package is considered a
-single-file package if FILE ends in \".el\", and a multi-file
-package if FILE ends in \".tar\".
-Automatically extract package attributes and update the archive's
-contents list with this information.
-If `package-archive-upload-base' does not specify a valid upload
-destination, prompt for one. If the directory does not exist, it
-is created. The directory need not have any initial contents
-\(i.e., you can use this command to populate an initially empty
-archive)."
- (interactive "fPackage file name: ")
- (with-temp-buffer
- (insert-file-contents file)
- (let ((pkg-desc
- (cond
- ((string-match "\\.tar\\'" file)
- (tar-mode) (package-tar-file-info))
- ((string-match "\\.el\\'" file) (package-buffer-info))
- (t (error "Unrecognized extension `%s'"
- (file-name-extension file))))))
- (package-upload-buffer-internal pkg-desc (file-name-extension file)))))
-
-(defun package-gnus-summary-upload ()
- "Upload a package contained in the current *Article* buffer.
-This should be invoked from the gnus *Summary* buffer."
- (interactive)
- (with-current-buffer gnus-article-buffer
- (package-upload-buffer)))
-
-(provide 'package-x)
-
-;;; package-x.el ends here
"Status: Installed in ['`‘]signed-good-1.0/['’]."
nil t))))))
-
-\f
-;;; Tests for package-x features.
-
-(require 'package-x)
-
-(defvar package-x-test--single-archive-entry-1-3
- (cons 'simple-single
- (package-make-ac-desc '(1 3) nil
- "A single-file package with no dependencies"
- 'single
- '((:authors ("J. R. Hacker" . "jrh@example.com"))
- (:maintainer "J. R. Hacker" . "jrh@example.com")
- (:url . "http://doodles.au"))))
- "Expected contents of the archive entry from the \"simple-single\" package.")
-
-(defvar package-x-test--single-archive-entry-1-4
- (cons 'simple-single
- (package-make-ac-desc '(1 4) nil
- "A single-file package with no dependencies"
- 'single
- '((:authors ("J. R. Hacker" . "jrh@example.com"))
- (:maintainer "J. R. Hacker" . "jrh@example.com"))))
- "Expected contents of the archive entry from the updated \"simple-single\" package.")
-
-(ert-deftest package-x-test-upload-buffer ()
- "Test creating an \"archive-contents\" file"
- (with-package-test (:basedir (ert-resource-directory)
- :file "simple-single-1.3.el"
- :upload-base t)
- (package-upload-buffer)
- (should (file-exists-p (expand-file-name "archive-contents"
- package-archive-upload-base)))
- (should (file-exists-p (expand-file-name "simple-single-1.3.el"
- package-archive-upload-base)))
- (should (file-exists-p (expand-file-name "simple-single-readme.txt"
- package-archive-upload-base)))
-
- (let (archive-contents)
- (with-temp-buffer
- (insert-file-contents
- (expand-file-name "archive-contents"
- package-archive-upload-base))
- (setq archive-contents
- (package-read-from-string
- (buffer-substring (point-min) (point-max)))))
- (should (equal 1 (car archive-contents)))
- (should (equal 2 (length archive-contents)))
- (let ((pac (cadr archive-contents))
- (pac-sample package-x-test--single-archive-entry-1-3))
- (should (equal (pop pac) (pop pac-sample)))
- (dotimes (i 4)
- (should (equal (aref pac i) (aref pac-sample i))))
- ;; The `extras' field should contain at least the specified elements.
- (should (cl-every (lambda (sample-elem)
- (member sample-elem (aref pac 4)))
- (aref pac-sample 4)))))))
-
-(ert-deftest package-x-test-upload-new-version ()
- "Test uploading a new version of a package"
- (with-package-test (:basedir (ert-resource-directory)
- :file "simple-single-1.3.el"
- :upload-base t)
- (package-upload-buffer)
- (with-temp-buffer
- (insert-file-contents "newer-versions/simple-single-1.4.el")
- (package-upload-buffer))
-
- (let (archive-contents)
- (with-temp-buffer
- (insert-file-contents
- (expand-file-name "archive-contents"
- package-archive-upload-base))
- (setq archive-contents
- (package-read-from-string
- (buffer-substring (point-min) (point-max)))))
- (should (equal 1 (car archive-contents)))
- (should (equal 2 (length archive-contents)))
- (let ((pac (cadr archive-contents))
- (pac-sample package-x-test--single-archive-entry-1-4))
- (should (equal (pop pac) (pop pac-sample)))
- (dotimes (i 4)
- (should (equal (aref pac i) (aref pac-sample i))))
- ;; The `extras' field should contain at least the specified elements.
- (should (cl-every (lambda (sample-elem)
- (member sample-elem (aref pac 4)))
- (aref pac-sample 4)))))))
-
(ert-deftest package-test-get-deps ()
"Test `package--get-deps' with complex structures."
(let ((package-alist
projects / emacs.git / commitdiff