;;; package.el --- Simple package system for Emacs
-;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 10 Mar 2007
;; Other external functions you may want to use:
;;
-;; M-x package-list-packages
+;; M-x list-packages
;; Enters a mode similar to buffer-menu which lets you manage
;; packages. You can choose packages for install (mark with "i",
;; then "x" to execute) or deletion (not implemented yet), and you
(declare-function url-http-parse-response "url-http" ())
(declare-function lm-header "lisp-mnt" (header))
(declare-function lm-commentary "lisp-mnt" (&optional file))
-(declare-function dired-delete-file "dired" (file &optional recursive trash))
(defvar url-http-end-of-headers)
(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")
;; until it's needed (i.e. when `package-intialize' is called).
(defvar package--builtins nil
"Alist of built-in packages.
+The actual value is initialized by loading the library
+`finder-inf'; this is not done until it is needed, e.g. by the
+function `package-built-in-p'.
+
Each element has the form (PKG . DESC), where PKG is a package
name (a symbol) and DESC is a vector that describes the package.
-
The vector DESC has the form [VERSION REQS DOCSTRING].
VERSION is a version list.
REQS is a list of packages (symbols) required by the package.
The inner alist is keyed by version.")
(put 'package-obsolete-alist 'risky-local-variable t)
-(defconst package-subdirectory-regexp
- "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
- "Regular expression matching the name of a package subdirectory.
-The first subexpression is the package name.
-The second subexpression is the version string.")
-
-(defun package-version-join (l)
- "Turn a list of version numbers into a version string."
- (mapconcat 'int-to-string l "."))
+(defun package-version-join (vlist)
+ "Return the version string corresponding to the list VLIST.
+This is, approximately, the inverse of `version-to-list'.
+\(Actually, it returns only one of the possible inverses, since
+`version-to-list' is a many-to-one operation.)"
+ (if (null vlist)
+ ""
+ (let ((str-list (list "." (int-to-string (car vlist)))))
+ (dolist (num (cdr vlist))
+ (cond
+ ((>= num 0)
+ (push (int-to-string num) str-list)
+ (push "." str-list))
+ ((< num -3)
+ (error "Invalid version list `%s'" vlist))
+ (t
+ ;; pre, or beta, or alpha
+ (cond ((equal "." (car str-list))
+ (pop str-list))
+ ((not (string-match "[0-9]+" (car str-list)))
+ (error "Invalid version list `%s'" vlist)))
+ (push (cond ((= num -1) "pre")
+ ((= num -2) "beta")
+ ((= num -3) "alpha"))
+ str-list))))
+ (if (equal "." (car str-list))
+ (pop str-list))
+ (apply 'concat (nreverse str-list)))))
(defun package-strip-version (dirname)
"Strip the version from a combined package name and version.
E.g., if given \"quux-23.0\", will return \"quux\""
- (if (string-match package-subdirectory-regexp dirname)
+ (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
(match-string 1 dirname)))
(defun package-load-descriptor (dir package)
- "Load the description file in directory DIR for package PACKAGE."
+ "Load the description file in directory DIR for package PACKAGE.
+Here, PACKAGE is a string of the form NAME-VER, where NAME is the
+package name and VER is its version."
(let* ((pkg-dir (expand-file-name package dir))
(pkg-file (expand-file-name
(concat (package-strip-version package) "-pkg")
description file containing a call to `define-package', which
updates `package-alist' and `package-obsolete-alist'."
(let ((all (memq 'all package-load-list))
+ (regexp (concat "\\`" package-subdirectory-regexp "\\'"))
name version force)
(dolist (dir (cons package-user-dir package-directory-list))
(when (file-directory-p dir)
(dolist (subdir (directory-files dir))
(when (and (file-directory-p (expand-file-name subdir dir))
- (string-match package-subdirectory-regexp subdir))
+ (string-match regexp subdir))
(setq name (intern (match-string 1 subdir))
version (match-string 2 subdir)
force (assq name package-load-list))
"Extract the kind of download from an archive package description vector."
(aref desc 3))
-(defun package--dir (name version-string)
- (let* ((subdir (concat name "-" version-string))
+(defun package--dir (name version)
+ "Return the directory where a package is installed, or nil if none.
+NAME and VERSION are both strings."
+ (let* ((subdir (concat name "-" version))
(dir-list (cons package-user-dir package-directory-list))
pkg-dir)
(while dir-list
(version-str (package-version-join (package-desc-vers pkg-vec)))
(pkg-dir (package--dir name version-str)))
(unless pkg-dir
- (error "Internal error: could not find directory for %s-%s"
+ (error "Internal error: unable to find directory for `%s-%s'"
name version-str))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; Don't return nil.
t))
-(defun package--built-in (package version)
- "Return true if the package is built-in to Emacs."
+(defun package-built-in-p (package &optional version)
+ "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs."
+ (require 'finder-inf nil t) ; For `package--builtins'.
(let ((elt (assq package package--builtins)))
- (and elt (version-list-= (package-desc-vers (cdr elt)) version))))
+ (and elt (version-list-<= version (package-desc-vers (cdr elt))))))
-;; FIXME: return a reason instead?
+;; This function goes ahead and activates a newer version of a package
+;; if an older one was already activated. This is not ideal; we'd at
+;; least need to check to see if the package has actually been loaded,
+;; and not merely activated.
(defun package-activate (package version)
- "Activate a package, and recursively activate its dependencies.
+ "Activate package PACKAGE, of version VERSION or newer.
+If PACKAGE has any dependencies, recursively activate them.
Return nil if the package could not be activated."
- ;; Assume the user knows what he is doing -- go ahead and activate a
- ;; newer version of a package if an older one has already been
- ;; activated. This is not ideal; we'd at least need to check to see
- ;; if the package has actually been loaded, and not merely
- ;; activated. However, don't try to activate 'emacs', as that makes
- ;; no sense.
- (unless (eq package 'emacs)
- (let* ((pkg-desc (assq package package-alist))
- (this-version (package-desc-vers (cdr pkg-desc)))
- (req-list (package-desc-reqs (cdr pkg-desc)))
- ;; If the package was never activated, do it now.
- (keep-going (or (not (memq package package-activated-list))
- (version-list-< version this-version))))
- (while (and req-list keep-going)
- (let* ((req (car req-list))
- (req-name (car req))
- (req-version (cadr req)))
- (or (package-activate req-name req-version)
- (setq keep-going nil)))
- (setq req-list (cdr req-list)))
- (if keep-going
- (package-activate-1 package (cdr pkg-desc))
- ;; We get here if a dependency failed to activate -- but we
- ;; can also get here if the requested package was already
- ;; activated. Return non-nil in the latter case.
- (and (memq package package-activated-list)
- (version-list-<= version this-version))))))
+ (let ((pkg-vec (cdr (assq package package-alist)))
+ available-version found)
+ ;; Check if PACKAGE is available in `package-alist'.
+ (when pkg-vec
+ (setq available-version (package-desc-vers pkg-vec)
+ found (version-list-<= version available-version)))
+ (cond
+ ;; If no such package is found, maybe it's built-in.
+ ((null found)
+ (package-built-in-p package version))
+ ;; If the package is already activated, just return t.
+ ((memq package package-activated-list)
+ t)
+ ;; Otherwise, proceed with activation.
+ (t
+ (let ((fail (catch 'dep-failure
+ ;; Activate its dependencies recursively.
+ (dolist (req (package-desc-reqs pkg-vec))
+ (unless (package-activate (car req) (cadr req))
+ (throw 'dep-failure req))))))
+ (if fail
+ (warn "Unable to activate package `%s'.
+Required package `%s-%s' is unavailable"
+ package (car fail) (package-version-join (cadr fail)))
+ ;; If all goes well, activate the package itself.
+ (package-activate-1 package pkg-vec)))))))
(defun package-mark-obsolete (package pkg-vec)
"Put package on the obsolete list, if not already there."
pkg-vec)))
package-obsolete-alist))))
-(defun define-package (name-str version-string
+(defun define-package (name-string version-string
&optional docstring requirements
&rest extra-properties)
"Define a new package.
-NAME is the name of the package, a string.
-VERSION-STRING is the version of the package, a dotted sequence
-of integers.
-DOCSTRING is the optional description.
-REQUIREMENTS is a list of requirements on other packages.
+NAME-STRING is the name of the package, as a string.
+VERSION-STRING is the version of the package, as a list of
+integers of the form produced by `version-to-list'.
+DOCSTRING is a short description of the package, a string.
+REQUIREMENTS is a list of dependencies on other packages.
Each requirement is of the form (OTHER-PACKAGE \"VERSION\").
EXTRA-PROPERTIES is currently unused."
- (let* ((name (intern name-str))
- (pkg-desc (assq name package-alist))
- (new-version (version-to-list version-string))
+ (let* ((name (intern name-string))
+ (version (version-to-list version-string))
(new-pkg-desc
(cons name
- (vector new-version
+ (vector version
(mapcar
(lambda (elt)
(list (car elt)
(version-to-list (car (cdr elt)))))
requirements)
- docstring))))
- ;; Only redefine a package if the redefinition is newer.
- (if (or (not pkg-desc)
- (version-list-< (package-desc-vers (cdr pkg-desc))
- new-version))
- (progn
- (when pkg-desc
- ;; Remove old package and declare it obsolete.
- (setq package-alist (delq pkg-desc package-alist))
- (package-mark-obsolete (car pkg-desc) (cdr pkg-desc)))
- ;; Add package to the alist.
- (push new-pkg-desc package-alist))
- ;; You can have two packages with the same version, for instance
- ;; one in the system package directory and one in your private
- ;; directory. We just let the first one win.
- (unless (version-list-= new-version
- (package-desc-vers (cdr pkg-desc)))
- ;; The package is born obsolete.
- (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc))))))
+ docstring)))
+ (old-pkg (assq name package-alist)))
+ (cond
+ ;; If there's no old package, just add this to `package-alist'.
+ ((null old-pkg)
+ (push new-pkg-desc package-alist))
+ ((version-list-< (package-desc-vers (cdr old-pkg)) version)
+ ;; Remove the old package and declare it obsolete.
+ (package-mark-obsolete name (cdr old-pkg))
+ (setq package-alist (cons new-pkg-desc
+ (delq old-pkg package-alist))))
+ ;; You can have two packages with the same version, e.g. one in
+ ;; the system package directory and one in your private
+ ;; directory. We just let the first one win.
+ ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
+ ;; The package is born obsolete.
+ (package-mark-obsolete name (cdr new-pkg-desc))))))
;; From Emacs 22.
(defun package-autoload-ensure-default-file (file)
(package-autoload-ensure-default-file generated-autoload-file))
(update-directory-autoloads pkg-dir)))
-(defun package-untar-buffer ()
+(defvar tar-parse-info)
+(declare-function tar-untar-buffer "tar-mode" ())
+
+(defun package-untar-buffer (dir)
"Untar the current buffer.
-This uses `tar-untar-buffer' if it is available.
-Otherwise it uses an external `tar' program.
-`default-directory' should be set by the caller."
+This uses `tar-untar-buffer' from Tar mode. All files should
+untar into a directory named DIR; otherwise, signal an error."
(require 'tar-mode)
- (if (fboundp 'tar-untar-buffer)
- (progn
- ;; tar-mode messes with narrowing, so we just let it have the
- ;; whole buffer to play with.
- (delete-region (point-min) (point))
- (tar-mode)
- (tar-untar-buffer))
- ;; FIXME: check the result.
- (call-process-region (point) (point-max) "tar" nil '(nil nil) nil
- "xf" "-")))
+ (tar-mode)
+ ;; Make sure everything extracts into DIR.
+ (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
+ (dolist (tar-data tar-parse-info)
+ (unless (string-match regexp (aref tar-data 2))
+ (error "Package does not untar cleanly into directory %s/" dir))))
+ (tar-untar-buffer))
(defun package-unpack (name version)
- (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
- package-user-dir)))
- ;; Be careful!!
+ (let* ((dirname (concat (symbol-name name) "-" version))
+ (pkg-dir (expand-file-name dirname package-user-dir)))
(make-directory package-user-dir t)
- (if (file-directory-p pkg-dir)
- (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're
- ; more confident
- (directory-files pkg-dir t "^[^.]")))
+ ;; FIXME: should we delete PKG-DIR if it exists?
(let* ((default-directory (file-name-as-directory package-user-dir)))
- (package-untar-buffer)
+ (package-untar-buffer dirname)
(package-generate-autoloads (symbol-name name) pkg-dir)
(let ((load-path (cons pkg-dir load-path)))
(byte-recompile-directory pkg-dir 0 t)))))
-(defun package--write-file-no-coding (file-name excl)
+(defun package--write-file-no-coding (file-name)
(let ((buffer-file-coding-system 'no-conversion))
- (write-region (point-min) (point-max) file-name nil nil nil excl)))
+ (write-region (point-min) (point-max) file-name)))
(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")
(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)
+ (expand-file-name (concat file-name ".el") package-user-dir))
+ (let* ((pkg-dir (expand-file-name (concat file-name "-"
+ (package-version-join
+ (version-to-list 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)
- (package--write-file-no-coding el-file 'excl)
+ (package--write-file-no-coding el-file)
(let ((print-level nil)
(print-length nil))
(write-region
(mapcar
(lambda (elt)
(list (car elt)
- (package-version-join (car (cdr elt)))))
+ (package-version-join (cadr elt))))
requires))))
"\n")
nil
(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 "\\`https?:" ,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.
(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)
(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.
+Built-in packages also qualify."
(let ((pkg-desc (assq package package-alist)))
- (and pkg-desc
- (version-list-<= min-version
- (package-desc-vers (cdr pkg-desc))))))
+ (if pkg-desc
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc)))
+ ;; Also check built-in packages.
+ (package-built-in-p package min-version))))
(defun package-compute-transaction (package-list requirements)
"Return a list of packages to be installed, including PACKAGE-LIST.
((null (stringp hold))
(error "Invalid element in `package-load-list'"))
((version-list-< (version-to-list hold) next-version)
- (error "Package '%s' held at version %s, \
+ (error "Package `%s' held at version %s, \
but version %s required"
(symbol-name next-pkg) hold
(package-version-join next-version)))))
(unless pkg-desc
- (error "Package '%s' is not available for installation"
- (symbol-name next-pkg)))
+ (error "Package `%s-%s' is unavailable"
+ (symbol-name next-pkg)
+ (package-version-join next-version)))
(unless (version-list-<= next-version
(package-desc-vers (cdr pkg-desc)))
(error
- "Need package '%s' with version %s, but only %s is available"
+ "Need package `%s-%s', but only %s is available"
(symbol-name next-pkg) (package-version-join next-version)
(package-version-join (package-desc-vers (cdr pkg-desc)))))
;; Only add to the transaction if we don't already have it.
(defun package-read-all-archive-contents ()
"Re-read `archive-contents', if it exists.
If successful, set `package-archive-contents'."
+ (setq package-archive-contents nil)
(dolist (archive package-archives)
(package-read-archive-contents (car archive))))
nil t))))
(let ((pkg-desc (assq name package-archive-contents)))
(unless pkg-desc
- (error "Package '%s' is not available for installation"
+ (error "Package `%s' is not available for installation"
(symbol-name name)))
(package-download-transaction
(package-compute-transaction (list name)
;; Try to activate it.
(package-initialize))
-(defun package-strip-rcs-id (v-str)
- "Strip RCS version ID from the version string.
+(defun package-strip-rcs-id (str)
+ "Strip RCS version ID from the version string STR.
If the result looks like a dotted numeric version, return it.
Otherwise return nil."
- (if v-str
- (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str)
- (match-string 1 v-str)
- (if (string-match "^[0-9.]*$" v-str)
- v-str))))
+ (when str
+ (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
+ (setq str (substring str (match-end 0))))
+ (condition-case nil
+ (if (version-to-list str)
+ str)
+ (error nil))))
(defun package-buffer-info ()
"Return a vector describing the package in the current buffer.
"Find package information for a tar file.
FILE is the name of the tar file to examine.
The return result is a vector like `package-buffer-info'."
- (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file)
- (error "Invalid package name `%s'" file))
- (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file)))
- (pkg-version (match-string-no-properties 2 file))
- ;; Extract the package descriptor.
- (pkg-def-contents (shell-command-to-string
- ;; Requires GNU tar.
- (concat "tar -xOf " file " "
- pkg-name "-" pkg-version "/"
- pkg-name "-pkg.el")))
- (pkg-def-parsed (package-read-from-string pkg-def-contents)))
- (unless (eq (car pkg-def-parsed) 'define-package)
- (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
- (let ((name-str (nth 1 pkg-def-parsed))
- (version-string (nth 2 pkg-def-parsed))
- (docstring (nth 3 pkg-def-parsed))
- (requires (nth 4 pkg-def-parsed))
- (readme (shell-command-to-string
- ;; Requires GNU tar.
- (concat "tar -xOf " file " "
- pkg-name "-" pkg-version "/README"))))
- (unless (equal pkg-version version-string)
- (error "Package has inconsistent versions"))
- (unless (equal pkg-name name-str)
- (error "Package has inconsistent names"))
- ;; Kind of a hack.
- (if (string-match ": Not found in archive" readme)
- (setq readme nil))
- ;; Turn string version numbers into list form.
- (if (eq (car requires) 'quote)
- (setq requires (car (cdr requires))))
- (setq requires
- (mapcar (lambda (elt)
- (list (car elt)
- (version-to-list (cadr elt))))
- requires))
- (vector pkg-name requires docstring version-string readme))))
+ (let ((default-directory (file-name-directory file))
+ (file (file-name-nondirectory file)))
+ (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
+ file)
+ (error "Invalid package name `%s'" file))
+ (let* ((pkg-name (match-string-no-properties 1 file))
+ (pkg-version (match-string-no-properties 2 file))
+ ;; Extract the package descriptor.
+ (pkg-def-contents (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+
+ pkg-name "-" pkg-version "/"
+ pkg-name "-pkg.el")))
+ (pkg-def-parsed (package-read-from-string pkg-def-contents)))
+ (unless (eq (car pkg-def-parsed) 'define-package)
+ (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
+ (let ((name-str (nth 1 pkg-def-parsed))
+ (version-string (nth 2 pkg-def-parsed))
+ (docstring (nth 3 pkg-def-parsed))
+ (requires (nth 4 pkg-def-parsed))
+ (readme (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/README"))))
+ (unless (equal pkg-version version-string)
+ (error "Package has inconsistent versions"))
+ (unless (equal pkg-name name-str)
+ (error "Package has inconsistent names"))
+ ;; Kind of a hack.
+ (if (string-match ": Not found in archive" readme)
+ (setq readme nil))
+ ;; Turn string version numbers into list form.
+ (if (eq (car requires) 'quote)
+ (setq requires (car (cdr requires))))
+ (setq requires
+ (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
+ requires))
+ (vector pkg-name requires docstring version-string readme)))))
;;;###autoload
(defun package-install-from-buffer (pkg-info type)
(t (error "Unrecognized extension `%s'" (file-name-extension file))))))
(defun package-delete (name version)
- (require 'dired) ; for dired-delete-file
- (dired-delete-file (expand-file-name (concat name "-" version)
- package-user-dir)
- ;; FIXME: query user?
- 'always))
+ (let ((dir (package--dir name version)))
+ (if (string-equal (file-name-directory dir)
+ (file-name-as-directory
+ (expand-file-name package-user-dir)))
+ (progn
+ (delete-directory dir t t)
+ (message "Package `%s-%s' deleted." name version))
+ ;; Don't delete "system" packages
+ (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.
(unless (file-exists-p package-user-dir)
(make-directory package-user-dir t))
(dolist (archive package-archives)
- (condition-case nil
+ (condition-case-no-debug nil
(package--download-one-archive archive "archive-contents")
(error (message "Failed to download `%s' archive."
(car archive)))))
(package-read-all-archive-contents))
+(defvar package--initialized nil)
+
;;;###autoload
-(defun package-initialize ()
+(defun package-initialize (&optional no-activate)
"Load Emacs Lisp packages, and activate them.
-The variable `package-load-list' controls which packages to load."
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages."
(interactive)
- (require 'finder-inf nil t)
- (setq package-alist package--builtins)
- (setq package-activated-list (mapcar #'car package-alist))
- (setq package-obsolete-alist nil)
+ (setq package-alist nil
+ package-obsolete-alist nil)
(package-load-all-descriptors)
(package-read-all-archive-contents)
- ;; Try to activate all our packages.
- (mapc (lambda (elt)
- (package-activate (car elt) (package-desc-vers (cdr elt))))
- package-alist))
+ (unless no-activate
+ (dolist (elt package-alist)
+ (package-activate (car elt) (package-desc-vers (cdr elt)))))
+ (setq package--initialized t))
\f
;;;; Package description buffer.
(defun describe-package (package)
"Display the full documentation of PACKAGE (a symbol)."
(interactive
- (let* ((packages (append (mapcar 'car package-alist)
- (mapcar 'car package-archive-contents)))
- (guess (function-called-at-point))
- val)
+ (let* ((guess (function-called-at-point))
+ packages val)
+ (require 'finder-inf nil t)
+ ;; Load the package list if necessary (but don't activate them).
+ (unless package--initialized
+ (package-initialize t))
+ (setq packages (append (mapcar 'car package-alist)
+ (mapcar 'car package-archive-contents)
+ (mapcar 'car package--builtins)))
(unless (memq guess packages)
(setq guess nil))
(setq packages (mapcar 'symbol-name packages))
"Describe package: ")
packages nil t nil nil guess))
(list (if (equal val "") guess (intern val)))))
- (if (or (null package) (null (symbolp package)))
- (message "You did not specify a package")
+ (if (or (null package) (not (symbolp package)))
+ (message "No package specified")
(help-setup-xref (list #'describe-package package)
(called-interactively-p 'interactive))
(with-help-window (help-buffer)
desc pkg-dir reqs version installable)
(prin1 package)
(princ " is ")
- (if (setq desc (cdr (assq package package-alist)))
- ;; This package is loaded (i.e. in `package-alist').
- (progn
- (setq version (package-version-join (package-desc-vers desc)))
- (cond (built-in
- (princ "a built-in package.\n\n"))
- ((setq pkg-dir (package--dir package-name version))
- (insert "an installed package.\n\n"))
- (t ;; This normally does not happen.
- (insert "a deleted package.\n\n")
- (setq version nil))))
- ;; This package is not installed.
- (setq desc (cdr (assq package package-archive-contents))
- version (package-version-join (package-desc-vers desc))
+ (cond
+ ;; Loaded packages are in `package-alist'.
+ ((setq desc (cdr (assq package package-alist)))
+ (setq version (package-version-join (package-desc-vers desc)))
+ (if (setq pkg-dir (package--dir package-name version))
+ (insert "an installed package.\n\n")
+ ;; This normally does not happen.
+ (insert "a deleted package.\n\n")))
+ ;; Available packages are in `package-archive-contents'.
+ ((setq desc (cdr (assq package package-archive-contents)))
+ (setq version (package-version-join (package-desc-vers desc))
installable t)
- (insert "an uninstalled package.\n\n"))
+ (if built-in
+ (insert "a built-in package.\n\n")
+ (insert "an uninstalled package.\n\n")))
+ (built-in
+ (setq desc (cdr built-in)
+ version (package-version-join (package-desc-vers desc)))
+ (insert "a built-in package.\n\n"))
+ (t
+ (insert "an orphan package.\n\n")))
(insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
(cond (pkg-dir
;; Todo: Add button for uninstalling.
(help-insert-xref-button (file-name-as-directory pkg-dir)
'help-package-def pkg-dir)
- (insert "'."))
+ (if built-in
+ (insert "',\n shadowing a "
+ (propertize "built-in package"
+ 'font-lock-face 'font-lock-builtin-face)
+ ".")
+ (insert "'.")))
(installable
- (insert "Available -- ")
- (let ((button-text (if (display-graphic-p)
- "Install"
- "[Install]"))
+ (if built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
+ " Alternate version available -- ")
+ (insert "Available -- "))
+ (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
(button-face (if (display-graphic-p)
'(:box (:line-width 2 :color "dark grey")
:background "light grey"
:foreground "black")
'link)))
- (insert-text-button button-text
- 'face button-face
- 'follow-link t
+ (insert-text-button button-text 'face button-face 'follow-link t
'package-symbol package
'action 'package-install-button-action)))
(built-in
- (insert (propertize "Built-in"
- 'font-lock-face 'font-lock-builtin-face) "."))
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
(t (insert "Deleted.")))
(insert "\n")
- (and version
- (> (length version) 0)
+ (and version (> (length version) 0)
(insert " "
(propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
- (setq reqs (package-desc-reqs desc))
+
+ (setq reqs (if desc (package-desc-reqs desc)))
(when reqs
(insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
(let ((first t)
(help-insert-xref-button text 'help-package name))
(insert "\n")))
(insert " " (propertize "Summary" 'font-lock-face 'bold)
- ": " (package-desc-doc desc) "\n\n")
+ ": " (if desc (package-desc-doc desc)) "\n\n")
- (if (assq package package--builtins)
+ (if built-in
;; For built-in packages, insert the commentary.
(let ((fn (locate-file (concat package-name ".el") load-path
load-file-rep-suffixes))
(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))))))))
;;;; Package menu mode.
(defvar package-menu-mode-map
- (let ((map (make-keymap))
+ (let ((map (copy-keymap special-mode-map))
(menu-map (make-sparse-keymap "Package")))
- (suppress-keymap map)
+ (set-keymap-parent map button-buffer-map)
(define-key map "\C-m" 'package-menu-describe-package)
- (define-key map "q" 'quit-window)
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "u" 'package-menu-mark-unmark)
(define-key map "\177" 'package-menu-backup-unmark)
(define-key map "d" 'package-menu-mark-delete)
(define-key map "i" 'package-menu-mark-install)
- (define-key map "g" 'revert-buffer)
(define-key map "r" 'package-menu-refresh)
(define-key map "~" 'package-menu-mark-obsolete-for-deletion)
(define-key map "x" 'package-menu-execute)
(put 'package-menu-mode 'mode-class 'special)
-(defun package-menu-mode ()
+(define-derived-mode package-menu-mode special-mode "Package Menu"
"Major mode for browsing a list of packages.
Letters do not insert themselves; instead, they are commands.
\\<package-menu-mode-map>
\\{package-menu-mode-map}"
- (kill-all-local-variables)
- (use-local-map package-menu-mode-map)
- (setq major-mode 'package-menu-mode)
- (setq mode-name "Package Menu")
(setq truncate-lines t)
(setq buffer-read-only t)
(set (make-local-variable 'revert-buffer-function) 'package-menu-revert)
(20 . "Version")
(32 . "Status")
(43 . "Description"))
- ""))
- (run-mode-hooks 'package-menu-mode-hook))
+ "")))
(defun package-menu-refresh ()
"Download the Emacs Lisp package archive.
(defun package-menu-mark-delete (num)
"Mark a package for deletion and move to the next line."
(interactive "p")
- (package-menu-mark-internal "D"))
+ (if (string-equal (package-menu-get-status) "installed")
+ (package-menu-mark-internal "D")
+ (forward-line)))
(defun package-menu-mark-install (num)
"Mark a package for installation and move to the next line."
(interactive "p")
- (package-menu-mark-internal "I"))
+ (if (string-equal (package-menu-get-status) "available")
+ (package-menu-mark-internal "I")
+ (forward-line)))
(defun package-menu-mark-unmark (num)
"Clear any marks on a package and move to the next line."
"")))
(defun package-menu-execute ()
- "Perform all the marked actions.
-Packages marked for installation will be downloaded and
-installed. Packages marked for deletion will be removed.
-Note that after installing packages you will want to restart
-Emacs."
+ "Perform marked Package Menu actions.
+Packages marked for installation are downloaded and installed;
+packages marked for deletion are removed."
(interactive)
- (goto-char (point-min))
- (while (not (eobp))
- (let ((cmd (char-after))
- (pkg-name (package-menu-get-package))
- (pkg-vers (package-menu-get-version))
- (pkg-status (package-menu-get-status)))
- (cond
- ((eq cmd ?D)
- (when (and (string= pkg-status "installed")
- (string= pkg-name "package"))
- ;; FIXME: actually, we could be tricky and remove all info.
- ;; But that is drastic and the user can do that instead.
- (error "Can't delete most recent version of `package'"))
- ;; Ask for confirmation here? Maybe if package status is ""?
- ;; Or if any lisp from package is actually loaded?
- (message "Deleting %s-%s..." pkg-name pkg-vers)
- (package-delete pkg-name pkg-vers)
- (message "Deleting %s-%s... done" pkg-name pkg-vers))
- ((eq cmd ?I)
- (package-install (intern pkg-name)))))
- (forward-line))
- (package-menu-revert))
+ (let (install-list delete-list cmd)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq cmd (char-after))
+ (cond
+ ((eq cmd ?\s) t)
+ ((eq cmd ?D)
+ (push (cons (package-menu-get-package)
+ (package-menu-get-version))
+ delete-list))
+ ((eq cmd ?I)
+ (push (package-menu-get-package) install-list)))
+ (forward-line)))
+ ;; Delete packages, prompting if necessary.
+ (when delete-list
+ (if (yes-or-no-p
+ (if (= (length delete-list) 1)
+ (format "Delete package `%s-%s'? "
+ (caar delete-list)
+ (cdr (car delete-list)))
+ (format "Delete these %d packages (%s)? "
+ (length delete-list)
+ (mapconcat (lambda (elt)
+ (concat (car elt) "-" (cdr elt)))
+ delete-list
+ ", "))))
+ (dolist (elt delete-list)
+ (condition-case-no-debug err
+ (package-delete (car elt) (cdr elt))
+ (error (message (cadr err)))))
+ (error "Aborted")))
+ (when install-list
+ (if (yes-or-no-p
+ (if (= (length install-list) 1)
+ (format "Install package `%s'? " (car install-list))
+ (format "Install these %d packages (%s)? "
+ (length install-list)
+ (mapconcat 'identity install-list ", "))))
+ (dolist (elt install-list)
+ (package-install (intern elt)))))
+ ;; If we deleted anything, regenerate `package-alist'. This is done
+ ;; automatically if we installed a package.
+ (and delete-list (null install-list)
+ (package-initialize))
+ (if (or delete-list install-list)
+ (package-menu-revert)
+ (message "No operations specified."))))
(defun package-print-package (package version key desc)
(let ((face
(defun package--generate-package-list ()
"Populate the current Package Menu buffer."
- (package-initialize)
(let ((inhibit-read-only t)
info-list name desc hold builtin)
- (setq buffer-read-only nil)
(erase-buffer)
;; List installed packages
(dolist (elt package-alist)
(setq name (car elt))
- (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
- (or (null package-menu-package-list)
- (memq name package-menu-package-list)))
+ (when (or (null package-menu-package-list)
+ (memq name package-menu-package-list))
(setq desc (cdr elt)
- hold (cadr (assq name package-load-list))
- builtin (cdr (assq name package--builtins)))
+ hold (cadr (assq name package-load-list)))
(setq info-list
(package-list-maybe-add
name (package-desc-vers desc)
;; FIXME: it turns out to be tricky to see if this
;; package is presently activated.
- (cond ((stringp hold) "held")
- ((and builtin
- (version-list-=
- (package-desc-vers builtin)
- (package-desc-vers desc)))
- "built-in")
- (t "installed"))
+ (if (stringp hold) "held" "installed")
+ (package-desc-doc desc)
+ info-list))))
+
+ ;; List built-in packages
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (null package-menu-package-list)
+ (memq name package-menu-package-list)))
+ (setq desc (cdr elt))
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ "built-in"
(package-desc-doc desc)
info-list))))
"Generate and pop to the *Packages* buffer.
Optional PACKAGES is a list of names of packages (symbols) to
list; the default is to display everything in `package-alist'."
- (with-current-buffer (get-buffer-create "*Packages*")
- (package-menu-mode)
- (set (make-local-variable 'package-menu-package-list) packages)
- (set (make-local-variable 'package-menu-sort-key) nil)
- (package--generate-package-list)
- ;; It's okay to use pop-to-buffer here. The package menu buffer
- ;; has keybindings, and the user just typed `M-x list-packages',
- ;; suggesting that they might want to use them.
- (pop-to-buffer (current-buffer))))
+ (require 'finder-inf nil t)
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (set (make-local-variable 'package-menu-package-list) packages)
+ (set (make-local-variable 'package-menu-sort-key) nil)
+ (package--generate-package-list))
+ ;; The package menu buffer has keybindings. If the user types
+ ;; `M-x list-packages', that suggests it should become current.
+ (switch-to-buffer buf)))
;;;###autoload
(defun list-packages ()
Fetches the updated list of packages before displaying.
The list is displayed in a buffer named `*Packages*'."
(interactive)
+ ;; Initialize the package system if necessary.
+ (unless package--initialized
+ (package-initialize t))
(package-refresh-contents)
(package--list-packages))
HCoop / bpt / emacs.git / blobdiff