lisp/emacs-lisp/package.el

   1 ;;; package.el --- Simple package system for Emacs
   2
   3 ;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Tom Tromey <tromey@redhat.com>
   6 ;; Created: 10 Mar 2007
   7 ;; Version: 0.9
   8 ;; Keywords: tools
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Change Log:
  28
  29 ;;  2 Apr 2007 - now using ChangeLog file
  30 ;; 15 Mar 2007 - updated documentation
  31 ;; 14 Mar 2007 - Changed how obsolete packages are handled
  32 ;; 13 Mar 2007 - Wrote package-install-from-buffer
  33 ;; 12 Mar 2007 - Wrote package-menu mode
  34
  35 ;;; Commentary:
  36
  37 ;; The idea behind package.el is to be able to download packages and
  38 ;; install them.  Packages are versioned and have versioned
  39 ;; dependencies.  Furthermore, this supports built-in packages which
  40 ;; may or may not be newer than user-specified packages.  This makes
  41 ;; it possible to upgrade Emacs and automatically disable packages
  42 ;; which have moved from external to core.  (Note though that we don't
  43 ;; currently register any of these, so this feature does not actually
  44 ;; work.)
  45
  46 ;; A package is described by its name and version.  The distribution
  47 ;; format is either  a tar file or a single .el file.
  48
  49 ;; A tar file should be named "NAME-VERSION.tar".  The tar file must
  50 ;; unpack into a directory named after the package and version:
  51 ;; "NAME-VERSION".  It must contain a file named "PACKAGE-pkg.el"
  52 ;; which consists of a call to define-package.  It may also contain a
  53 ;; "dir" file and the info files it references.
  54
  55 ;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
  56 ;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
  57
  58 ;; The downloader downloads all dependent packages.  By default,
  59 ;; packages come from the official GNU sources, but others may be
  60 ;; added by customizing the `package-archives' alist.  Packages get
  61 ;; byte-compiled at install time.
  62
  63 ;; At activation time we will set up the load-path and the info path,
  64 ;; and we will load the package's autoloads.  If a package's
  65 ;; dependencies are not available, we will not activate that package.
  66
  67 ;; Conceptually a package has multiple state transitions:
  68 ;;
  69 ;; * Download.  Fetching the package from ELPA.
  70 ;; * Install.  Untar the package, or write the .el file, into
  71 ;;   ~/.emacs.d/elpa/ directory.
  72 ;; * Byte compile.  Currently this phase is done during install,
  73 ;;   but we may change this.
  74 ;; * Activate.  Evaluate the autoloads for the package to make it
  75 ;;   available to the user.
  76 ;; * Load.  Actually load the package and run some code from it.
  77
  78 ;; Other external functions you may want to use:
  79 ;;
  80 ;; M-x list-packages
  81 ;;    Enters a mode similar to buffer-menu which lets you manage
  82 ;;    packages.  You can choose packages for install (mark with "i",
  83 ;;    then "x" to execute) or deletion (not implemented yet), and you
  84 ;;    can see what packages are available.  This will automatically
  85 ;;    fetch the latest list of packages from ELPA.
  86 ;;
  87 ;; M-x package-list-packages-no-fetch
  88 ;;    Like package-list-packages, but does not automatically fetch the
  89 ;;    new list of packages.
  90 ;;
  91 ;; M-x package-install-from-buffer
  92 ;;    Install a package consisting of a single .el file that appears
  93 ;;    in the current buffer.  This only works for packages which
  94 ;;    define a Version header properly; package.el also supports the
  95 ;;    extension headers Package-Version (in case Version is an RCS id
  96 ;;    or similar), and Package-Requires (if the package requires other
  97 ;;    packages).
  98 ;;
  99 ;; M-x package-install-file
 100 ;;    Install a package from the indicated file.  The package can be
 101 ;;    either a tar file or a .el file.  A tar file must contain an
 102 ;;    appropriately-named "-pkg.el" file; a .el file must be properly
 103 ;;    formatted as with package-install-from-buffer.
 104
 105 ;;; Thanks:
 106 ;;; (sorted by sort-lines):
 107
 108 ;; Jim Blandy <jimb@red-bean.com>
 109 ;; Karl Fogel <kfogel@red-bean.com>
 110 ;; Kevin Ryde <user42@zip.com.au>
 111 ;; Lawrence Mitchell
 112 ;; Michael Olson <mwolson@member.fsf.org>
 113 ;; Sebastian Tennant <sebyte@smolny.plus.com>
 114 ;; Stefan Monnier <monnier@iro.umontreal.ca>
 115 ;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
 116 ;; Phil Hagelberg <phil@hagelb.org>
 117
 118 ;;; ToDo:
 119
 120 ;; - putting info dirs at the start of the info path means
 121 ;;   users see a weird ordering of categories.  OTOH we want to
 122 ;;   override later entries.  maybe emacs needs to enforce
 123 ;;   the standard layout?
 124 ;; - put bytecode in a separate directory tree
 125 ;; - perhaps give users a way to recompile their bytecode
 126 ;;   or do it automatically when emacs changes
 127 ;; - give users a way to know whether a package is installed ok
 128 ;; - give users a way to view a package's documentation when it
 129 ;;   only appears in the .el
 130 ;; - use/extend checkdoc so people can tell if their package will work
 131 ;; - "installed" instead of a blank in the status column
 132 ;; - tramp needs its files to be compiled in a certain order.
 133 ;;   how to handle this?  fix tramp?
 134 ;; - on emacs 21 we don't kill the -autoloads.el buffer.  what about 22?
 135 ;; - maybe we need separate .elc directories for various emacs versions
 136 ;;   and also emacs-vs-xemacs.  That way conditional compilation can
 137 ;;   work.  But would this break anything?
 138 ;; - should store the package's keywords in archive-contents, then
 139 ;;   let the users filter the package-menu by keyword.  See
 140 ;;   finder-by-keyword.  (We could also let people view the
 141 ;;   Commentary, but it isn't clear how useful this is.)
 142 ;; - William Xu suggests being able to open a package file without
 143 ;;   installing it
 144 ;; - Interface with desktop.el so that restarting after an install
 145 ;;   works properly
 146 ;; - Implement M-x package-upgrade, to upgrade any/all existing packages
 147 ;; - Use hierarchical layout.  PKG/etc PKG/lisp PKG/info
 148 ;;   ... except maybe lisp?
 149 ;; - It may be nice to have a macro that expands to the package's
 150 ;;   private data dir, aka ".../etc".  Or, maybe data-directory
 151 ;;   needs to be a list (though this would be less nice)
 152 ;;   a few packages want this, eg sokoban
 153 ;; - package menu needs:
 154 ;;     ability to know which packages are built-in & thus not deletable
 155 ;;     it can sometimes print odd results, like 0.3 available but 0.4 active
 156 ;;        why is that?
 157 ;; - Allow multiple versions on the server...?
 158 ;;   [ why bother? ]
 159 ;; - Don't install a package which will invalidate dependencies overall
 160 ;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5))
 161 ;;   [ currently thinking, why bother.. KISS ]
 162 ;; - Allow optional package dependencies
 163 ;;   then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
 164 ;;   and just don't compile to add to load path ...?
 165 ;; - Have a list of archive URLs?  [ maybe there's no point ]
 166 ;; - David Kastrup pointed out on the xemacs list that for GPL it
 167 ;;   is friendlier to ship the source tree.  We could "support" that
 168 ;;   by just having a "src" subdir in the package.  This isn't ideal
 169 ;;   but it probably is not worth trying to support random source
 170 ;;   tree layouts, build schemes, etc.
 171 ;; - Our treatment of the info path is somewhat bogus
 172 ;; - perhaps have an "unstable" tree in ELPA as well as a stable one
 173
 174 ;;; Code:
 175
 176 (defgroup package nil
 177   "Manager for Emacs Lisp packages."
 178   :group 'applications
 179   :version "24.1")
 180
 181 ;;;###autoload
 182 (defcustom package-enable-at-startup t
 183   "Whether to activate installed packages when Emacs starts.
 184 If non-nil, packages are activated after reading the init file
 185 and before `after-init-hook'.  Activation is not done if
 186 `user-init-file' is nil (e.g. Emacs was started with \"-q\").
 187
 188 Even if the value is nil, you can type \\[package-initialize] to
 189 activate the package system at any time."
 190   :type 'boolean
 191   :group 'package
 192   :version "24.1")
 193
 194 (defcustom package-load-list '(all)
 195   "List of packages for `package-initialize' to load.
 196 Each element in this list should be a list (NAME VERSION), or the
 197 symbol `all'.  The symbol `all' says to load the latest installed
 198 versions of all packages not specified by other elements.
 199
 200 For an element (NAME VERSION), NAME is a package name (a symbol).
 201 VERSION should be t, a string, or nil.
 202 If VERSION is t, all versions are loaded, though obsolete ones
 203  will be put in `package-obsolete-alist' and not activated.
 204 If VERSION is a string, only that version is ever loaded.
 205  Any other version, even if newer, is silently ignored.
 206  Hence, the package is \"held\" at that version.
 207 If VERSION is nil, the package is not loaded (it is \"disabled\")."
 208   :type '(repeat symbol)
 209   :risky t
 210   :group 'package
 211   :version "24.1")
 212
 213 (defvar Info-directory-list)
 214 (declare-function info-initialize "info" ())
 215 (declare-function url-http-parse-response "url-http" ())
 216 (declare-function lm-header "lisp-mnt" (header))
 217 (declare-function lm-commentary "lisp-mnt" (&optional file))
 218 (defvar url-http-end-of-headers)
 219
 220 (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
 221   "An alist of archives from which to fetch.
 222 The default value points to the GNU Emacs package repository.
 223
 224 Each element has the form (ID . LOCATION).
 225  ID is an archive name, as a string.
 226  LOCATION specifies the base location for the archive.
 227   If it starts with \"http:\", it is treated as a HTTP URL;
 228   otherwise it should be an absolute directory name.
 229   (Other types of URL are currently not supported.)"
 230   :type '(alist :key-type (string :tag "Archive name")
 231                 :value-type (string :tag "URL or directory name"))
 232   :risky t
 233   :group 'package
 234   :version "24.1")
 235
 236 (defconst package-archive-version 1
 237   "Version number of the package archive understood by this file.
 238 Lower version numbers than this will probably be understood as well.")
 239
 240 (defconst package-el-version "1.0"
 241   "Version of package.el.")
 242
 243 ;; We don't prime the cache since it tends to get out of date.
 244 (defvar package-archive-contents nil
 245   "Cache of the contents of the Emacs Lisp Package Archive.
 246 This is an alist mapping package names (symbols) to package
 247 descriptor vectors.  These are like the vectors for `package-alist'
 248 but have extra entries: one which is 'tar for tar packages and
 249 'single for single-file packages, and one which is the name of
 250 the archive from which it came.")
 251 (put 'package-archive-contents 'risky-local-variable t)
 252
 253 (defcustom package-user-dir (locate-user-emacs-file "elpa")
 254   "Directory containing the user's Emacs Lisp packages.
 255 The directory name should be absolute.
 256 Apart from this directory, Emacs also looks for system-wide
 257 packages in `package-directory-list'."
 258   :type 'directory
 259   :risky t
 260   :group 'package
 261   :version "24.1")
 262
 263 (defcustom package-directory-list
 264   ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
 265   (let (result)
 266     (dolist (f load-path)
 267       (and (stringp f)
 268            (equal (file-name-nondirectory f) "site-lisp")
 269            (push (expand-file-name "elpa" f) result)))
 270     (nreverse result))
 271   "List of additional directories containing Emacs Lisp packages.
 272 Each directory name should be absolute.
 273
 274 These directories contain packages intended for system-wide; in
 275 contrast, `package-user-dir' contains packages for personal use."
 276   :type '(repeat directory)
 277   :risky t
 278   :group 'package
 279   :version "24.1")
 280
 281 ;; The value is precomputed in finder-inf.el, but don't load that
 282 ;; until it's needed (i.e. when `package-intialize' is called).
 283 (defvar package--builtins nil
 284   "Alist of built-in packages.
 285 The actual value is initialized by loading the library
 286 `finder-inf'; this is not done until it is needed, e.g. by the
 287 function `package-built-in-p'.
 288
 289 Each element has the form (PKG . DESC), where PKG is a package
 290 name (a symbol) and DESC is a vector that describes the package.
 291 The vector DESC has the form [VERSION REQS DOCSTRING].
 292   VERSION is a version list.
 293   REQS is a list of packages (symbols) required by the package.
 294   DOCSTRING is a brief description of the package.")
 295 (put 'package--builtins 'risky-local-variable t)
 296
 297 (defvar package-alist nil
 298   "Alist of all packages available for activation.
 299 Each element has the form (PKG . DESC), where PKG is a package
 300 name (a symbol) and DESC is a vector that describes the package.
 301
 302 The vector DESC has the form [VERSION REQS DOCSTRING].
 303   VERSION is a version list.
 304   REQS is a list of packages (symbols) required by the package.
 305   DOCSTRING is a brief description of the package.
 306
 307 This variable is set automatically by `package-load-descriptor',
 308 called via `package-initialize'.  To change which packages are
 309 loaded and/or activated, customize `package-load-list'.")
 310 (put 'package-archive-contents 'risky-local-variable t)
 311
 312 (defvar package-activated-list nil
 313   "List of the names of currently activated packages.")
 314 (put 'package-activated-list 'risky-local-variable t)
 315
 316 (defvar package-obsolete-alist nil
 317   "Representation of obsolete packages.
 318 Like `package-alist', but maps package name to a second alist.
 319 The inner alist is keyed by version.")
 320 (put 'package-obsolete-alist 'risky-local-variable t)
 321
 322 (defun package-version-join (vlist)
 323   "Return the version string corresponding to the list VLIST.
 324 This is, approximately, the inverse of `version-to-list'.
 325 \(Actually, it returns only one of the possible inverses, since
 326 `version-to-list' is a many-to-one operation.)"
 327   (if (null vlist)
 328       ""
 329     (let ((str-list (list "." (int-to-string (car vlist)))))
 330       (dolist (num (cdr vlist))
 331         (cond
 332          ((>= num 0)
 333           (push (int-to-string num) str-list)
 334           (push "." str-list))
 335          ((< num -3)
 336           (error "Invalid version list `%s'" vlist))
 337          (t
 338           ;; pre, or beta, or alpha
 339           (cond ((equal "." (car str-list))
 340                  (pop str-list))
 341                 ((not (string-match "[0-9]+" (car str-list)))
 342                  (error "Invalid version list `%s'" vlist)))
 343           (push (cond ((= num -1) "pre")
 344                       ((= num -2) "beta")
 345                       ((= num -3) "alpha"))
 346                 str-list))))
 347       (if (equal "." (car str-list))
 348           (pop str-list))
 349       (apply 'concat (nreverse str-list)))))
 350
 351 (defun package-strip-version (dirname)
 352   "Strip the version from a combined package name and version.
 353 E.g., if given \"quux-23.0\", will return \"quux\""
 354   (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
 355       (match-string 1 dirname)))
 356
 357 (defun package-load-descriptor (dir package)
 358   "Load the description file in directory DIR for package PACKAGE.
 359 Here, PACKAGE is a string of the form NAME-VER, where NAME is the
 360 package name and VER is its version."
 361   (let* ((pkg-dir (expand-file-name package dir))
 362          (pkg-file (expand-file-name
 363                     (concat (package-strip-version package) "-pkg")
 364                     pkg-dir)))
 365     (when (and (file-directory-p pkg-dir)
 366                (file-exists-p (concat pkg-file ".el")))
 367       (load pkg-file nil t))))
 368
 369 (defun package-load-all-descriptors ()
 370   "Load descriptors for installed Emacs Lisp packages.
 371 This looks for package subdirectories in `package-user-dir' and
 372 `package-directory-list'.  The variable `package-load-list'
 373 controls which package subdirectories may be loaded.
 374
 375 In each valid package subdirectory, this function loads the
 376 description file containing a call to `define-package', which
 377 updates `package-alist' and `package-obsolete-alist'."
 378   (let ((all (memq 'all package-load-list))
 379         (regexp (concat "\\`" package-subdirectory-regexp "\\'"))
 380         name version force)
 381     (dolist (dir (cons package-user-dir package-directory-list))
 382       (when (file-directory-p dir)
 383         (dolist (subdir (directory-files dir))
 384           (when (and (file-directory-p (expand-file-name subdir dir))
 385                      (string-match regexp subdir))
 386             (setq name    (intern (match-string 1 subdir))
 387                   version (match-string 2 subdir)
 388                   force   (assq name package-load-list))
 389             (when (cond
 390                    ((null force)
 391                     all) ; not in package-load-list
 392                    ((null (setq force (cadr force)))
 393                     nil) ; disabled
 394                    ((eq force t)
 395                     t)
 396                    ((stringp force) ; held
 397                     (version-list-= (version-to-list version)
 398                                     (version-to-list force)))
 399                    (t
 400                     (error "Invalid element in `package-load-list'")))
 401               (package-load-descriptor dir subdir))))))))
 402
 403 (defsubst package-desc-vers (desc)
 404   "Extract version from a package description vector."
 405   (aref desc 0))
 406
 407 (defsubst package-desc-reqs (desc)
 408   "Extract requirements from a package description vector."
 409   (aref desc 1))
 410
 411 (defsubst package-desc-doc (desc)
 412   "Extract doc string from a package description vector."
 413   (aref desc 2))
 414
 415 (defsubst package-desc-kind (desc)
 416   "Extract the kind of download from an archive package description vector."
 417   (aref desc 3))
 418
 419 (defun package--dir (name version)
 420   "Return the directory where a package is installed, or nil if none.
 421 NAME and VERSION are both strings."
 422   (let* ((subdir (concat name "-" version))
 423          (dir-list (cons package-user-dir package-directory-list))
 424          pkg-dir)
 425     (while dir-list
 426       (let ((subdir-full (expand-file-name subdir (car dir-list))))
 427         (if (file-directory-p subdir-full)
 428             (setq pkg-dir  subdir-full
 429                   dir-list nil)
 430           (setq dir-list (cdr dir-list)))))
 431     pkg-dir))
 432
 433 (defun package-activate-1 (package pkg-vec)
 434   (let* ((name (symbol-name package))
 435          (version-str (package-version-join (package-desc-vers pkg-vec)))
 436          (pkg-dir (package--dir name version-str)))
 437     (unless pkg-dir
 438       (error "Internal error: unable to find directory for `%s-%s'"
 439              name version-str))
 440     ;; Add info node.
 441     (when (file-exists-p (expand-file-name "dir" pkg-dir))
 442       ;; FIXME: not the friendliest, but simple.
 443       (require 'info)
 444       (info-initialize)
 445       (push pkg-dir Info-directory-list))
 446     ;; Add to load path, add autoloads, and activate the package.
 447     (push pkg-dir load-path)
 448     (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
 449     (push package package-activated-list)
 450     ;; Don't return nil.
 451     t))
 452
 453 (defun package-built-in-p (package &optional version)
 454   "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs."
 455   (require 'finder-inf nil t) ; For `package--builtins'.
 456   (let ((elt (assq package package--builtins)))
 457     (and elt (version-list-<= version (package-desc-vers (cdr elt))))))
 458
 459 ;; This function goes ahead and activates a newer version of a package
 460 ;; if an older one was already activated.  This is not ideal; we'd at
 461 ;; least need to check to see if the package has actually been loaded,
 462 ;; and not merely activated.
 463 (defun package-activate (package version)
 464   "Activate package PACKAGE, of version VERSION or newer.
 465 If PACKAGE has any dependencies, recursively activate them.
 466 Return nil if the package could not be activated."
 467   (let ((pkg-vec (cdr (assq package package-alist)))
 468         available-version found)
 469     ;; Check if PACKAGE is available in `package-alist'.
 470     (when pkg-vec
 471       (setq available-version (package-desc-vers pkg-vec)
 472             found (version-list-<= version available-version)))
 473     (cond
 474      ;; If no such package is found, maybe it's built-in.
 475      ((null found)
 476       (package-built-in-p package version))
 477      ;; If the package is already activated, just return t.
 478      ((memq package package-activated-list)
 479       t)
 480      ;; Otherwise, proceed with activation.
 481      (t
 482       (let ((fail (catch 'dep-failure
 483                     ;; Activate its dependencies recursively.
 484                     (dolist (req (package-desc-reqs pkg-vec))
 485                       (unless (package-activate (car req) (cadr req))
 486                         (throw 'dep-failure req))))))
 487         (if fail
 488             (warn "Unable to activate package `%s'.
 489 Required package `%s-%s' is unavailable"
 490                   package (car fail) (package-version-join (cadr fail)))
 491           ;; If all goes well, activate the package itself.
 492           (package-activate-1 package pkg-vec)))))))
 493
 494 (defun package-mark-obsolete (package pkg-vec)
 495   "Put package on the obsolete list, if not already there."
 496   (let ((elt (assq package package-obsolete-alist)))
 497     (if elt
 498         ;; If this obsolete version does not exist in the list, update
 499         ;; it the list.
 500         (unless (assoc (package-desc-vers pkg-vec) (cdr elt))
 501           (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec)
 502                             (cdr elt))))
 503       ;; Make a new association.
 504       (push (cons package (list (cons (package-desc-vers pkg-vec)
 505                                       pkg-vec)))
 506             package-obsolete-alist))))
 507
 508 (defun define-package (name-string version-string
 509                                 &optional docstring requirements
 510                                 &rest extra-properties)
 511   "Define a new package.
 512 NAME-STRING is the name of the package, as a string.
 513 VERSION-STRING is the version of the package, as a list of
 514 integers of the form produced by `version-to-list'.
 515 DOCSTRING is a short description of the package, a string.
 516 REQUIREMENTS is a list of dependencies on other packages.
 517 Each requirement is of the form (OTHER-PACKAGE \"VERSION\").
 518
 519 EXTRA-PROPERTIES is currently unused."
 520   (let* ((name (intern name-string))
 521          (version (version-to-list version-string))
 522          (new-pkg-desc
 523           (cons name
 524                 (vector version
 525                         (mapcar
 526                          (lambda (elt)
 527                            (list (car elt)
 528                                  (version-to-list (car (cdr elt)))))
 529                          requirements)
 530                         docstring)))
 531          (old-pkg (assq name package-alist)))
 532     (cond
 533      ;; If there's no old package, just add this to `package-alist'.
 534      ((null old-pkg)
 535       (push new-pkg-desc package-alist))
 536      ((version-list-< (package-desc-vers (cdr old-pkg)) version)
 537       ;; Remove the old package and declare it obsolete.
 538       (package-mark-obsolete name (cdr old-pkg))
 539       (setq package-alist (cons new-pkg-desc
 540                                 (delq old-pkg package-alist))))
 541      ;; You can have two packages with the same version, e.g. one in
 542      ;; the system package directory and one in your private
 543      ;; directory.  We just let the first one win.
 544      ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
 545       ;; The package is born obsolete.
 546       (package-mark-obsolete name (cdr new-pkg-desc))))))
 547
 548 ;; From Emacs 22.
 549 (defun package-autoload-ensure-default-file (file)
 550   "Make sure that the autoload file FILE exists and if not create it."
 551   (unless (file-exists-p file)
 552     (write-region
 553      (concat ";;; " (file-name-nondirectory file)
 554              " --- automatically extracted autoloads\n"
 555              ";;\n"
 556              ";;; Code:\n\n"
 557              "\f\n;; Local Variables:\n"
 558              ";; version-control: never\n"
 559              ";; no-byte-compile: t\n"
 560              ";; no-update-autoloads: t\n"
 561              ";; End:\n"
 562              ";;; " (file-name-nondirectory file)
 563              " ends here\n")
 564      nil file))
 565   file)
 566
 567 (defun package-generate-autoloads (name pkg-dir)
 568   (let* ((auto-name (concat name "-autoloads.el"))
 569          (ignore-name (concat name "-pkg.el"))
 570          (generated-autoload-file (expand-file-name auto-name pkg-dir))
 571          (version-control 'never))
 572     (require 'autoload)
 573     (unless (fboundp 'autoload-ensure-default-file)
 574       (package-autoload-ensure-default-file generated-autoload-file))
 575     (update-directory-autoloads pkg-dir)))
 576
 577 (defvar tar-parse-info)
 578 (declare-function tar-untar-buffer "tar-mode" ())
 579
 580 (defun package-untar-buffer (dir)
 581   "Untar the current buffer.
 582 This uses `tar-untar-buffer' from Tar mode.  All files should
 583 untar into a directory named DIR; otherwise, signal an error."
 584   (require 'tar-mode)
 585   (tar-mode)
 586   ;; Make sure everything extracts into DIR.
 587   (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
 588     (dolist (tar-data tar-parse-info)
 589       (unless (string-match regexp (aref tar-data 2))
 590         (error "Package does not untar cleanly into directory %s/" dir))))
 591   (tar-untar-buffer))
 592
 593 (defun package-unpack (name version)
 594   (let* ((dirname (concat (symbol-name name) "-" version))
 595          (pkg-dir (expand-file-name dirname package-user-dir)))
 596     (make-directory package-user-dir t)
 597     ;; FIXME: should we delete PKG-DIR if it exists?
 598     (let* ((default-directory (file-name-as-directory package-user-dir)))
 599       (package-untar-buffer dirname)
 600       (package-generate-autoloads (symbol-name name) pkg-dir)
 601       (let ((load-path (cons pkg-dir load-path)))
 602         (byte-recompile-directory pkg-dir 0 t)))))
 603
 604 (defun package--write-file-no-coding (file-name)
 605   (let ((buffer-file-coding-system 'no-conversion))
 606     (write-region (point-min) (point-max) file-name)))
 607
 608 (defun package-unpack-single (file-name version desc requires)
 609   "Install the contents of the current buffer as a package."
 610   ;; Special case "package".
 611   (if (string= file-name "package")
 612       (package--write-file-no-coding
 613        (expand-file-name (concat file-name ".el") package-user-dir))
 614     (let* ((pkg-dir  (expand-file-name (concat file-name "-"
 615                                                (package-version-join
 616                                                 (version-to-list version)))
 617                                        package-user-dir))
 618            (el-file  (expand-file-name (concat file-name ".el") pkg-dir))
 619            (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
 620       (make-directory pkg-dir t)
 621       (package--write-file-no-coding el-file)
 622       (let ((print-level nil)
 623             (print-length nil))
 624         (write-region
 625          (concat
 626           (prin1-to-string
 627            (list 'define-package
 628                  file-name
 629                  version
 630                  desc
 631                  (list 'quote
 632                        ;; Turn version lists into string form.
 633                        (mapcar
 634                         (lambda (elt)
 635                           (list (car elt)
 636                                 (package-version-join (cadr elt))))
 637                         requires))))
 638           "\n")
 639          nil
 640          pkg-file
 641          nil nil nil 'excl))
 642       (package-generate-autoloads file-name pkg-dir)
 643       (let ((load-path (cons pkg-dir load-path)))
 644         (byte-recompile-directory pkg-dir 0 t)))))
 645
 646 (defmacro package--with-work-buffer (location file &rest body)
 647   "Run BODY in a buffer containing the contents of FILE at LOCATION.
 648 LOCATION is the base location of a package archive, and should be
 649 one of the URLs (or file names) specified in `package-archives'.
 650 FILE is the name of a file relative to that base location.
 651
 652 This macro retrieves FILE from LOCATION into a temporary buffer,
 653 and evaluates BODY while that buffer is current.  This work
 654 buffer is killed afterwards.  Return the last value in BODY."
 655   `(let* ((http (string-match "\\`http:" ,location))
 656           (buffer
 657            (if http
 658                (url-retrieve-synchronously (concat ,location ,file))
 659              (generate-new-buffer "*package work buffer*"))))
 660      (prog1
 661          (with-current-buffer buffer
 662            (if http
 663                (progn (package-handle-response)
 664                       (re-search-forward "^$" nil 'move)
 665                       (forward-char)
 666                       (delete-region (point-min) (point)))
 667              (unless (file-name-absolute-p ,location)
 668                (error "Archive location %s is not an absolute file name"
 669                       ,location))
 670              (insert-file-contents (expand-file-name ,file ,location)))
 671            ,@body)
 672        (kill-buffer buffer))))
 673
 674 (defun package-handle-response ()
 675   "Handle the response from a `url-retrieve-synchronously' call.
 676 Parse the HTTP response and throw if an error occurred.
 677 The url package seems to require extra processing for this.
 678 This should be called in a `save-excursion', in the download buffer.
 679 It will move point to somewhere in the headers."
 680   ;; We assume HTTP here.
 681   (require 'url-http)
 682   (let ((response (url-http-parse-response)))
 683     (when (or (< response 200) (>= response 300))
 684       (error "Error during download request:%s"
 685              (buffer-substring-no-properties (point) (progn
 686                                                        (end-of-line)
 687                                                        (point)))))))
 688
 689 (defun package-download-single (name version desc requires)
 690   "Download and install a single-file package."
 691   (let ((location (package-archive-base name))
 692         (file (concat (symbol-name name) "-" version ".el")))
 693     (package--with-work-buffer location file
 694       (package-unpack-single (symbol-name name) version desc requires))))
 695
 696 (defun package-download-tar (name version)
 697   "Download and install a tar package."
 698   (let ((location (package-archive-base name))
 699         (file (concat (symbol-name name) "-" version ".tar")))
 700     (package--with-work-buffer location file
 701       (package-unpack name version))))
 702
 703 (defun package-installed-p (package &optional min-version)
 704   "Return true if PACKAGE, of VERSION or newer, is installed.
 705 Built-in packages also qualify."
 706   (let ((pkg-desc (assq package package-alist)))
 707     (if pkg-desc
 708         (version-list-<= min-version
 709                          (package-desc-vers (cdr pkg-desc)))
 710       ;; Also check built-in packages.
 711       (package-built-in-p package min-version))))
 712
 713 (defun package-compute-transaction (package-list requirements)
 714   "Return a list of packages to be installed, including PACKAGE-LIST.
 715 PACKAGE-LIST should be a list of package names (symbols).
 716
 717 REQUIREMENTS should be a list of additional requirements; each
 718 element in this list should have the form (PACKAGE VERSION),
 719 where PACKAGE is a package name and VERSION is the required
 720 version of that package (as a list).
 721
 722 This function recursively computes the requirements of the
 723 packages in REQUIREMENTS, and returns a list of all the packages
 724 that must be installed.  Packages that are already installed are
 725 not included in this list."
 726   (dolist (elt requirements)
 727     (let* ((next-pkg (car elt))
 728            (next-version (cadr elt)))
 729       (unless (package-installed-p next-pkg next-version)
 730         ;; A package is required, but not installed.  It might also be
 731         ;; blocked via `package-load-list'.
 732         (let ((pkg-desc (assq next-pkg package-archive-contents))
 733               hold)
 734           (when (setq hold (assq next-pkg package-load-list))
 735             (setq hold (cadr hold))
 736             (cond ((eq hold nil)
 737                    (error "Required package '%s' is disabled"
 738                           (symbol-name next-pkg)))
 739                   ((null (stringp hold))
 740                    (error "Invalid element in `package-load-list'"))
 741                   ((version-list-< (version-to-list hold) next-version)
 742                    (error "Package `%s' held at version %s, \
 743 but version %s required"
 744                           (symbol-name next-pkg) hold
 745                           (package-version-join next-version)))))
 746           (unless pkg-desc
 747             (error "Package `%s-%s' is unavailable"
 748                    (symbol-name next-pkg)
 749                    (package-version-join next-version)))
 750           (unless (version-list-<= next-version
 751                                    (package-desc-vers (cdr pkg-desc)))
 752             (error
 753              "Need package `%s-%s', but only %s is available"
 754              (symbol-name next-pkg) (package-version-join next-version)
 755              (package-version-join (package-desc-vers (cdr pkg-desc)))))
 756           ;; Only add to the transaction if we don't already have it.
 757           (unless (memq next-pkg package-list)
 758             (push next-pkg package-list))
 759           (setq package-list
 760                 (package-compute-transaction package-list
 761                                              (package-desc-reqs
 762                                               (cdr pkg-desc))))))))
 763   package-list)
 764
 765 (defun package-read-from-string (str)
 766   "Read a Lisp expression from STR.
 767 Signal an error if the entire string was not used."
 768   (let* ((read-data (read-from-string str))
 769          (more-left
 770           (condition-case nil
 771               ;; The call to `ignore' suppresses a compiler warning.
 772               (progn (ignore (read-from-string
 773                               (substring str (cdr read-data))))
 774                      t)
 775             (end-of-file nil))))
 776     (if more-left
 777         (error "Can't read whole string")
 778       (car read-data))))
 779
 780 (defun package--read-archive-file (file)
 781   "Re-read archive file FILE, if it exists.
 782 Will return the data from the file, or nil if the file does not exist.
 783 Will throw an error if the archive version is too new."
 784   (let ((filename (expand-file-name file package-user-dir)))
 785     (when (file-exists-p filename)
 786       (with-temp-buffer
 787         (insert-file-contents-literally filename)
 788         (let ((contents (read (current-buffer))))
 789           (if (> (car contents) package-archive-version)
 790               (error "Package archive version %d is higher than %d"
 791                      (car contents) package-archive-version))
 792           (cdr contents))))))
 793
 794 (defun package-read-all-archive-contents ()
 795   "Re-read `archive-contents', if it exists.
 796 If successful, set `package-archive-contents'."
 797   (setq package-archive-contents nil)
 798   (dolist (archive package-archives)
 799     (package-read-archive-contents (car archive))))
 800
 801 (defun package-read-archive-contents (archive)
 802   "Re-read archive contents for ARCHIVE.
 803 If successful, set the variable `package-archive-contents'.
 804 If the archive version is too new, signal an error."
 805   ;; Version 1 of 'archive-contents' is identical to our internal
 806   ;; representation.
 807   (let* ((dir (concat "archives/" archive))
 808          (contents-file (concat dir "/archive-contents"))
 809          contents)
 810     (when (setq contents (package--read-archive-file contents-file))
 811       (dolist (package contents)
 812         (package--add-to-archive-contents package archive)))))
 813
 814 (defun package--add-to-archive-contents (package archive)
 815   "Add the PACKAGE from the given ARCHIVE if necessary.
 816 Also, add the originating archive to the end of the package vector."
 817   (let* ((name    (car package))
 818          (version (aref (cdr package) 0))
 819          (entry   (cons (car package)
 820                         (vconcat (cdr package) (vector archive))))
 821          (existing-package (cdr (assq name package-archive-contents))))
 822     (when (or (not existing-package)
 823               (version-list-< (aref existing-package 0) version))
 824       (add-to-list 'package-archive-contents entry))))
 825
 826 (defun package-download-transaction (package-list)
 827   "Download and install all the packages in PACKAGE-LIST.
 828 PACKAGE-LIST should be a list of package names (symbols).
 829 This function assumes that all package requirements in
 830 PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
 831 using `package-compute-transaction'."
 832   (dolist (elt package-list)
 833     (let* ((desc (cdr (assq elt package-archive-contents)))
 834            ;; As an exception, if package is "held" in
 835            ;; `package-load-list', download the held version.
 836            (hold (cadr (assq elt package-load-list)))
 837            (v-string (or (and (stringp hold) hold)
 838                          (package-version-join (package-desc-vers desc))))
 839            (kind (package-desc-kind desc)))
 840       (cond
 841        ((eq kind 'tar)
 842         (package-download-tar elt v-string))
 843        ((eq kind 'single)
 844         (package-download-single elt v-string
 845                                  (package-desc-doc desc)
 846                                  (package-desc-reqs desc)))
 847        (t
 848         (error "Unknown package kind: %s" (symbol-name kind)))))))
 849
 850 ;;;###autoload
 851 (defun package-install (name)
 852   "Install the package named NAME.
 853 Interactively, prompt for the package name.
 854 The package is found on one of the archives in `package-archives'."
 855   (interactive
 856    (list (intern (completing-read "Install package: "
 857                                   (mapcar (lambda (elt)
 858                                             (cons (symbol-name (car elt))
 859                                                   nil))
 860                                           package-archive-contents)
 861                                   nil t))))
 862   (let ((pkg-desc (assq name package-archive-contents)))
 863     (unless pkg-desc
 864       (error "Package `%s' is not available for installation"
 865              (symbol-name name)))
 866     (package-download-transaction
 867      (package-compute-transaction (list name)
 868                                   (package-desc-reqs (cdr pkg-desc)))))
 869   ;; Try to activate it.
 870   (package-initialize))
 871
 872 (defun package-strip-rcs-id (str)
 873   "Strip RCS version ID from the version string STR.
 874 If the result looks like a dotted numeric version, return it.
 875 Otherwise return nil."
 876   (when str
 877     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
 878       (setq str (substring str (match-end 0))))
 879     (condition-case nil
 880         (if (version-to-list str)
 881             str)
 882       (error nil))))
 883
 884 (defun package-buffer-info ()
 885   "Return a vector describing the package in the current buffer.
 886 The vector has the form
 887
 888    [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
 889
 890 FILENAME is the file name, a string, sans the \".el\" extension.
 891 REQUIRES is a requires list, or nil.
 892 DESCRIPTION is the package description, a string.
 893 VERSION is the version, a string.
 894 COMMENTARY is the commentary section, a string, or nil if none.
 895
 896 If the buffer does not contain a conforming package, signal an
 897 error.  If there is a package, narrow the buffer to the file's
 898 boundaries."
 899   (goto-char (point-min))
 900   (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t)
 901     (error "Packages lacks a file header"))
 902   (let ((file-name (match-string-no-properties 1))
 903         (desc      (match-string-no-properties 2))
 904         (start     (line-beginning-position)))
 905     (unless (search-forward (concat ";;; " file-name ".el ends here"))
 906       (error "Package lacks a terminating comment"))
 907     ;; Try to include a trailing newline.
 908     (forward-line)
 909     (narrow-to-region start (point))
 910     (require 'lisp-mnt)
 911     ;; Use some headers we've invented to drive the process.
 912     (let* ((requires-str (lm-header "package-requires"))
 913            (requires (if requires-str
 914                          (package-read-from-string requires-str)))
 915            ;; Prefer Package-Version; if defined, the package author
 916            ;; probably wants us to use it.  Otherwise try Version.
 917            (pkg-version
 918             (or (package-strip-rcs-id (lm-header "package-version"))
 919                 (package-strip-rcs-id (lm-header "version"))))
 920            (commentary (lm-commentary)))
 921       (unless pkg-version
 922         (error
 923          "Package lacks a \"Version\" or \"Package-Version\" header"))
 924       ;; Turn string version numbers into list form.
 925       (setq requires
 926             (mapcar
 927              (lambda (elt)
 928                (list (car elt)
 929                      (version-to-list (car (cdr elt)))))
 930              requires))
 931       (vector file-name requires desc pkg-version commentary))))
 932
 933 (defun package-tar-file-info (file)
 934   "Find package information for a tar file.
 935 FILE is the name of the tar file to examine.
 936 The return result is a vector like `package-buffer-info'."
 937   (let ((default-directory (file-name-directory file))
 938         (file (file-name-nondirectory file)))
 939     (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
 940                           file)
 941       (error "Invalid package name `%s'" file))
 942     (let* ((pkg-name (match-string-no-properties 1 file))
 943            (pkg-version (match-string-no-properties 2 file))
 944            ;; Extract the package descriptor.
 945            (pkg-def-contents (shell-command-to-string
 946                               ;; Requires GNU tar.
 947                               (concat "tar -xOf " file " "
 948
 949                                       pkg-name "-" pkg-version "/"
 950                                       pkg-name "-pkg.el")))
 951            (pkg-def-parsed (package-read-from-string pkg-def-contents)))
 952       (unless (eq (car pkg-def-parsed) 'define-package)
 953         (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
 954       (let ((name-str       (nth 1 pkg-def-parsed))
 955             (version-string (nth 2 pkg-def-parsed))
 956             (docstring      (nth 3 pkg-def-parsed))
 957             (requires       (nth 4 pkg-def-parsed))
 958             (readme (shell-command-to-string
 959                      ;; Requires GNU tar.
 960                      (concat "tar -xOf " file " "
 961                              pkg-name "-" pkg-version "/README"))))
 962         (unless (equal pkg-version version-string)
 963           (error "Package has inconsistent versions"))
 964         (unless (equal pkg-name name-str)
 965           (error "Package has inconsistent names"))
 966         ;; Kind of a hack.
 967         (if (string-match ": Not found in archive" readme)
 968             (setq readme nil))
 969         ;; Turn string version numbers into list form.
 970         (if (eq (car requires) 'quote)
 971             (setq requires (car (cdr requires))))
 972         (setq requires
 973               (mapcar (lambda (elt)
 974                         (list (car elt)
 975                               (version-to-list (cadr elt))))
 976                       requires))
 977         (vector pkg-name requires docstring version-string readme)))))
 978
 979 ;;;###autoload
 980 (defun package-install-from-buffer (pkg-info type)
 981   "Install a package from the current buffer.
 982 When called interactively, the current buffer is assumed to be a
 983 single .el file that follows the packaging guidelines; see info
 984 node `(elisp)Packaging'.
 985
 986 When called from Lisp, PKG-INFO is a vector describing the
 987 information, of the type returned by `package-buffer-info'; and
 988 TYPE is the package type (either `single' or `tar')."
 989   (interactive (list (package-buffer-info) 'single))
 990   (save-excursion
 991     (save-restriction
 992       (let* ((file-name (aref pkg-info 0))
 993              (requires  (aref pkg-info 1))
 994              (desc (if (string= (aref pkg-info 2) "")
 995                        "No description available."
 996                      (aref pkg-info 2)))
 997              (pkg-version (aref pkg-info 3)))
 998         ;; Download and install the dependencies.
 999         (let ((transaction (package-compute-transaction nil requires)))
1000           (package-download-transaction transaction))
1001         ;; Install the package itself.
1002         (cond
1003          ((eq type 'single)
1004           (package-unpack-single file-name pkg-version desc requires))
1005          ((eq type 'tar)
1006           (package-unpack (intern file-name) pkg-version))
1007          (t
1008           (error "Unknown type: %s" (symbol-name type))))
1009         ;; Try to activate it.
1010         (package-initialize)))))
1011
1012 ;;;###autoload
1013 (defun package-install-file (file)
1014   "Install a package from a file.
1015 The file can either be a tar file or an Emacs Lisp file."
1016   (interactive "fPackage file name: ")
1017   (with-temp-buffer
1018     (insert-file-contents-literally file)
1019     (cond
1020      ((string-match "\\.el$" file)
1021       (package-install-from-buffer (package-buffer-info) 'single))
1022      ((string-match "\\.tar$" file)
1023       (package-install-from-buffer (package-tar-file-info file) 'tar))
1024      (t (error "Unrecognized extension `%s'" (file-name-extension file))))))
1025
1026 (defun package-delete (name version)
1027   (let ((dir (package--dir name version)))
1028     (if (string-equal (file-name-directory dir)
1029                       (file-name-as-directory
1030                        (expand-file-name package-user-dir)))
1031         (progn
1032           (delete-directory dir t t)
1033           (message "Package `%s-%s' deleted." name version))
1034       ;; Don't delete "system" packages
1035       (error "Package `%s-%s' is a system package, not deleting"
1036              name version))))
1037
1038 (defun package-archive-base (name)
1039   "Return the archive containing the package NAME."
1040   (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
1041     (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
1042
1043 (defun package--download-one-archive (archive file)
1044   "Retrieve an archive file FILE from ARCHIVE, and cache it.
1045 ARCHIVE should be a cons cell of the form (NAME . LOCATION),
1046 similar to an entry in `package-alist'.  Save the cached copy to
1047 \"archives/NAME/archive-contents\" in `package-user-dir'."
1048   (let* ((dir (expand-file-name "archives" package-user-dir))
1049          (dir (expand-file-name (car archive) dir)))
1050     (package--with-work-buffer (cdr archive) file
1051       ;; Read the retrieved buffer to make sure it is valid (e.g. it
1052       ;; may fetch a URL redirect page).
1053       (when (listp (read buffer))
1054         (make-directory dir t)
1055         (setq buffer-file-name (expand-file-name file dir))
1056         (let ((version-control 'never))
1057           (save-buffer))))))
1058
1059 (defun package-refresh-contents ()
1060   "Download the ELPA archive description if needed.
1061 This informs Emacs about the latest versions of all packages, and
1062 makes them available for download."
1063   (interactive)
1064   (unless (file-exists-p package-user-dir)
1065     (make-directory package-user-dir t))
1066   (dolist (archive package-archives)
1067     (condition-case-no-debug nil
1068         (package--download-one-archive archive "archive-contents")
1069       (error (message "Failed to download `%s' archive."
1070                       (car archive)))))
1071   (package-read-all-archive-contents))
1072
1073 (defvar package--initialized nil)
1074
1075 ;;;###autoload
1076 (defun package-initialize (&optional no-activate)
1077   "Load Emacs Lisp packages, and activate them.
1078 The variable `package-load-list' controls which packages to load.
1079 If optional arg NO-ACTIVATE is non-nil, don't activate packages."
1080   (interactive)
1081   (setq package-alist nil
1082         package-obsolete-alist nil)
1083   (package-load-all-descriptors)
1084   (package-read-all-archive-contents)
1085   (unless no-activate
1086     (dolist (elt package-alist)
1087       (package-activate (car elt) (package-desc-vers (cdr elt)))))
1088   (setq package--initialized t))
1089
1090 \f
1091 ;;;; Package description buffer.
1092
1093 ;;;###autoload
1094 (defun describe-package (package)
1095   "Display the full documentation of PACKAGE (a symbol)."
1096   (interactive
1097    (let* ((guess (function-called-at-point))
1098           packages val)
1099      (require 'finder-inf nil t)
1100      ;; Load the package list if necessary (but don't activate them).
1101      (unless package--initialized
1102        (package-initialize t))
1103      (setq packages (append (mapcar 'car package-alist)
1104                             (mapcar 'car package-archive-contents)
1105                             (mapcar 'car package--builtins)))
1106      (unless (memq guess packages)
1107        (setq guess nil))
1108      (setq packages (mapcar 'symbol-name packages))
1109      (setq val
1110            (completing-read (if guess
1111                                 (format "Describe package (default %s): "
1112                                         guess)
1113                               "Describe package: ")
1114                             packages nil t nil nil guess))
1115      (list (if (equal val "") guess (intern val)))))
1116   (if (or (null package) (not (symbolp package)))
1117       (message "No package specified")
1118     (help-setup-xref (list #'describe-package package)
1119                      (called-interactively-p 'interactive))
1120     (with-help-window (help-buffer)
1121       (with-current-buffer standard-output
1122         (describe-package-1 package)))))
1123
1124 (defun describe-package-1 (package)
1125   (require 'lisp-mnt)
1126   (let ((package-name (symbol-name package))
1127         (built-in (assq package package--builtins))
1128         desc pkg-dir reqs version installable)
1129     (prin1 package)
1130     (princ " is ")
1131     (cond
1132      ;; Loaded packages are in `package-alist'.
1133      ((setq desc (cdr (assq package package-alist)))
1134       (setq version (package-version-join (package-desc-vers desc)))
1135       (if (setq pkg-dir (package--dir package-name version))
1136           (insert "an installed package.\n\n")
1137         ;; This normally does not happen.
1138         (insert "a deleted package.\n\n")))
1139      ;; Available packages are in `package-archive-contents'.
1140      ((setq desc (cdr (assq package package-archive-contents)))
1141       (setq version (package-version-join (package-desc-vers desc))
1142             installable t)
1143       (if built-in
1144           (insert "a built-in package.\n\n")
1145         (insert "an uninstalled package.\n\n")))
1146      (built-in
1147       (setq desc (cdr built-in)
1148             version (package-version-join (package-desc-vers desc)))
1149       (insert "a built-in package.\n\n"))
1150      (t
1151       (insert "an orphan package.\n\n")))
1152
1153     (insert "     " (propertize "Status" 'font-lock-face 'bold) ": ")
1154     (cond (pkg-dir
1155            (insert (propertize "Installed"
1156                                'font-lock-face 'font-lock-comment-face))
1157            (insert " in `")
1158            ;; Todo: Add button for uninstalling.
1159            (help-insert-xref-button (file-name-as-directory pkg-dir)
1160                                     'help-package-def pkg-dir)
1161            (if built-in
1162                (insert "',\n             shadowing a "
1163                        (propertize "built-in package"
1164                                    'font-lock-face 'font-lock-builtin-face)
1165                        ".")
1166              (insert "'.")))
1167           (installable
1168            (if built-in
1169                (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
1170                        "  Alternate version available -- ")
1171              (insert "Available -- "))
1172            (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
1173                  (button-face (if (display-graphic-p)
1174                                   '(:box (:line-width 2 :color "dark grey")
1175                                          :background "light grey"
1176                                          :foreground "black")
1177                                 'link)))
1178              (insert-text-button button-text 'face button-face 'follow-link t
1179                                  'package-symbol package
1180                                  'action 'package-install-button-action)))
1181           (built-in
1182            (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
1183           (t (insert "Deleted.")))
1184     (insert "\n")
1185     (and version (> (length version) 0)
1186          (insert "    "
1187                  (propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
1188
1189     (setq reqs (if desc (package-desc-reqs desc)))
1190     (when reqs
1191       (insert "   " (propertize "Requires" 'font-lock-face 'bold) ": ")
1192       (let ((first t)
1193             name vers text)
1194         (dolist (req reqs)
1195           (setq name (car req)
1196                 vers (cadr req)
1197                 text (format "%s-%s" (symbol-name name)
1198                              (package-version-join vers)))
1199           (cond (first (setq first nil))
1200                 ((>= (+ 2 (current-column) (length text))
1201                      (window-width))
1202                  (insert ",\n               "))
1203                 (t (insert ", ")))
1204           (help-insert-xref-button text 'help-package name))
1205         (insert "\n")))
1206     (insert "    " (propertize "Summary" 'font-lock-face 'bold)
1207             ": " (if desc (package-desc-doc desc)) "\n\n")
1208
1209     (if built-in
1210         ;; For built-in packages, insert the commentary.
1211         (let ((fn (locate-file (concat package-name ".el") load-path
1212                                load-file-rep-suffixes))
1213               (opoint (point)))
1214           (insert (or (lm-commentary fn) ""))
1215           (save-excursion
1216             (goto-char opoint)
1217             (when (re-search-forward "^;;; Commentary:\n" nil t)
1218               (replace-match ""))
1219             (while (re-search-forward "^\\(;+ ?\\)" nil t)
1220               (replace-match ""))))
1221       (let ((readme (expand-file-name (concat package-name "-readme.txt")
1222                                       package-user-dir))
1223             readme-string)
1224         ;; For elpa packages, try downloading the commentary.  If that
1225         ;; fails, try an existing readme file in `package-user-dir'.
1226         (cond ((condition-case nil
1227                    (package--with-work-buffer (package-archive-base package)
1228                                               (concat package-name "-readme.txt")
1229                      (setq buffer-file-name
1230                            (expand-file-name readme package-user-dir))
1231                      (let ((version-control 'never))
1232                        (save-buffer))
1233                      (setq readme-string (buffer-string))
1234                      t)
1235                  (error nil))
1236                (insert readme-string))
1237               ((file-readable-p readme)
1238                (insert-file-contents readme)
1239                (goto-char (point-max))))))))
1240
1241 (defun package-install-button-action (button)
1242   (let ((package (button-get button 'package-symbol)))
1243     (when (y-or-n-p (format "Install package `%s'? " package))
1244       (package-install package)
1245       (revert-buffer nil t)
1246       (goto-char (point-min)))))
1247
1248 \f
1249 ;;;; Package menu mode.
1250
1251 (defvar package-menu-mode-map
1252   (let ((map (copy-keymap special-mode-map))
1253         (menu-map (make-sparse-keymap "Package")))
1254     (set-keymap-parent map button-buffer-map)
1255     (define-key map "\C-m" 'package-menu-describe-package)
1256     (define-key map "n" 'next-line)
1257     (define-key map "p" 'previous-line)
1258     (define-key map "u" 'package-menu-mark-unmark)
1259     (define-key map "\177" 'package-menu-backup-unmark)
1260     (define-key map "d" 'package-menu-mark-delete)
1261     (define-key map "i" 'package-menu-mark-install)
1262     (define-key map "r" 'package-menu-refresh)
1263     (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
1264     (define-key map "x" 'package-menu-execute)
1265     (define-key map "h" 'package-menu-quick-help)
1266     (define-key map "?" 'package-menu-describe-package)
1267     (define-key map [follow-link] 'mouse-face)
1268     (define-key map [mouse-2] 'mouse-select-window)
1269     (define-key map [menu-bar package-menu] (cons "Package" menu-map))
1270     (define-key menu-map [mq]
1271       '(menu-item "Quit" quit-window
1272                   :help "Quit package selection"))
1273     (define-key menu-map [s1] '("--"))
1274     (define-key menu-map [mn]
1275       '(menu-item "Next" next-line
1276                   :help "Next Line"))
1277     (define-key menu-map [mp]
1278       '(menu-item "Previous" previous-line
1279                   :help "Previous Line"))
1280     (define-key menu-map [s2] '("--"))
1281     (define-key menu-map [mu]
1282       '(menu-item "Unmark" package-menu-mark-unmark
1283                   :help "Clear any marks on a package and move to the next line"))
1284     (define-key menu-map [munm]
1285       '(menu-item "Unmark backwards" package-menu-backup-unmark
1286                   :help "Back up one line and clear any marks on that package"))
1287     (define-key menu-map [md]
1288       '(menu-item "Mark for deletion" package-menu-mark-delete
1289                   :help "Mark a package for deletion and move to the next line"))
1290     (define-key menu-map [mi]
1291       '(menu-item "Mark for install" package-menu-mark-install
1292                   :help "Mark a package for installation and move to the next line"))
1293     (define-key menu-map [s3] '("--"))
1294     (define-key menu-map [mg]
1295       '(menu-item "Update package list" revert-buffer
1296                   :help "Update the list of packages"))
1297     (define-key menu-map [mr]
1298       '(menu-item "Refresh package list" package-menu-refresh
1299                   :help "Download the ELPA archive"))
1300     (define-key menu-map [s4] '("--"))
1301     (define-key menu-map [mt]
1302       '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion
1303                   :help "Mark all obsolete packages for deletion"))
1304     (define-key menu-map [mx]
1305       '(menu-item "Execute actions" package-menu-execute
1306                   :help "Perform all the marked actions"))
1307     (define-key menu-map [s5] '("--"))
1308     (define-key menu-map [mh]
1309       '(menu-item "Help" package-menu-quick-help
1310                   :help "Show short key binding help for package-menu-mode"))
1311     (define-key menu-map [mc]
1312       '(menu-item "View Commentary" package-menu-view-commentary
1313                   :help "Display information about this package"))
1314     map)
1315   "Local keymap for `package-menu-mode' buffers.")
1316
1317 (defvar package-menu-sort-button-map
1318   (let ((map (make-sparse-keymap)))
1319     (define-key map [header-line mouse-1] 'package-menu-sort-by-column)
1320     (define-key map [header-line mouse-2] 'package-menu-sort-by-column)
1321     (define-key map [follow-link] 'mouse-face)
1322     map)
1323   "Local keymap for package menu sort buttons.")
1324
1325 (put 'package-menu-mode 'mode-class 'special)
1326
1327 (define-derived-mode package-menu-mode special-mode "Package Menu"
1328   "Major mode for browsing a list of packages.
1329 Letters do not insert themselves; instead, they are commands.
1330 \\<package-menu-mode-map>
1331 \\{package-menu-mode-map}"
1332   (setq truncate-lines t)
1333   (setq buffer-read-only t)
1334   (set (make-local-variable 'revert-buffer-function) 'package-menu-revert)
1335   (setq header-line-format
1336         (mapconcat
1337          (lambda (pair)
1338            (let ((column (car pair))
1339                  (name (cdr pair)))
1340              (concat
1341               ;; Insert a space that aligns the button properly.
1342               (propertize " " 'display (list 'space :align-to column)
1343                           'face 'fixed-pitch)
1344               ;; Set up the column button.
1345               (propertize name
1346                           'column-name name
1347                           'help-echo "mouse-1: sort by column"
1348                           'mouse-face 'highlight
1349                           'keymap package-menu-sort-button-map))))
1350          ;; We take a trick from buff-menu and have a dummy leading
1351          ;; space to align the header line with the beginning of the
1352          ;; text.  This doesn't really work properly on Emacs 21, but
1353          ;; it is close enough.
1354          '((0 . "")
1355            (2 . "Package")
1356            (20 . "Version")
1357            (32 . "Status")
1358            (43 . "Description"))
1359          "")))
1360
1361 (defun package-menu-refresh ()
1362   "Download the Emacs Lisp package archive.
1363 This fetches the contents of each archive specified in
1364 `package-archives', and then refreshes the package menu."
1365   (interactive)
1366   (unless (eq major-mode 'package-menu-mode)
1367     (error "The current buffer is not a Package Menu"))
1368   (package-refresh-contents)
1369   (package--generate-package-list))
1370
1371 (defun package-menu-revert (&optional arg noconfirm)
1372   "Update the list of packages.
1373 This function is the `revert-buffer-function' for Package Menu
1374 buffers.  The arguments are ignored."
1375   (interactive)
1376   (unless (eq major-mode 'package-menu-mode)
1377     (error "The current buffer is not a Package Menu"))
1378   (package--generate-package-list))
1379
1380 (defun package-menu-describe-package ()
1381   "Describe the package in the current line."
1382   (interactive)
1383   (let ((name (package-menu-get-package)))
1384     (if name
1385         (describe-package (intern name))
1386       (message "No package on this line"))))
1387
1388 (defun package-menu-mark-internal (what)
1389   (unless (eobp)
1390     (let ((buffer-read-only nil))
1391       (beginning-of-line)
1392       (delete-char 1)
1393       (insert what)
1394       (forward-line))))
1395
1396 ;; fixme numeric argument
1397 (defun package-menu-mark-delete (num)
1398   "Mark a package for deletion and move to the next line."
1399   (interactive "p")
1400   (if (string-equal (package-menu-get-status) "installed")
1401       (package-menu-mark-internal "D")
1402     (forward-line)))
1403
1404 (defun package-menu-mark-install (num)
1405   "Mark a package for installation and move to the next line."
1406   (interactive "p")
1407   (if (string-equal (package-menu-get-status) "available")
1408       (package-menu-mark-internal "I")
1409     (forward-line)))
1410
1411 (defun package-menu-mark-unmark (num)
1412   "Clear any marks on a package and move to the next line."
1413   (interactive "p")
1414   (package-menu-mark-internal " "))
1415
1416 (defun package-menu-backup-unmark ()
1417   "Back up one line and clear any marks on that package."
1418   (interactive)
1419   (forward-line -1)
1420   (package-menu-mark-internal " ")
1421   (forward-line -1))
1422
1423 (defun package-menu-mark-obsolete-for-deletion ()
1424   "Mark all obsolete packages for deletion."
1425   (interactive)
1426   (save-excursion
1427     (goto-char (point-min))
1428     (forward-line 2)
1429     (while (not (eobp))
1430       (if (looking-at ".*\\s obsolete\\s ")
1431           (package-menu-mark-internal "D")
1432         (forward-line 1)))))
1433
1434 (defun package-menu-quick-help ()
1435   "Show short key binding help for package-menu-mode."
1436   (interactive)
1437   (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
1438
1439 (define-obsolete-function-alias
1440   'package-menu-view-commentary 'package-menu-describe-package "24.1")
1441
1442 ;; Return the name of the package on the current line.
1443 (defun package-menu-get-package ()
1444   (save-excursion
1445     (beginning-of-line)
1446     (if (looking-at ". \\([^ \t]*\\)")
1447         (match-string-no-properties 1))))
1448
1449 ;; Return the version of the package on the current line.
1450 (defun package-menu-get-version ()
1451   (save-excursion
1452     (beginning-of-line)
1453     (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)")
1454         (match-string 1))))
1455
1456 (defun package-menu-get-status ()
1457   (save-excursion
1458     (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
1459         (match-string 1)
1460       "")))
1461
1462 (defun package-menu-execute ()
1463   "Perform marked Package Menu actions.
1464 Packages marked for installation are downloaded and installed;
1465 packages marked for deletion are removed."
1466   (interactive)
1467   (let (install-list delete-list cmd)
1468     (save-excursion
1469       (goto-char (point-min))
1470       (while (not (eobp))
1471         (setq cmd (char-after))
1472         (cond
1473          ((eq cmd ?\s) t)
1474          ((eq cmd ?D)
1475           (push (cons (package-menu-get-package)
1476                       (package-menu-get-version))
1477                 delete-list))
1478          ((eq cmd ?I)
1479           (push (package-menu-get-package) install-list)))
1480         (forward-line)))
1481     ;; Delete packages, prompting if necessary.
1482     (when delete-list
1483       (if (yes-or-no-p
1484            (if (= (length delete-list) 1)
1485                (format "Delete package `%s-%s'? "
1486                        (caar delete-list)
1487                        (cdr (car delete-list)))
1488              (format "Delete these %d packages (%s)? "
1489                      (length delete-list)
1490                      (mapconcat (lambda (elt)
1491                                   (concat (car elt) "-" (cdr elt)))
1492                                 delete-list
1493                                 ", "))))
1494           (dolist (elt delete-list)
1495             (condition-case-no-debug err
1496                 (package-delete (car elt) (cdr elt))
1497               (error (message (cadr err)))))
1498         (error "Aborted")))
1499     (when install-list
1500       (if (yes-or-no-p
1501            (if (= (length install-list) 1)
1502                (format "Install package `%s'? " (car install-list))
1503              (format "Install these %d packages (%s)? "
1504                      (length install-list)
1505                      (mapconcat 'identity install-list ", "))))
1506           (dolist (elt install-list)
1507             (package-install (intern elt)))))
1508     ;; If we deleted anything, regenerate `package-alist'.  This is done
1509     ;; automatically if we installed a package.
1510     (and delete-list (null install-list)
1511          (package-initialize))
1512     (if (or delete-list install-list)
1513         (package-menu-revert)
1514       (message "No operations specified."))))
1515
1516 (defun package-print-package (package version key desc)
1517   (let ((face
1518          (cond ((string= key "built-in") 'font-lock-builtin-face)
1519                ((string= key "available") 'default)
1520                ((string= key "held") 'font-lock-constant-face)
1521                ((string= key "disabled") 'font-lock-warning-face)
1522                ((string= key "installed") 'font-lock-comment-face)
1523                (t ; obsolete, but also the default.
1524                 'font-lock-warning-face))))
1525     (insert (propertize "  " 'font-lock-face face))
1526     (insert-text-button (symbol-name package)
1527                         'face 'link
1528                         'follow-link t
1529                         'package-symbol package
1530                         'action (lambda (button)
1531                                   (describe-package
1532                                    (button-get button 'package-symbol))))
1533     (indent-to 20 1)
1534     (insert (propertize (package-version-join version) 'font-lock-face face))
1535     (indent-to 32 1)
1536     (insert (propertize key 'font-lock-face face))
1537     ;; FIXME: this 'when' is bogus...
1538     (when desc
1539       (indent-to 43 1)
1540       (let ((opoint (point)))
1541         (insert (propertize desc 'font-lock-face face))
1542         (upcase-region opoint (min (point) (1+ opoint)))))
1543     (insert "\n")))
1544
1545 (defun package-list-maybe-add (package version status description result)
1546   (unless (assoc (cons package version) result)
1547     (push (list (cons package version) status description) result))
1548   result)
1549
1550 (defvar package-menu-package-list nil
1551   "List of packages to display in the Package Menu buffer.
1552 A value of nil means to display all packages.")
1553
1554 (defvar package-menu-sort-key nil
1555   "Sort key for the current Package Menu buffer.")
1556
1557 (defun package--generate-package-list ()
1558   "Populate the current Package Menu buffer."
1559   (let ((inhibit-read-only t)
1560         info-list name desc hold builtin)
1561     (erase-buffer)
1562     ;; List installed packages
1563     (dolist (elt package-alist)
1564       (setq name (car elt))
1565       (when (or (null package-menu-package-list)
1566                 (memq name package-menu-package-list))
1567         (setq desc (cdr elt)
1568               hold (cadr (assq name package-load-list)))
1569         (setq info-list
1570               (package-list-maybe-add
1571                name (package-desc-vers desc)
1572                ;; FIXME: it turns out to be tricky to see if this
1573                ;; package is presently activated.
1574                (if (stringp hold) "held" "installed")
1575                (package-desc-doc desc)
1576                info-list))))
1577
1578     ;; List built-in packages
1579     (dolist (elt package--builtins)
1580       (setq name (car elt))
1581       (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
1582                  (or (null package-menu-package-list)
1583                      (memq name package-menu-package-list)))
1584         (setq desc (cdr elt))
1585         (setq info-list
1586               (package-list-maybe-add
1587                name (package-desc-vers desc)
1588                "built-in"
1589                (package-desc-doc desc)
1590                info-list))))
1591
1592     ;; List available and disabled packages
1593     (dolist (elt package-archive-contents)
1594       (setq name (car elt)
1595             desc (cdr elt)
1596             hold (assq name package-load-list))
1597       (when (or (null package-menu-package-list)
1598                 (memq name package-menu-package-list))
1599         (setq info-list
1600               (package-list-maybe-add name
1601                                       (package-desc-vers desc)
1602                                       (if (and hold (null (cadr hold)))
1603                                           "disabled"
1604                                         "available")
1605                                       (package-desc-doc (cdr elt))
1606                                       info-list))))
1607     ;; List obsolete packages
1608     (mapc (lambda (elt)
1609             (mapc (lambda (inner-elt)
1610                     (setq info-list
1611                           (package-list-maybe-add (car elt)
1612                                                   (package-desc-vers
1613                                                    (cdr inner-elt))
1614                                                   "obsolete"
1615                                                   (package-desc-doc
1616                                                    (cdr inner-elt))
1617                                                   info-list)))
1618                   (cdr elt)))
1619           package-obsolete-alist)
1620
1621     (setq info-list
1622           (sort info-list
1623                 (cond ((string= package-menu-sort-key "Package")
1624                        'package-menu--name-predicate)
1625                       ((string= package-menu-sort-key "Version")
1626                        'package-menu--version-predicate)
1627                       ((string= package-menu-sort-key "Description")
1628                        'package-menu--description-predicate)
1629                       (t ; By default, sort by package status
1630                        'package-menu--status-predicate))))
1631
1632     (dolist (elt info-list)
1633       (package-print-package (car (car elt))
1634                              (cdr (car elt))
1635                              (car (cdr elt))
1636                              (car (cdr (cdr elt)))))
1637     (goto-char (point-min))
1638     (set-buffer-modified-p nil)
1639     (current-buffer)))
1640
1641 (defun package-menu--version-predicate (left right)
1642   (let ((vleft  (or (cdr (car left))  '(0)))
1643         (vright (or (cdr (car right)) '(0))))
1644     (if (version-list-= vleft vright)
1645         (package-menu--name-predicate left right)
1646       (version-list-< vleft vright))))
1647
1648 (defun package-menu--status-predicate (left right)
1649   (let ((sleft  (cadr left))
1650         (sright (cadr right)))
1651     (cond ((string= sleft sright)
1652            (package-menu--name-predicate left right))
1653           ((string= sleft  "available") t)
1654           ((string= sright "available") nil)
1655           ((string= sleft  "installed") t)
1656           ((string= sright "installed") nil)
1657           ((string= sleft  "held") t)
1658           ((string= sright "held") nil)
1659           ((string= sleft  "built-in") t)
1660           ((string= sright "built-in") nil)
1661           ((string= sleft  "obsolete") t)
1662           ((string= sright  "obsolete") nil)
1663           (t (string< sleft sright)))))
1664
1665 (defun package-menu--description-predicate (left right)
1666   (let ((sleft  (car (cddr left)))
1667         (sright (car (cddr right))))
1668     (if (string= sleft sright)
1669         (package-menu--name-predicate left right)
1670       (string< sleft sright))))
1671
1672 (defun package-menu--name-predicate (left right)
1673   (string< (symbol-name (caar left))
1674            (symbol-name (caar right))))
1675
1676 (defun package-menu-sort-by-column (&optional e)
1677   "Sort the package menu by the column of the mouse click E."
1678   (interactive "e")
1679   (let* ((pos (event-start e))
1680          (obj (posn-object pos))
1681          (col (if obj
1682                   (get-text-property (cdr obj) 'column-name (car obj))
1683                 (get-text-property (posn-point pos) 'column-name)))
1684          (buf (window-buffer (posn-window (event-start e)))))
1685     (with-current-buffer buf
1686       (when (eq major-mode 'package-menu-mode)
1687         (setq package-menu-sort-key col)
1688         (package--generate-package-list)))))
1689
1690 (defun package--list-packages (&optional packages)
1691   "Generate and pop to the *Packages* buffer.
1692 Optional PACKAGES is a list of names of packages (symbols) to
1693 list; the default is to display everything in `package-alist'."
1694   (require 'finder-inf nil t)
1695   (let ((buf (get-buffer-create "*Packages*")))
1696     (with-current-buffer buf
1697       (package-menu-mode)
1698       (set (make-local-variable 'package-menu-package-list) packages)
1699       (set (make-local-variable 'package-menu-sort-key) nil)
1700       (package--generate-package-list))
1701     ;; The package menu buffer has keybindings.  If the user types
1702     ;; `M-x list-packages', that suggests it should become current.
1703     (switch-to-buffer buf)))
1704
1705 ;;;###autoload
1706 (defun list-packages ()
1707   "Display a list of packages.
1708 Fetches the updated list of packages before displaying.
1709 The list is displayed in a buffer named `*Packages*'."
1710   (interactive)
1711   ;; Initialize the package system if necessary.
1712   (unless package--initialized
1713     (package-initialize t))
1714   (package-refresh-contents)
1715   (package--list-packages))
1716
1717 ;;;###autoload
1718 (defalias 'package-list-packages 'list-packages)
1719
1720 (defun package-list-packages-no-fetch ()
1721   "Display a list of packages.
1722 Does not fetch the updated list of packages before displaying.
1723 The list is displayed in a buffer named `*Packages*'."
1724   (interactive)
1725   (package--list-packages))
1726
1727 (provide 'package)
1728
1729 ;;; package.el ends here