From: Stefan Kangas Date: Wed, 12 Feb 2025 16:32:33 +0000 (+0100) Subject: Move package-x.el to lisp/obsolete X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=58fcdd0470151b03a9c8f06f6e4c378196ac743a;p=emacs.git Move package-x.el to lisp/obsolete * lisp/emacs-lisp/package-x.el: Move from here... * lisp/obsolete/package-x.el: ...to here. (Bug#76194) (cherry picked from commit f7867e685659ede4fafa8691381cfe08becc6ad6) --- diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el deleted file mode 100644 index 68a62df90f7..00000000000 --- a/lisp/emacs-lisp/package-x.el +++ /dev/null @@ -1,321 +0,0 @@ -;;; package-x.el --- Package extras -*- lexical-binding: t; -*- - -;; Copyright (C) 2007-2025 Free Software Foundation, Inc. - -;; Author: Tom Tromey -;; Created: 10 Mar 2007 -;; Keywords: tools -;; Package: package - -;; 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: - -;; 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 "\n" - "" (package--encode title) "\n" - ;; FIXME: should have a link in the web page. - "" archive-url "news.html\n" - "" (package--encode text) "\n" - "" date-string "\n" - "\n"))) - -(defun package--make-html-entry (title text) - (concat "
  • " (format-time-string "%B %e") " - " - title " - " (package--encode text) - "
    • \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" - "" - (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 diff --git a/lisp/obsolete/package-x.el b/lisp/obsolete/package-x.el new file mode 100644 index 00000000000..68a62df90f7 --- /dev/null +++ b/lisp/obsolete/package-x.el @@ -0,0 +1,321 @@ +;;; package-x.el --- Package extras -*- lexical-binding: t; -*- + +;; Copyright (C) 2007-2025 Free Software Foundation, Inc. + +;; Author: Tom Tromey +;; Created: 10 Mar 2007 +;; Keywords: tools +;; Package: package + +;; 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: + +;; 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 "\n" + "" (package--encode title) "\n" + ;; FIXME: should have a link in the web page. + "" archive-url "news.html\n" + "" (package--encode text) "\n" + "" date-string "\n" + "\n"))) + +(defun package--make-html-entry (title text) + (concat "
  • " (format-time-string "%B %e") " - " + title " - " (package--encode text) + "
    • \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" + "" + (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