[Emacs-diffs] /srv/bzr/emacs/trunk r103566: Usability improvements to commands in package-x.el.

[Chong Yidong]

------------------------------------------------------------
revno: 103566
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Sun 2011-03-06 15:19:39 -0500
message:
  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.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/package-x.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-03-06 18:24:11 +0000
+++ b/lisp/ChangeLog    2011-03-06 20:19:39 +0000
@@ -1,5 +1,19 @@
 2011-03-06  Chong Yidong  <address@hidden>
 
+       * 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  <address@hidden>
+
        * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill,
        and move isearch-yank-line to M-s C-e (Bug#8183).
 

=== modified file 'lisp/emacs-lisp/package-x.el'
--- a/lisp/emacs-lisp/package-x.el      2011-02-25 18:30:00 +0000
+++ b/lisp/emacs-lisp/package-x.el      2011-03-06 20:19:39 +0000
@@ -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:address@hidden:/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 @@
                (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 @@
 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 @@
 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 @@
 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)