comparison lisp/emacs-lisp/package.el @ 111394:72d2a83a2641

* emacs-lisp/package.el (package-unpack): Remove no-op. (package--builtins, package--dir): Doc fix. (package-activate-1, package-activate, package-install) (package-compute-transaction): Fix error message. (package-delete): Use delete-directory. Omit system packages. (package-initialize): Set package-alist to nil first. (package-menu-mark-delete, package-menu-mark-install): Don't add symbols that are inconsistent with the package state. (package-menu-execute): Perform deletions and installations as single batch operations.

111393:230a50b33a46

;;   available to the user.
;; * Load.  Actually load the package and run some code from it.

;; Other external functions you may want to use:
;;
;; M-x package-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
;;    can see what packages are available.  This will automatically
;;    fetch the latest list of packages from ELPA.

(defvar Info-directory-list)
(declare-function info-initialize "info" ())
(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.

;; The value is precomputed in finder-inf.el, but don't load that
;; until it's needed (i.e. when `package-intialize' is called).
(defvar package--builtins nil
  "Alist of built-in packages.
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.
  DOCSTRING is a brief description of the package.")
(put 'package--builtins 'risky-local-variable t)

(defsubst package-desc-kind (desc)
  "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))
	 (dir-list (cons package-user-dir package-directory-list))
	 pkg-dir)
    (while dir-list
      (let ((subdir-full (expand-file-name subdir (car dir-list))))
	(if (file-directory-p subdir-full)

(defun package-activate-1 (package pkg-vec)
  (let* ((name (symbol-name package))
	 (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"
	     name version-str))
    ;; Add info node.
    (when (file-exists-p (expand-file-name "dir" pkg-dir))
      ;; FIXME: not the friendliest, but simple.
      (require 'info)

		    (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', version %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)

			 "xf" "-")))

(defun package-unpack (name version)
  (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
				   package-user-dir)))
    ;; Be careful!!
    (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 "^[^.]")))
    (let* ((default-directory (file-name-as-directory package-user-dir)))
      (package-untar-buffer)
      (package-generate-autoloads (symbol-name name) pkg-dir)
      (let ((load-path (cons pkg-dir load-path)))
	(byte-recompile-directory pkg-dir 0 t)))))

		 (list 'quote
		       ;; Turn version lists into string form.
		       (mapcar
			(lambda (elt)
			  (list (car elt)
				(package-version-join (car (cdr elt)))))
			requires))))
	  "\n")
	 nil
	 pkg-file
	 nil nil nil 'excl))

		   (error "Required package '%s' is disabled"
			  (symbol-name next-pkg)))
		  ((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, \
but version %s required"
			  (symbol-name next-pkg) hold
			  (package-version-join next-version)))))
	  (unless pkg-desc
	    (error "Package '%s', version %s, unavailable for installation"
		   (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"
	     (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.
	  (unless (memq next-pkg package-list)
	    (push next-pkg package-list))

						  nil))
					  package-archive-contents)
				  nil t))))
  (let ((pkg-desc (assq name package-archive-contents)))
    (unless pkg-desc
      (error "Package '%s' is not available for installation"
	     (symbol-name name)))
    (package-download-transaction
     (package-compute-transaction (list name)
				  (package-desc-reqs (cdr pkg-desc)))))
  ;; Try to activate it.

     ((string-match "\\.tar$" file)
      (package-install-from-buffer (package-tar-file-info file) 'tar))
     (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))

(defun package-archive-url (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-initialize (&optional no-activate)
  "Load Emacs Lisp packages, and activate them.
The variable `package-load-list' controls which packages to load.
If optional arg NO-ACTIVATE is non-nil, don't activate packages."
  (interactive)
  (setq package-obsolete-alist nil)
  (package-load-all-descriptors)
  (package-read-all-archive-contents)
  (unless no-activate
    (dolist (elt package-alist)
      (package-activate (car elt) (package-desc-vers (cdr elt)))))

;; fixme numeric argument
(defun package-menu-mark-delete (num)
  "Mark a package for deletion and move to the next line."
  (interactive "p")
  (package-menu-mark-internal "D"))

(defun package-menu-mark-install (num)
  "Mark a package for installation and move to the next line."
  (interactive "p")
  (package-menu-mark-internal "I"))

(defun package-menu-mark-unmark (num)
  "Clear any marks on a package and move to the next line."
  (interactive "p")
  (package-menu-mark-internal " "))

    (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
	(match-string 1)
      "")))

(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."
  (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))

(defun package-print-package (package version key desc)
  (let ((face
	 (cond ((string= key "built-in") 'font-lock-builtin-face)
	       ((string= key "available") 'default)

111394:72d2a83a2641

;;   available to the user.
;; * Load.  Actually load the package and run some code from it.

;; Other external functions you may want to use:
;;
;; 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
;;    can see what packages are available.  This will automatically
;;    fetch the latest list of packages from ELPA.

(defvar Info-directory-list)
(declare-function info-initialize "info" ())
(declare-function url-http-parse-response "url-http" ())
(declare-function lm-header "lisp-mnt" (header))
(declare-function lm-commentary "lisp-mnt" (&optional file))
(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.

;; The value is precomputed in finder-inf.el, but don't load that
;; 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.
  DOCSTRING is a brief description of the package.")
(put 'package--builtins 'risky-local-variable t)

(defsubst package-desc-kind (desc)
  "Extract the kind of download from an archive package description vector."
  (aref desc 3))

(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
      (let ((subdir-full (expand-file-name subdir (car dir-list))))
	(if (file-directory-p subdir-full)

(defun package-activate-1 (package pkg-vec)
  (let* ((name (symbol-name package))
	 (version-str (package-version-join (package-desc-vers pkg-vec)))
	 (pkg-dir (package--dir name version-str)))
    (unless pkg-dir
      (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))
      ;; FIXME: not the friendliest, but simple.
      (require 'info)

		    (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)

			 "xf" "-")))

(defun package-unpack (name version)
  (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
				   package-user-dir)))
    (make-directory package-user-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-generate-autoloads (symbol-name name) pkg-dir)
      (let ((load-path (cons pkg-dir load-path)))
	(byte-recompile-directory pkg-dir 0 t)))))

		 (list 'quote
		       ;; Turn version lists into string form.
		       (mapcar
			(lambda (elt)
			  (list (car elt)
				(package-version-join (cadr elt))))
			requires))))
	  "\n")
	 nil
	 pkg-file
	 nil nil nil 'excl))

		   (error "Required package '%s' is disabled"
			  (symbol-name next-pkg)))
		  ((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, \
but version %s required"
			  (symbol-name next-pkg) hold
			  (package-version-join next-version)))))
	  (unless pkg-desc
	    (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-%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.
	  (unless (memq next-pkg package-list)
	    (push next-pkg package-list))

						  nil))
					  package-archive-contents)
				  nil t))))
  (let ((pkg-desc (assq name package-archive-contents)))
    (unless pkg-desc
      (error "Package `%s' is not available for installation"
	     (symbol-name name)))
    (package-download-transaction
     (package-compute-transaction (list name)
				  (package-desc-reqs (cdr pkg-desc)))))
  ;; Try to activate it.

     ((string-match "\\.tar$" file)
      (package-install-from-buffer (package-tar-file-info file) 'tar))
     (t (error "Unrecognized extension `%s'" (file-name-extension file))))))

(defun package-delete (name version)
  (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)
  "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-initialize (&optional no-activate)
  "Load Emacs Lisp packages, and activate them.
The variable `package-load-list' controls which packages to load.
If optional arg NO-ACTIVATE is non-nil, don't activate packages."
  (interactive)
  (setq package-alist nil
	package-obsolete-alist nil)
  (package-load-all-descriptors)
  (package-read-all-archive-contents)
  (unless no-activate
    (dolist (elt package-alist)
      (package-activate (car elt) (package-desc-vers (cdr elt)))))

;; fixme numeric argument
(defun package-menu-mark-delete (num)
  "Mark a package for deletion and move to the next line."
  (interactive "p")
  (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")
  (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."
  (interactive "p")
  (package-menu-mark-internal " "))

    (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
	(match-string 1)
      "")))

(defun package-menu-execute ()
  "Perform marked Package Menu actions.
Packages marked for installation are downloaded and installed;
packages marked for deletion are removed."
  (interactive)
  (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 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
	 (cond ((string= key "built-in") 'font-lock-builtin-face)
	       ((string= key "available") 'default)