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.

2 files changed, 159 insertions, 108 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index e4d402afa76..5e9e134e746 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,19 @@
 2011-03-06  Chong Yidong  <cyd@stupidchicken.com>
 
+        * 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.
+
+2011-03-06  Chong Yidong  <cyd@stupidchicken.com>
+
         * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill,
         and move isearch-yank-line to M-s C-e (Bug#8183).
 
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index 61f23abf0a7..4de95f65702 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -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)))
-
-        ;; 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))))))
-
-          ;; 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")))
-
-          ;; 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")))
-
-          (set-buffer pkg-buffer)
-          (write-region (point-min) (point-max)
-                        (concat package-archive-upload-base
-                                file-name "-" pkg-version
-                                "." extension)
-                        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))
-
-          ;; 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)))))))
+  (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)))
+                (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
+                            (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 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))
+
+            ;; 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)