Usability improvements to commands in package-x.el.
* lisp/emacs-lisp/package-x.el (package-archive-upload-base): Make it a defcustom. (package--update-file): Doc fix. Accept relative file names. (package--archive-contents-from-file): Remove the argument, since it's necessarily always "archive-contents". (package-maint-add-news-item): Pass relative file name args to package--update-file. (package-upload-buffer-internal): Prompt for a destination if package-archive-upload-base is invalid. Create the directory if it does not exist. (package-upload-buffer, package-upload-file): Doc fix.
This commit is contained in:
Chong Yidong
parent
78f5433f6b
commit
5c69cb2ce3
2 changed files with 153 additions and 102 deletions
|
|
@ -27,21 +27,41 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file currently contains parts of the package system most
|
||||
;; people won't need, such as package uploading.
|
||||
;; 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)
|
||||
|
||||
;; Note that this only works if you have the password, which you
|
||||
;; probably don't :-).
|
||||
(defvar package-archive-upload-base nil
|
||||
"Base location for uploading to package archive.")
|
||||
(defcustom package-archive-upload-base "/path/to/archive"
|
||||
"The base location of the archive to which packages are uploaded.
|
||||
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 package upload should also update NEWS and RSS feeds.")
|
||||
"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."
|
||||
|
|
@ -75,13 +95,18 @@
|
|||
title " - " (package--encode text)
|
||||
" </li>\n"))
|
||||
|
||||
(defun package--update-file (file location text)
|
||||
(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 location)
|
||||
(search-forward tag)
|
||||
(forward-line)
|
||||
(insert text)
|
||||
(let ((file-precious-flag t))
|
||||
|
|
@ -105,30 +130,31 @@ Return the file contents, as a string, or nil if unsuccessful."
|
|||
(buffer-substring-no-properties (point-min) (point-max)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(defun package--archive-contents-from-file (file)
|
||||
"Parse the given archive-contents file."
|
||||
(if (not (file-exists-p file))
|
||||
;; no existing archive-contents, possibly a new ELPA repo.
|
||||
(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--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 ELPA web pages.
|
||||
"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.
|
||||
You need administrative access to ELPA to use this."
|
||||
DESCRIPTION is the text of the news item."
|
||||
(interactive "sTitle: \nsText: ")
|
||||
(package--update-file (concat package-archive-upload-base "elpa.rss")
|
||||
(package--update-file "elpa.rss"
|
||||
"<description>"
|
||||
(package--make-rss-entry title description archive-url))
|
||||
(package--update-file (concat package-archive-upload-base "news.html")
|
||||
(package--update-file "news.html"
|
||||
"New entries go here"
|
||||
(package--make-html-entry title description)))
|
||||
|
||||
|
|
@ -144,8 +170,8 @@ PKG-INFO is the package info, see `package-buffer-info'.
|
|||
EXTENSION is the file extension, a string. It can be either
|
||||
\"el\" or \"tar\".
|
||||
|
||||
The variable `package-archive-upload-base' specifies the upload
|
||||
destination. If this is nil, signal an error.
|
||||
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
|
||||
|
|
@ -156,85 +182,97 @@ addition, if `package-update-news-on-upload' is non-nil, call
|
|||
If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
|
||||
from the \"archive-contents\" at `package-archive-upload-base',
|
||||
if it exists."
|
||||
(unless package-archive-upload-base
|
||||
(error "No destination specified in `package-archive-upload-base'"))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(let* ((file-type (cond
|
||||
((equal extension "el") 'single)
|
||||
((equal extension "tar") 'tar)
|
||||
(t (error "Unknown extension `%s'" extension))))
|
||||
(file-name (aref pkg-info 0))
|
||||
(pkg-name (intern file-name))
|
||||
(requires (aref pkg-info 1))
|
||||
(desc (if (string= (aref pkg-info 2) "")
|
||||
(read-string "Description of package: ")
|
||||
(aref pkg-info 2)))
|
||||
(pkg-version (aref pkg-info 3))
|
||||
(commentary (aref pkg-info 4))
|
||||
(split-version (version-to-list pkg-version))
|
||||
(pkg-buffer (current-buffer)))
|
||||
(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))
|
||||
(eq package-archive-upload-base
|
||||
(car-safe
|
||||
(get 'package-archive-upload-base 'standard-value))))
|
||||
(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 (cond
|
||||
((equal extension "el") 'single)
|
||||
((equal extension "tar") 'tar)
|
||||
(t (error "Unknown extension `%s'" extension))))
|
||||
(file-name (aref pkg-info 0))
|
||||
(pkg-name (intern file-name))
|
||||
(requires (aref pkg-info 1))
|
||||
(desc (if (string= (aref pkg-info 2) "")
|
||||
(read-string "Description of package: ")
|
||||
(aref pkg-info 2)))
|
||||
(pkg-version (aref pkg-info 3))
|
||||
(commentary (aref pkg-info 4))
|
||||
(split-version (version-to-list pkg-version))
|
||||
(pkg-buffer (current-buffer)))
|
||||
|
||||
;; 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
|
||||
(concat package-archive-upload-base
|
||||
"archive-contents"))))
|
||||
(new-desc (vector split-version requires desc file-type)))
|
||||
(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-desc-vers (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))))))
|
||||
;; 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 (vector split-version requires desc file-type)))
|
||||
(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-desc-vers (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-length nil))
|
||||
(write-region (concat (pp-to-string contents) "\n")
|
||||
nil
|
||||
(concat package-archive-upload-base
|
||||
"archive-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-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
|
||||
(concat package-archive-upload-base
|
||||
(symbol-name pkg-name) "-readme.txt")))
|
||||
;; 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 pkg-buffer)
|
||||
(write-region (point-min) (point-max)
|
||||
(concat package-archive-upload-base
|
||||
file-name "-" pkg-version
|
||||
"." extension)
|
||||
nil nil nil 'excl)
|
||||
(set-buffer pkg-buffer)
|
||||
(write-region (point-min) (point-max)
|
||||
(expand-file-name
|
||||
(concat file-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 (concat file-name "." extension)
|
||||
pkg-version desc archive-url))
|
||||
;; Write a news entry.
|
||||
(and package-update-news-on-upload
|
||||
archive-url
|
||||
(package--update-news (concat file-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 (string= file-name "package")
|
||||
(write-region (point-min) (point-max)
|
||||
(concat package-archive-upload-base
|
||||
file-name "." extension)
|
||||
nil nil nil 'ask)))))))
|
||||
;; special-case "package": write a second copy so that the
|
||||
;; installer can easily find the latest version.
|
||||
(if (string= file-name "package")
|
||||
(write-region (point-min) (point-max)
|
||||
(expand-file-name
|
||||
(concat file-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.
|
||||
The variable `package-archive-upload-base' specifies the upload
|
||||
destination."
|
||||
If `package-archive-upload-base' does not specify a valid upload
|
||||
destination, prompt for one."
|
||||
(interactive)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
|
|
@ -247,9 +285,8 @@ destination."
|
|||
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\".
|
||||
|
||||
The variable `package-archive-upload-base' specifies the upload
|
||||
destination."
|
||||
If `package-archive-upload-base' does not specify a valid upload
|
||||
destination, prompt for one."
|
||||
(interactive "fPackage file name: ")
|
||||
(with-temp-buffer
|
||||
(insert-file-contents-literally file)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue