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)