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