From 07366aa9fbc5bb4ef272b5ad843b8b8d1f70461b Mon Sep 17 00:00:00 2001 From: Phil Hagelberg Date: Mon, 12 Jul 2010 22:10:40 -0700 Subject: [PATCH 1/5] 2010-07-12 Phil Hagelberg * emacs-lisp/package.el: Support multiple archive sources from which to fetch packages. Replace package-archive-base with package-archives alist. --- lisp/emacs-lisp/package.el | 136 ++++++++++++++++++++++++++++---------------- 1 files changed, 87 insertions(+), 49 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c603544..0278149 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -217,15 +217,19 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (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 (names and URLs) from which to fetch. +The default points to the GNU package repository. +Note that some code in package.el assumes that this is an http: URL." + :type '(alist :key-type (string :tag "Archive name") + :value-type (string :tag "Archive URL")) + :group 'package) (defconst package-archive-version 1 "Version number of the package archive understood by this file. Lower version numbers than this will probably be understood as well.") +;; TODO: this doesn't match the version in the comments header (defconst package-el-version "1.0" "Version of package.el.") @@ -234,8 +238,9 @@ Lower version numbers than this will probably be understood as well.") "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.") (defcustom package-user-dir (locate-user-emacs-file "elpa") "Directory containing the user's Emacs Lisp packages. @@ -361,16 +366,14 @@ E.g., if given \"quux-23.0\", will return \"quux\"" (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. + "Load the description file in directory DIR for a PACKAGE. 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)))) + (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. @@ -670,7 +673,7 @@ It will move point to somewhere in the headers." (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-for name) (symbol-name name) "-" version ".el")))) (with-current-buffer buffer (package-handle-response) @@ -683,7 +686,7 @@ It will move point to somewhere in the headers." (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-for name) (symbol-name name) "-" version ".tar")))) (with-current-buffer tar-buffer (package-handle-response) @@ -772,16 +775,13 @@ Will throw an error if the archive version is too new." (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 +793,36 @@ Throw an error if the archive version is too new." (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 they exist. + +Will set `package-archive-contents' and `package--builtins' if +successful. Will throw an error if the archive version is too +new." + (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 needed. + +Adds the archive from which it came to the end of the package vector." + (let* ((package-name (car package)) + (package-version (aref (cdr package) 0)) + (package-with-archive (cons (car package) + (vconcat (cdr package) (vector archive)))) + (existing-package (cdr (assq package-name package-archive-contents)))) + (when (or (not existing-package) + (package-version-compare package-version + (aref existing-package 0) '>)) + (add-to-list 'package-archive-contents package-with-archive)))) + (defun package-download-transaction (transaction) "Download and install all the packages in the given transaction." (dolist (elt transaction) @@ -817,25 +847,22 @@ Throw an error if the archive version is too new." (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 the archive sites, see `package-archives'." (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))))) + (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" - (symbol-name name))) + (symbol-name name))) (let ((transaction - (package-compute-transaction (list name) - (package-desc-reqs (cdr pkg-desc))))) + (package-compute-transaction (list name) + (package-desc-reqs (cdr pkg-desc))))) (package-download-transaction transaction))) ;; Try to activate it. (package-initialize)) @@ -996,19 +1023,30 @@ The file can either be a tar file or an Emacs Lisp file." ;; 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)))) - (with-current-buffer buffer +(defun package-archive-for (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 a single archive file and cache it locally. + +Downloads the archive index from ARCHIVE and stores it in FILE." + (let* ((archive-name (car archive)) + (archive-url (cdr archive)) + (buffer (url-retrieve-synchronously (concat archive-url file)))) + (save-excursion + (set-buffer buffer) (package-handle-response) (re-search-forward "^$" nil 'move) (forward-char) (delete-region (point-min) (point)) + (make-directory (concat (file-name-as-directory package-user-dir) + "archives/" archive-name) t) (setq buffer-file-name (concat (file-name-as-directory package-user-dir) - file)) + "archives/" archive-name "/" file)) (let ((version-control 'never)) - (save-buffer)) + (save-buffer)) (kill-buffer buffer)))) (defun package-refresh-contents () @@ -1019,9 +1057,9 @@ download." (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 +1068,7 @@ The variable `package-load-list' controls which packages to load." (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)))) @@ -1308,7 +1346,7 @@ 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 + (buffer (url-retrieve-synchronously (concat (package-archive-for pkg-name) pkg-name "-readme.txt")))) (with-current-buffer buffer -- 1.7.0.4