[Emacs-diffs] /srv/bzr/emacs/trunk r100925: Add support for non-default package repositories.

[Chong Yidong]

------------------------------------------------------------
revno: 100925
author: Phil Hagelberg <address@hidden>
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Wed 2010-07-28 14:54:42 -0400
message:
  Add support for non-default package repositories.
  
  * lisp/emacs-lisp/package.el (package-archive-base): Var deleted.
  (package-archives): New variable.
  (package-archive-contents): Doc fix.
  (package-load-descriptor): Do nothing if descriptor file is
  missing.
  (package--write-file-no-coding): New function.
  (package-unpack-single): Use it.
  (package-archive-id): New function.
  (package-download-single, package-download-tar)
  (package-menu-view-commentary): Use it.
  (package-installed-p): Make second argument optional.
  (package-read-all-archive-contents): New function.
  (package-initialize): Use it.
  (package-read-archive-contents): Add ARCHIVE argument.
  (package--add-to-archive-contents): New function.
  (package-install): Don't call package-read-archive-contents.
  (package--download-one-archive): Store archive file in a
  subdirectory of package-user-dir.
  (package-menu-execute): Remove spurious line movement.
  
  * lisp/emacs-lisp/package.el (package-load-list, package-archives)
  (package-archive-contents, package-user-dir)
  (package-directory-list, package--builtins, package-alist)
  (package-activated-list, package-obsolete-alist): Mark as risky.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/package.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2010-07-28 17:34:51 +0000
+++ b/lisp/ChangeLog    2010-07-28 18:54:42 +0000
@@ -1,3 +1,33 @@
+2010-07-28  Chong Yidong  <address@hidden>
+
+       * emacs-lisp/package.el (package-load-list, package-archives)
+       (package-archive-contents, package-user-dir)
+       (package-directory-list, package--builtins, package-alist)
+       (package-activated-list, package-obsolete-alist): Mark as risky.
+
+2010-07-28  Phil Hagelberg  <address@hidden>
+
+       Add support for non-default package repositories.
+       * emacs-lisp/package.el (package-archive-base): Var deleted.
+       (package-archives): New variable.
+       (package-archive-contents): Doc fix.
+       (package-load-descriptor): Do nothing if descriptor file is
+       missing.
+       (package--write-file-no-coding): New function.
+       (package-unpack-single): Use it.
+       (package-archive-id): New function.
+       (package-download-single, package-download-tar)
+       (package-menu-view-commentary): Use it.
+       (package-installed-p): Make second argument optional.
+       (package-read-all-archive-contents): New function.
+       (package-initialize): Use it.
+       (package-read-archive-contents): Add ARCHIVE argument.
+       (package--add-to-archive-contents): New function.
+       (package-install): Don't call package-read-archive-contents.
+       (package--download-one-archive): Store archive file in a
+       subdirectory of package-user-dir.
+       (package-menu-execute): Remove spurious line movement.
+
 2010-07-28  Jan Djärv  <address@hidden>
 
        * cus-start.el (tool-bar-style): Add text-image-horiz.

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2010-06-20 04:55:14 +0000
+++ b/lisp/emacs-lisp/package.el        2010-07-28 18:54:42 +0000
@@ -43,9 +43,6 @@
 ;; currently register any of these, so this feature does not actually
 ;; work.)
 
-;; This code supports a single package repository, ELPA.  All packages
-;; must be registered there.
-
 ;; A package is described by its name and version.  The distribution
 ;; format is either  a tar file or a single .el file.
 
@@ -55,11 +52,13 @@
 ;; which consists of a call to define-package.  It may also contain a
 ;; "dir" file and the info files it references.
 
-;; A .el file will be named "NAME-VERSION.el" in ELPA, but will be
+;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
 ;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
 
-;; The downloader will download all dependent packages.  It will also
-;; byte-compile the package's lisp at install time.
+;; The downloader downloads all dependent packages.  By default,
+;; packages come from the official GNU sources, but others may be
+;; added by customizing the `package-archives' alist.  Packages get
+;; byte-compiled at install time.
 
 ;; At activation time we will set up the load-path and the info path,
 ;; and we will load the package's autoloads.  If a package's
@@ -207,6 +206,7 @@
  Hence, the package is \"held\" at that version.
 If VERSION is nil, the package is not loaded (it is \"disabled\")."
   :type '(repeat symbol)
+  :risky t
   :group 'package
   :version "24.1")
 
@@ -217,10 +217,16 @@
 (declare-function lm-commentary "lisp-mnt" (&optional file))
 (declare-function dired-delete-file "dired" (file &optional recursive trash))
 
-(defconst package-archive-base "http://elpa.gnu.org/packages/";
-  "Base URL for the Emacs Lisp Package Archive (ELPA).
-Ordinarily you should not need to change this.
-Note that some code in package.el assumes that this is an http: URL.")
+(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/";))
+  "An alist of archives from which to fetch.
+The default value points to the GNU Emacs package repository.
+Each element has the form (ID . URL), where ID is an identifier
+string for an archive and URL is a http: URL (a string)."
+  :type '(alist :key-type (string :tag "Archive name")
+                :value-type (string :tag "Archive URL"))
+  :risky t
+  :group 'package
+  :version "24.1")
 
 (defconst package-archive-version 1
   "Version number of the package archive understood by this file.
@@ -234,8 +240,10 @@
   "Cache of the contents of the Emacs Lisp Package Archive.
 This is an alist mapping package names (symbols) to package
 descriptor vectors.  These are like the vectors for `package-alist'
-but have an extra entry which is 'tar for tar packages and
-'single for single-file packages.")
+but have extra entries: one which is 'tar for tar packages and
+'single for single-file packages, and one which is the name of
+the archive from which it came.")
+(put 'package-archive-contents 'risky-local-variable t)
 
 (defcustom package-user-dir (locate-user-emacs-file "elpa")
   "Directory containing the user's Emacs Lisp packages.
@@ -243,6 +251,7 @@
 Apart from this directory, Emacs also looks for system-wide
 packages in `package-directory-list'."
   :type 'directory
+  :risky t
   :group 'package
   :version "24.1")
 
@@ -259,6 +268,7 @@
 These directories contain packages intended for system-wide; in
 contrast, `package-user-dir' contains packages for personal use."
   :type '(repeat directory)
+  :risky t
   :group 'package
   :version "24.1")
 
@@ -293,6 +303,7 @@
               (bubbles . [(0 5) nil "Puzzle game for Emacs."])))))
   "Alist of all built-in packages.
 Maps the package name to a vector [VERSION REQS DOCSTRING].")
+(put 'package--builtins 'risky-local-variable t)
 
 (defvar package-alist package--builtins
   "Alist of all packages available for activation.
@@ -301,15 +312,18 @@
 The value is generated by `package-load-descriptor', usually
 called via `package-initialize'.  For user customizations of
 which packages to load/activate, see `package-load-list'.")
+(put 'package-archive-contents 'risky-local-variable t)
 
 (defvar package-activated-list
   (mapcar #'car package-alist)
   "List of the names of currently activated packages.")
+(put 'package-activated-list 'risky-local-variable t)
 
 (defvar package-obsolete-alist nil
   "Representation of obsolete packages.
 Like `package-alist', but maps package name to a second alist.
 The inner alist is keyed by version.")
+(put 'package-obsolete-alist 'risky-local-variable t)
 
 (defconst package-subdirectory-regexp
   "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
@@ -361,16 +375,14 @@
       (match-string 1 dirname)))
 
 (defun package-load-descriptor (dir package)
-  "Load the description file for a package.
-DIR is the directory in which to find the package subdirectory,
-and PACKAGE is the name of the package subdirectory.
-Return nil if the package could not be found."
-  (let ((pkg-dir (expand-file-name package dir)))
-    (if (file-directory-p pkg-dir)
-       (load (expand-file-name (concat (package-strip-version package)
-                                       "-pkg")
-                               pkg-dir)
-             nil t))))
+  "Load the description file in directory DIR for package PACKAGE."
+  (let* ((pkg-dir (expand-file-name package dir))
+        (pkg-file (expand-file-name
+                   (concat (package-strip-version package) "-pkg")
+                   pkg-dir)))
+    (when (and (file-directory-p pkg-dir)
+              (file-exists-p (concat pkg-file ".el")))
+      (load pkg-file nil t))))
 
 (defun package-load-all-descriptors ()
   "Load descriptors for installed Emacs Lisp packages.
@@ -613,20 +625,23 @@
       (let ((load-path (cons pkg-dir load-path)))
        (byte-recompile-directory pkg-dir 0 t)))))
 
+(defun package--write-file-no-coding (file-name excl)
+  (let ((buffer-file-coding-system 'no-conversion))
+    (write-region (point-min) (point-max) file-name nil nil nil excl)))
+
 (defun package-unpack-single (file-name version desc requires)
   "Install the contents of the current buffer as a package."
   ;; Special case "package".
   (if (string= file-name "package")
-      (write-region (point-min) (point-max)
-                   (expand-file-name (concat file-name ".el")
-                                     package-user-dir)
-                   nil nil nil nil)
+      (package--write-file-no-coding
+       (expand-file-name (concat file-name ".el") package-user-dir)
+       nil)
     (let* ((pkg-dir  (expand-file-name (concat file-name "-" version)
                                       package-user-dir))
           (el-file  (expand-file-name (concat file-name ".el") pkg-dir))
           (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
       (make-directory pkg-dir t)
-      (write-region (point-min) (point-max) el-file nil nil nil 'excl)
+      (package--write-file-no-coding el-file 'excl)
       (let ((print-level nil)
            (print-length nil))
        (write-region
@@ -670,7 +685,7 @@
 (defun package-download-single (name version desc requires)
   "Download and install a single-file package."
   (let ((buffer (url-retrieve-synchronously
-                (concat package-archive-base
+                (concat (package-archive-id name)
                         (symbol-name name) "-" version ".el"))))
     (with-current-buffer buffer
       (package-handle-response)
@@ -683,7 +698,7 @@
 (defun package-download-tar (name version)
   "Download and install a tar package."
   (let ((tar-buffer (url-retrieve-synchronously
-                    (concat package-archive-base
+                    (concat (package-archive-id name)
                             (symbol-name name) "-" version ".tar"))))
     (with-current-buffer tar-buffer
       (package-handle-response)
@@ -692,12 +707,12 @@
       (package-unpack name version)
       (kill-buffer tar-buffer))))
 
-(defun package-installed-p (package version)
+(defun package-installed-p (package &optional min-version)
   (let ((pkg-desc (assq package package-alist)))
     (and pkg-desc
-        (package-version-compare version
+        (package-version-compare min-version
                                  (package-desc-vers (cdr pkg-desc))
-                                 '>=))))
+                                 '<=))))
 
 (defun package-compute-transaction (result requirements)
   (dolist (elt requirements)
@@ -772,16 +787,13 @@
                       (car contents) package-archive-version))
            (cdr contents))))))
 
-(defun package-read-archive-contents ()
+(defun package-read-all-archive-contents ()
   "Re-read `archive-contents' and `builtin-packages', if they exist.
 Set `package-archive-contents' and `package--builtins' if successful.
 Throw an error if the archive version is too new."
-  (let ((archive-contents (package--read-archive-file "archive-contents"))
-       (builtins (package--read-archive-file "builtin-packages")))
-    (if archive-contents
-       ;; Version 1 of 'archive-contents' is identical to our
-       ;; internal representation.
-       (setq package-archive-contents archive-contents))
+  (dolist (archive package-archives)
+    (package-read-archive-contents (car archive)))
+  (let ((builtins (package--read-archive-file "builtin-packages")))
     (if builtins
        ;; Version 1 of 'builtin-packages' is a list where the car is
        ;; a split emacs version and the cdr is an alist suitable for
@@ -793,6 +805,33 @@
                  (if (package-version-compare our-version (car elt) '>=)
                      (setq result (append (cdr elt) result)))))))))
 
+(defun package-read-archive-contents (archive)
+  "Re-read `archive-contents' and `builtin-packages' for ARCHIVE.
+If successful, set `package-archive-contents' and `package--builtins'.
+If the archive version is too new, signal an error."
+  (let ((archive-contents (package--read-archive-file
+                           (concat "archives/" archive
+                                   "/archive-contents"))))
+    (if archive-contents
+        ;; Version 1 of 'archive-contents' is identical to our
+        ;; internal representation.
+        ;; TODO: merge archive lists
+        (dolist (package archive-contents)
+          (package--add-to-archive-contents package archive)))))
+
+(defun package--add-to-archive-contents (package archive)
+  "Add the PACKAGE from the given ARCHIVE if necessary.
+Also, add the originating archive to the end of the package vector."
+  (let* ((name    (car package))
+         (version (aref (cdr package) 0))
+         (entry   (cons (car package)
+                       (vconcat (cdr package) (vector archive))))
+         (existing-package (cdr (assq name package-archive-contents))))
+    (when (or (not existing-package)
+              (package-version-compare version
+                                       (aref existing-package 0) '>))
+      (add-to-list 'package-archive-contents entry))))
+
 (defun package-download-transaction (transaction)
   "Download and install all the packages in the given transaction."
   (dolist (elt transaction)
@@ -817,26 +856,21 @@
 (defun package-install (name)
   "Install the package named NAME.
 Interactively, prompt for the package name.
-The package is found on the archive site, see `package-archive-base'."
+The package is found on one of the archives in `package-archive-base'."
   (interactive
-   (list (progn
-          ;; Make sure we're using the most recent download of the
-          ;; archive.  Maybe we should be updating the archive first?
-          (package-read-archive-contents)
-          (intern (completing-read "Install package: "
-                                   (mapcar (lambda (elt)
-                                             (cons (symbol-name (car elt))
-                                                   nil))
-                                           package-archive-contents)
-                                   nil t)))))
+   (list (intern (completing-read "Install package: "
+                                 (mapcar (lambda (elt)
+                                           (cons (symbol-name (car elt))
+                                                 nil))
+                                         package-archive-contents)
+                                 nil t))))
   (let ((pkg-desc (assq name package-archive-contents)))
     (unless pkg-desc
-      (error "Package '%s' not available for installation"
+      (error "Package '%s' is not available for installation"
             (symbol-name name)))
-    (let ((transaction
-          (package-compute-transaction (list name)
-                                       (package-desc-reqs (cdr pkg-desc)))))
-      (package-download-transaction transaction)))
+    (package-download-transaction
+     (package-compute-transaction (list name)
+                                 (package-desc-reqs (cdr pkg-desc)))))
   ;; Try to activate it.
   (package-initialize))
 
@@ -996,20 +1030,28 @@
                     ;; FIXME: query user?
                     'always))
 
-(defun package--download-one-archive (file)
-  "Download a single archive file and cache it locally."
-  (let ((buffer (url-retrieve-synchronously
-                (concat package-archive-base file))))
+(defun package-archive-id (name)
+  "Return the archive containing the package NAME."
+  (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
+    (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
+
+(defun package--download-one-archive (archive file)
+  "Download an archive file FILE from ARCHIVE, and cache it locally."
+  (let* ((archive-name (car archive))
+         (archive-url  (cdr archive))
+        (dir (expand-file-name "archives" package-user-dir))
+        (dir (expand-file-name archive-name dir))
+         (buffer (url-retrieve-synchronously (concat archive-url file))))
     (with-current-buffer buffer
       (package-handle-response)
       (re-search-forward "^$" nil 'move)
       (forward-char)
       (delete-region (point-min) (point))
-      (setq buffer-file-name (concat (file-name-as-directory package-user-dir)
-                                    file))
+      (make-directory dir t)
+      (setq buffer-file-name (expand-file-name file dir))
       (let ((version-control 'never))
-       (save-buffer))
-      (kill-buffer buffer))))
+       (save-buffer)))
+    (kill-buffer buffer)))
 
 (defun package-refresh-contents ()
   "Download the ELPA archive description if needed.
@@ -1019,9 +1061,9 @@
   (interactive)
   (unless (file-exists-p package-user-dir)
     (make-directory package-user-dir t))
-  (package--download-one-archive "archive-contents")
-  (package--download-one-archive "builtin-packages")
-  (package-read-archive-contents))
+  (dolist (archive package-archives)
+    (package--download-one-archive archive "archive-contents"))
+  (package-read-all-archive-contents))
 
 ;;;###autoload
 (defun package-initialize ()
@@ -1030,7 +1072,7 @@
   (interactive)
   (setq package-obsolete-alist nil)
   (package-load-all-descriptors)
-  (package-read-archive-contents)
+  (package-read-all-archive-contents)
   ;; Try to activate all our packages.
   (mapc (lambda (elt)
          (package-activate (car elt) (package-desc-vers (cdr elt))))
@@ -1306,11 +1348,12 @@
 For single-file packages, shows the commentary section from the header.
 For larger packages, shows the README file."
   (interactive)
-  (let* (start-point ok
-        (pkg-name (package-menu-get-package))
-        (buffer (url-retrieve-synchronously (concat package-archive-base
-                                                    pkg-name
-                                                    "-readme.txt"))))
+  (let* ((pkg-name (package-menu-get-package))
+        (buffer (url-retrieve-synchronously
+                 (concat (package-archive-id pkg-name)
+                         pkg-name
+                         "-readme.txt")))
+        start-point ok)
     (with-current-buffer buffer
       ;; FIXME: it would be nice to work with any URL type.
       (setq start-point url-http-end-of-headers)
@@ -1322,7 +1365,7 @@
          (insert "Package information for " pkg-name "\n\n")
          (if ok
              (insert-buffer-substring buffer start-point)
-           (insert "This package does not have a README file or commentary 
comment.\n"))
+           (insert "This package lacks a README file or commentary.\n"))
          (goto-char (point-min))
          (view-mode)))
       (display-buffer new-buffer t))))
@@ -1355,7 +1398,6 @@
 Emacs."
   (interactive)
   (goto-char (point-min))
-  (forward-line 2)
   (while (not (eobp))
     (let ((cmd (char-after))
          (pkg-name (package-menu-get-package))