changeset 109567:0fc9f7a0d319

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.

--- a/lisp/ChangeLog	Wed Jul 28 19:34:51 2010 +0200
+++ b/lisp/ChangeLog	Wed Jul 28 14:54:42 2010 -0400
@@ -1,3 +1,33 @@
[phone]  Chong Yidong  <[e-mail]>
+
+	* 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.
+
[phone]  Phil Hagelberg  <[e-mail]>
+
+	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  <[e-mail]>
 
 	* cus-start.el (tool-bar-style): Add text-image-horiz.

--- a/lisp/emacs-lisp/package.el	Wed Jul 28 19:34:51 2010 +0200
+++ b/lisp/emacs-lisp/package.el	Wed Jul 28 14:54:42 2010 -0400
@@ -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))