Commit f561e49a authored by Chong Yidong's avatar Chong Yidong

Allow specifying local ELPA mirrors in package-archives.

* emacs-lisp/package.el (package-archives): Accept either ordinary
directory names, in addition to HTTP URLs.
(package--with-work-buffer): New macro.   Handle normal directories.
(package-handle-response): Don't display the failing buffer.
(package-download-single, package-download-tar)
(package--download-one-archive): Use package--with-work-buffer.
(package-archive-base): Rename from package-archive-url.
parent ad7d6ecb
2011-03-06 Chong Yidong <cyd@stupidchicken.com>
* emacs-lisp/package.el (package-archives): Accept either ordinary
directory names, in addition to HTTP URLs.
(package--with-work-buffer): New macro. Handle normal directories.
(package-handle-response): Don't display the failing buffer.
(package-download-single, package-download-tar)
(package--download-one-archive): Use package--with-work-buffer.
(package-archive-base): Rename from package-archive-url.
2011-03-06 Glenn Morris <rgm@gnu.org>
* generic-x.el (generic-unix-modes): Add xmodmap-generic-mode.
......
......@@ -220,10 +220,15 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")."
(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)."
Each element has the form (ID . LOCATION).
ID is an archive name, as a string.
LOCATION specifies the base location for the archive.
If it starts with \"http:\", it is treated as a HTTP URL;
otherwise it should be an absolute directory name.
(Other types of URL are currently not supported.)"
:type '(alist :key-type (string :tag "Archive name")
:value-type (string :tag "Archive URL"))
:value-type (string :tag "URL or directory name"))
:risky t
:group 'package
:version "24.1")
......@@ -617,8 +622,36 @@ Otherwise it uses an external `tar' program.
(let ((load-path (cons pkg-dir load-path)))
(byte-recompile-directory pkg-dir 0 t)))))
(defmacro package--with-work-buffer (location file &rest body)
"Run BODY in a buffer containing the contents of FILE at LOCATION.
LOCATION is the base location of a package archive, and should be
one of the URLs (or file names) specified in `package-archives'.
FILE is the name of a file relative to that base location.
This macro retrieves FILE from LOCATION into a temporary buffer,
and evaluates BODY while that buffer is current. This work
buffer is killed afterwards. Return the last value in BODY."
`(let* ((http (string-match "\\`http:" ,location))
(buffer
(if http
(url-retrieve-synchronously (concat ,location ,file))
(generate-new-buffer "*package work buffer*"))))
(prog1
(with-current-buffer buffer
(if http
(progn (package-handle-response)
(re-search-forward "^$" nil 'move)
(forward-char)
(delete-region (point-min) (point)))
(unless (file-name-absolute-p ,location)
(error "Archive location %s is not an absolute file name"
,location))
(insert-file-contents (expand-file-name ,file ,location)))
,@body)
(kill-buffer buffer))))
(defun package-handle-response ()
"Handle the response from the server.
"Handle the response from a `url-retrieve-synchronously' call.
Parse the HTTP response and throw if an error occurred.
The url package seems to require extra processing for this.
This should be called in a `save-excursion', in the download buffer.
......@@ -627,7 +660,6 @@ It will move point to somewhere in the headers."
(require 'url-http)
(let ((response (url-http-parse-response)))
(when (or (< response 200) (>= response 300))
(display-buffer (current-buffer))
(error "Error during download request:%s"
(buffer-substring-no-properties (point) (progn
(end-of-line)
......@@ -635,28 +667,17 @@ 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-url name)
(symbol-name name) "-" version ".el"))))
(with-current-buffer buffer
(package-handle-response)
(re-search-forward "^$" nil 'move)
(forward-char)
(delete-region (point-min) (point))
(package-unpack-single (symbol-name name) version desc requires)
(kill-buffer buffer))))
(let ((location (package-archive-base name))
(file (concat (symbol-name name) "-" version ".el")))
(package--with-work-buffer location file
(package-unpack-single (symbol-name name) version desc requires))))
(defun package-download-tar (name version)
"Download and install a tar package."
(let ((tar-buffer (url-retrieve-synchronously
(concat (package-archive-url name)
(symbol-name name) "-" version ".tar"))))
(with-current-buffer tar-buffer
(package-handle-response)
(re-search-forward "^$" nil 'move)
(forward-char)
(package-unpack name version)
(kill-buffer tar-buffer))))
(let ((location (package-archive-base name))
(file (concat (symbol-name name) "-" version ".tar")))
(package--with-work-buffer location file
(package-unpack name version))))
(defun package-installed-p (package &optional min-version)
"Return true if PACKAGE, of VERSION or newer, is installed.
......@@ -987,31 +1008,26 @@ The file can either be a tar file or an Emacs Lisp file."
(error "Package `%s-%s' is a system package, not deleting"
name version))))
(defun package-archive-url (name)
(defun package-archive-base (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))
"Retrieve an archive file FILE from ARCHIVE, and cache it.
ARCHIVE should be a cons cell of the form (NAME . LOCATION),
similar to an entry in `package-alist'. Save the cached copy to
\"archives/NAME/archive-contents\" in `package-user-dir'."
(let* ((dir (expand-file-name "archives" package-user-dir))
(dir (expand-file-name (car archive) dir)))
(package--with-work-buffer (cdr archive) file
;; Read the retrieved buffer to make sure it is valid (e.g. it
;; may fetch a URL redirect page).
(when (listp (read buffer))
(make-directory dir t)
(setq buffer-file-name (expand-file-name file dir))
(let ((version-control 'never))
(save-buffer))))
(kill-buffer buffer)))
(save-buffer))))))
(defun package-refresh-contents ()
"Download the ELPA archive description if needed.
......@@ -1176,27 +1192,21 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match ""))))
(let ((readme (expand-file-name (concat package-name "-readme.txt")
package-user-dir)))
package-user-dir))
readme-string)
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
(cond ((let ((buffer (ignore-errors
(url-retrieve-synchronously
(concat (package-archive-url package)
package-name "-readme.txt"))))
response)
(when buffer
(with-current-buffer buffer
(setq response (url-http-parse-response))
(if (or (< response 200) (>= response 300))
(setq response nil)
(setq buffer-file-name
(expand-file-name readme package-user-dir))
(delete-region (point-min) (1+ url-http-end-of-headers))
(save-buffer)))
(when response
(insert-buffer-substring buffer)
(kill-buffer buffer)
t))))
(cond ((condition-case nil
(package--with-work-buffer (package-archive-base package)
(concat package-name "-readme.txt")
(setq buffer-file-name
(expand-file-name readme package-user-dir))
(let ((version-control 'never))
(save-buffer))
(setq readme-string (buffer-string))
t)
(error nil))
(insert readme-string))
((file-readable-p readme)
(insert-file-contents readme)
(goto-char (point-max))))))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment