Mercurial > dotfiles
comparison .elisp/old/package.el @ 336:ea73ef5dc38c
emacs: avoid weird package.el breakage with newish packages
I've been toting around this package.el from 2009 or so, and something
in the package format seems to have changed that broke me. Thanks to
some related diagnostics by Lucas, I've grabbed the last package.el
that worked with emacs 23 and stashed it here. This seems to work,
modulo some things (notably js2-mode and smex) now seem to require
emacs 24 if you install them using package.el, so this will end up
being brittle on my last couple of emacs23 machines.
| author | Augie Fackler <raf@durin42.com> |
|---|---|
| date | Thu, 29 May 2014 14:30:42 -0400 |
| parents | .elisp/package.el@8980dc2deda0 |
| children |
comparison
equal
deleted
inserted
replaced
| 335:7a736d851718 | 336:ea73ef5dc38c |
|---|---|
| 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 (defconst package-subdirectory-regexp | |
| 323 "\\`\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)\\'" | |
| 324 "Regular expression matching the name of a package subdirectory. | |
| 325 The first subexpression is the package name. | |
| 326 The second subexpression is the version string.") | |
| 327 | |
| 328 (defun package-version-join (vlist) | |
| 329 "Return the version string corresponding to the list VLIST. | |
| 330 This is, approximately, the inverse of `version-to-list'. | |
| 331 \(Actually, it returns only one of the possible inverses, since | |
| 332 `version-to-list' is a many-to-one operation.)" | |
| 333 (if (null vlist) | |
| 334 "" | |
| 335 (let ((str-list (list "." (int-to-string (car vlist))))) | |
| 336 (dolist (num (cdr vlist)) | |
| 337 (cond | |
| 338 ((>= num 0) | |
| 339 (push (int-to-string num) str-list) | |
| 340 (push "." str-list)) | |
| 341 ((< num -3) | |
| 342 (error "Invalid version list `%s'" vlist)) | |
| 343 (t | |
| 344 ;; pre, or beta, or alpha | |
| 345 (cond ((equal "." (car str-list)) | |
| 346 (pop str-list)) | |
| 347 ((not (string-match "[0-9]+" (car str-list))) | |
| 348 (error "Invalid version list `%s'" vlist))) | |
| 349 (push (cond ((= num -1) "pre") | |
| 350 ((= num -2) "beta") | |
| 351 ((= num -3) "alpha")) | |
| 352 str-list)))) | |
| 353 (if (equal "." (car str-list)) | |
| 354 (pop str-list)) | |
| 355 (apply 'concat (nreverse str-list))))) | |
| 356 | |
| 357 (defun package-strip-version (dirname) | |
| 358 "Strip the version from a combined package name and version. | |
| 359 E.g., if given \"quux-23.0\", will return \"quux\"" | |
| 360 (if (string-match package-subdirectory-regexp dirname) | |
| 361 (match-string 1 dirname))) | |
| 362 | |
| 363 (defun package-load-descriptor (dir package) | |
| 364 "Load the description file in directory DIR for package PACKAGE. | |
| 365 Here, PACKAGE is a string of the form NAME-VER, where NAME is the | |
| 366 package name and VER is its version." | |
| 367 (let* ((pkg-dir (expand-file-name package dir)) | |
| 368 (pkg-file (expand-file-name | |
| 369 (concat (package-strip-version package) "-pkg") | |
| 370 pkg-dir))) | |
| 371 (when (and (file-directory-p pkg-dir) | |
| 372 (file-exists-p (concat pkg-file ".el"))) | |
| 373 (load pkg-file nil t)))) | |
| 374 | |
| 375 (defun package-load-all-descriptors () | |
| 376 "Load descriptors for installed Emacs Lisp packages. | |
| 377 This looks for package subdirectories in `package-user-dir' and | |
| 378 `package-directory-list'. The variable `package-load-list' | |
| 379 controls which package subdirectories may be loaded. | |
| 380 | |
| 381 In each valid package subdirectory, this function loads the | |
| 382 description file containing a call to `define-package', which | |
| 383 updates `package-alist' and `package-obsolete-alist'." | |
| 384 (let ((all (memq 'all package-load-list)) | |
| 385 name version force) | |
| 386 (dolist (dir (cons package-user-dir package-directory-list)) | |
| 387 (when (file-directory-p dir) | |
| 388 (dolist (subdir (directory-files dir)) | |
| 389 (when (and (file-directory-p (expand-file-name subdir dir)) | |
| 390 (string-match package-subdirectory-regexp subdir)) | |
| 391 (setq name (intern (match-string 1 subdir)) | |
| 392 version (match-string 2 subdir) | |
| 393 force (assq name package-load-list)) | |
| 394 (when (cond | |
| 395 ((null force) | |
| 396 all) ; not in package-load-list | |
| 397 ((null (setq force (cadr force))) | |
| 398 nil) ; disabled | |
| 399 ((eq force t) | |
| 400 t) | |
| 401 ((stringp force) ; held | |
| 402 (version-list-= (version-to-list version) | |
| 403 (version-to-list force))) | |
| 404 (t | |
| 405 (error "Invalid element in `package-load-list'"))) | |
| 406 (package-load-descriptor dir subdir)))))))) | |
| 407 | |
| 408 (defsubst package-desc-vers (desc) | |
| 409 "Extract version from a package description vector." | |
| 410 (aref desc 0)) | |
| 411 | |
| 412 (defsubst package-desc-reqs (desc) | |
| 413 "Extract requirements from a package description vector." | |
| 414 (aref desc 1)) | |
| 415 | |
| 416 (defsubst package-desc-doc (desc) | |
| 417 "Extract doc string from a package description vector." | |
| 418 (aref desc 2)) | |
| 419 | |
| 420 (defsubst package-desc-kind (desc) | |
| 421 "Extract the kind of download from an archive package description vector." | |
| 422 (aref desc 3)) | |
| 423 | |
| 424 (defun package--dir (name version) | |
| 425 "Return the directory where a package is installed, or nil if none. | |
| 426 NAME and VERSION are both strings." | |
| 427 (let* ((subdir (concat name "-" version)) | |
| 428 (dir-list (cons package-user-dir package-directory-list)) | |
| 429 pkg-dir) | |
| 430 (while dir-list | |
| 431 (let ((subdir-full (expand-file-name subdir (car dir-list)))) | |
| 432 (if (file-directory-p subdir-full) | |
| 433 (setq pkg-dir subdir-full | |
| 434 dir-list nil) | |
| 435 (setq dir-list (cdr dir-list))))) | |
| 436 pkg-dir)) | |
| 437 | |
| 438 (defun package-activate-1 (package pkg-vec) | |
| 439 (let* ((name (symbol-name package)) | |
| 440 (version-str (package-version-join (package-desc-vers pkg-vec))) | |
| 441 (pkg-dir (package--dir name version-str))) | |
| 442 (unless pkg-dir | |
| 443 (error "Internal error: unable to find directory for `%s-%s'" | |
| 444 name version-str)) | |
| 445 ;; Add info node. | |
| 446 (when (file-exists-p (expand-file-name "dir" pkg-dir)) | |
| 447 ;; FIXME: not the friendliest, but simple. | |
| 448 (require 'info) | |
| 449 (info-initialize) | |
| 450 (push pkg-dir Info-directory-list)) | |
| 451 ;; Add to load path, add autoloads, and activate the package. | |
| 452 (push pkg-dir load-path) | |
| 453 (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) | |
| 454 (push package package-activated-list) | |
| 455 ;; Don't return nil. | |
| 456 t)) | |
| 457 | |
| 458 (defun package-built-in-p (package &optional version) | |
| 459 "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs." | |
| 460 (require 'finder-inf nil t) ; For `package--builtins'. | |
| 461 (let ((elt (assq package package--builtins))) | |
| 462 (and elt (version-list-<= version (package-desc-vers (cdr elt)))))) | |
| 463 | |
| 464 ;; This function goes ahead and activates a newer version of a package | |
| 465 ;; if an older one was already activated. This is not ideal; we'd at | |
| 466 ;; least need to check to see if the package has actually been loaded, | |
| 467 ;; and not merely activated. | |
| 468 (defun package-activate (package version) | |
| 469 "Activate package PACKAGE, of version VERSION or newer. | |
| 470 If PACKAGE has any dependencies, recursively activate them. | |
| 471 Return nil if the package could not be activated." | |
| 472 (let ((pkg-vec (cdr (assq package package-alist))) | |
| 473 available-version found) | |
| 474 ;; Check if PACKAGE is available in `package-alist'. | |
| 475 (when pkg-vec | |
| 476 (setq available-version (package-desc-vers pkg-vec) | |
| 477 found (version-list-<= version available-version))) | |
| 478 (cond | |
| 479 ;; If no such package is found, maybe it's built-in. | |
| 480 ((null found) | |
| 481 (package-built-in-p package version)) | |
| 482 ;; If the package is already activated, just return t. | |
| 483 ((memq package package-activated-list) | |
| 484 t) | |
| 485 ;; Otherwise, proceed with activation. | |
| 486 (t | |
| 487 (let ((fail (catch 'dep-failure | |
| 488 ;; Activate its dependencies recursively. | |
| 489 (dolist (req (package-desc-reqs pkg-vec)) | |
| 490 (unless (package-activate (car req) (cadr req)) | |
| 491 (throw 'dep-failure req)))))) | |
| 492 (if fail | |
| 493 (warn "Unable to activate package `%s'. | |
| 494 Required package `%s-%s' is unavailable" | |
| 495 package (car fail) (package-version-join (cadr fail))) | |
| 496 ;; If all goes well, activate the package itself. | |
| 497 (package-activate-1 package pkg-vec))))))) | |
| 498 | |
| 499 (defun package-mark-obsolete (package pkg-vec) | |
| 500 "Put package on the obsolete list, if not already there." | |
| 501 (let ((elt (assq package package-obsolete-alist))) | |
| 502 (if elt | |
| 503 ;; If this obsolete version does not exist in the list, update | |
| 504 ;; it the list. | |
| 505 (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) | |
| 506 (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) | |
| 507 (cdr elt)))) | |
| 508 ;; Make a new association. | |
| 509 (push (cons package (list (cons (package-desc-vers pkg-vec) | |
| 510 pkg-vec))) | |
| 511 package-obsolete-alist)))) | |
| 512 | |
| 513 (defun define-package (name-string version-string | |
| 514 &optional docstring requirements | |
| 515 &rest extra-properties) | |
| 516 "Define a new package. | |
| 517 NAME-STRING is the name of the package, as a string. | |
| 518 VERSION-STRING is the version of the package, as a list of | |
| 519 integers of the form produced by `version-to-list'. | |
| 520 DOCSTRING is a short description of the package, a string. | |
| 521 REQUIREMENTS is a list of dependencies on other packages. | |
| 522 Each requirement is of the form (OTHER-PACKAGE \"VERSION\"). | |
| 523 | |
| 524 EXTRA-PROPERTIES is currently unused." | |
| 525 (let* ((name (intern name-string)) | |
| 526 (version (version-to-list version-string)) | |
| 527 (new-pkg-desc | |
| 528 (cons name | |
| 529 (vector version | |
| 530 (mapcar | |
| 531 (lambda (elt) | |
| 532 (list (car elt) | |
| 533 (version-to-list (car (cdr elt))))) | |
| 534 requirements) | |
| 535 docstring))) | |
| 536 (old-pkg (assq name package-alist))) | |
| 537 (cond | |
| 538 ;; If there's no old package, just add this to `package-alist'. | |
| 539 ((null old-pkg) | |
| 540 (push new-pkg-desc package-alist)) | |
| 541 ((version-list-< (package-desc-vers (cdr old-pkg)) version) | |
| 542 ;; Remove the old package and declare it obsolete. | |
| 543 (package-mark-obsolete name (cdr old-pkg)) | |
| 544 (setq package-alist (cons new-pkg-desc | |
| 545 (delq old-pkg package-alist)))) | |
| 546 ;; You can have two packages with the same version, e.g. one in | |
| 547 ;; the system package directory and one in your private | |
| 548 ;; directory. We just let the first one win. | |
| 549 ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) | |
| 550 ;; The package is born obsolete. | |
| 551 (package-mark-obsolete name (cdr new-pkg-desc)))))) | |
| 552 | |
| 553 ;; From Emacs 22. | |
| 554 (defun package-autoload-ensure-default-file (file) | |
| 555 "Make sure that the autoload file FILE exists and if not create it." | |
| 556 (unless (file-exists-p file) | |
| 557 (write-region | |
| 558 (concat ";;; " (file-name-nondirectory file) | |
| 559 " --- automatically extracted autoloads\n" | |
| 560 ";;\n" | |
| 561 ";;; Code:\n\n" | |
| 562 " \n;; Local Variables:\n" | |
| 563 ";; version-control: never\n" | |
| 564 ";; no-byte-compile: t\n" | |
| 565 ";; no-update-autoloads: t\n" | |
| 566 ";; End:\n" | |
| 567 ";;; " (file-name-nondirectory file) | |
| 568 " ends here\n") | |
| 569 nil file)) | |
| 570 file) | |
| 571 | |
| 572 (defun package-generate-autoloads (name pkg-dir) | |
| 573 (let* ((auto-name (concat name "-autoloads.el")) | |
| 574 (ignore-name (concat name "-pkg.el")) | |
| 575 (generated-autoload-file (expand-file-name auto-name pkg-dir)) | |
| 576 (version-control 'never)) | |
| 577 (require 'autoload) | |
| 578 (unless (fboundp 'autoload-ensure-default-file) | |
| 579 (package-autoload-ensure-default-file generated-autoload-file)) | |
| 580 (update-directory-autoloads pkg-dir))) | |
| 581 | |
| 582 (defun package-untar-buffer () | |
| 583 "Untar the current buffer. | |
| 584 This uses `tar-untar-buffer' if it is available. | |
| 585 Otherwise it uses an external `tar' program. | |
| 586 `default-directory' should be set by the caller." | |
| 587 (require 'tar-mode) | |
| 588 (if (fboundp 'tar-untar-buffer) | |
| 589 (progn | |
| 590 ;; tar-mode messes with narrowing, so we just let it have the | |
| 591 ;; whole buffer to play with. | |
| 592 (delete-region (point-min) (point)) | |
| 593 (tar-mode) | |
| 594 (tar-untar-buffer)) | |
| 595 ;; FIXME: check the result. | |
| 596 (call-process-region (point) (point-max) "tar" nil '(nil nil) nil | |
| 597 "xf" "-"))) | |
| 598 | |
| 599 (defun package-unpack (name version) | |
| 600 (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) | |
| 601 package-user-dir))) | |
| 602 (make-directory package-user-dir t) | |
| 603 ;; FIXME: should we delete PKG-DIR if it exists? | |
| 604 (let* ((default-directory (file-name-as-directory package-user-dir))) | |
| 605 (package-untar-buffer) | |
| 606 (package-generate-autoloads (symbol-name name) pkg-dir) | |
| 607 (let ((load-path (cons pkg-dir load-path))) | |
| 608 (byte-recompile-directory pkg-dir 0 t))))) | |
| 609 | |
| 610 (defun package--write-file-no-coding (file-name) | |
| 611 (let ((buffer-file-coding-system 'no-conversion)) | |
| 612 (write-region (point-min) (point-max) file-name))) | |
| 613 | |
| 614 (defun package-unpack-single (file-name version desc requires) | |
| 615 "Install the contents of the current buffer as a package." | |
| 616 ;; Special case "package". | |
| 617 (if (string= file-name "package") | |
| 618 (package--write-file-no-coding | |
| 619 (expand-file-name (concat file-name ".el") package-user-dir)) | |
| 620 (let* ((pkg-dir (expand-file-name (concat file-name "-" | |
| 621 (package-version-join | |
| 622 (version-to-list version))) | |
| 623 package-user-dir)) | |
| 624 (el-file (expand-file-name (concat file-name ".el") pkg-dir)) | |
| 625 (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) | |
| 626 (make-directory pkg-dir t) | |
| 627 (package--write-file-no-coding el-file) | |
| 628 (let ((print-level nil) | |
| 629 (print-length nil)) | |
| 630 (write-region | |
| 631 (concat | |
| 632 (prin1-to-string | |
| 633 (list 'define-package | |
| 634 file-name | |
| 635 version | |
| 636 desc | |
| 637 (list 'quote | |
| 638 ;; Turn version lists into string form. | |
| 639 (mapcar | |
| 640 (lambda (elt) | |
| 641 (list (car elt) | |
| 642 (package-version-join (cadr elt)))) | |
| 643 requires)))) | |
| 644 "\n") | |
| 645 nil | |
| 646 pkg-file | |
| 647 nil nil nil 'excl)) | |
| 648 (package-generate-autoloads file-name pkg-dir) | |
| 649 (let ((load-path (cons pkg-dir load-path))) | |
| 650 (byte-recompile-directory pkg-dir 0 t))))) | |
| 651 | |
| 652 (defmacro package--with-work-buffer (location file &rest body) | |
| 653 "Run BODY in a buffer containing the contents of FILE at LOCATION. | |
| 654 LOCATION is the base location of a package archive, and should be | |
| 655 one of the URLs (or file names) specified in `package-archives'. | |
| 656 FILE is the name of a file relative to that base location. | |
| 657 | |
| 658 This macro retrieves FILE from LOCATION into a temporary buffer, | |
| 659 and evaluates BODY while that buffer is current. This work | |
| 660 buffer is killed afterwards. Return the last value in BODY." | |
| 661 `(let* ((http (string-match "\\`http:" ,location)) | |
| 662 (buffer | |
| 663 (if http | |
| 664 (url-retrieve-synchronously (concat ,location ,file)) | |
| 665 (generate-new-buffer "*package work buffer*")))) | |
| 666 (prog1 | |
| 667 (with-current-buffer buffer | |
| 668 (if http | |
| 669 (progn (package-handle-response) | |
| 670 (re-search-forward "^$" nil 'move) | |
| 671 (forward-char) | |
| 672 (delete-region (point-min) (point))) | |
| 673 (unless (file-name-absolute-p ,location) | |
| 674 (error "Archive location %s is not an absolute file name" | |
| 675 ,location)) | |
| 676 (insert-file-contents (expand-file-name ,file ,location))) | |
| 677 ,@body) | |
| 678 (kill-buffer buffer)))) | |
| 679 | |
| 680 (defun package-handle-response () | |
| 681 "Handle the response from a `url-retrieve-synchronously' call. | |
| 682 Parse the HTTP response and throw if an error occurred. | |
| 683 The url package seems to require extra processing for this. | |
| 684 This should be called in a `save-excursion', in the download buffer. | |
| 685 It will move point to somewhere in the headers." | |
| 686 ;; We assume HTTP here. | |
| 687 (require 'url-http) | |
| 688 (let ((response (url-http-parse-response))) | |
| 689 (when (or (< response 200) (>= response 300)) | |
| 690 (error "Error during download request:%s" | |
| 691 (buffer-substring-no-properties (point) (progn | |
| 692 (end-of-line) | |
| 693 (point))))))) | |
| 694 | |
| 695 (defun package-download-single (name version desc requires) | |
| 696 "Download and install a single-file package." | |
| 697 (let ((location (package-archive-base name)) | |
| 698 (file (concat (symbol-name name) "-" version ".el"))) | |
| 699 (package--with-work-buffer location file | |
| 700 (package-unpack-single (symbol-name name) version desc requires)))) | |
| 701 | |
| 702 (defun package-download-tar (name version) | |
| 703 "Download and install a tar package." | |
| 704 (let ((location (package-archive-base name)) | |
| 705 (file (concat (symbol-name name) "-" version ".tar"))) | |
| 706 (package--with-work-buffer location file | |
| 707 (package-unpack name version)))) | |
| 708 | |
| 709 (defun package-installed-p (package &optional min-version) | |
| 710 "Return true if PACKAGE, of VERSION or newer, is installed. | |
| 711 Built-in packages also qualify." | |
| 712 (let ((pkg-desc (assq package package-alist))) | |
| 713 (if pkg-desc | |
| 714 (version-list-<= min-version | |
| 715 (package-desc-vers (cdr pkg-desc))) | |
| 716 ;; Also check built-in packages. | |
| 717 (package-built-in-p package min-version)))) | |
| 718 | |
| 719 (defun package-compute-transaction (package-list requirements) | |
| 720 "Return a list of packages to be installed, including PACKAGE-LIST. | |
| 721 PACKAGE-LIST should be a list of package names (symbols). | |
| 722 | |
| 723 REQUIREMENTS should be a list of additional requirements; each | |
| 724 element in this list should have the form (PACKAGE VERSION), | |
| 725 where PACKAGE is a package name and VERSION is the required | |
| 726 version of that package (as a list). | |
| 727 | |
| 728 This function recursively computes the requirements of the | |
| 729 packages in REQUIREMENTS, and returns a list of all the packages | |
| 730 that must be installed. Packages that are already installed are | |
| 731 not included in this list." | |
| 732 (dolist (elt requirements) | |
| 733 (let* ((next-pkg (car elt)) | |
| 734 (next-version (cadr elt))) | |
| 735 (unless (package-installed-p next-pkg next-version) | |
| 736 ;; A package is required, but not installed. It might also be | |
| 737 ;; blocked via `package-load-list'. | |
| 738 (let ((pkg-desc (assq next-pkg package-archive-contents)) | |
| 739 hold) | |
| 740 (when (setq hold (assq next-pkg package-load-list)) | |
| 741 (setq hold (cadr hold)) | |
| 742 (cond ((eq hold nil) | |
| 743 (error "Required package '%s' is disabled" | |
| 744 (symbol-name next-pkg))) | |
| 745 ((null (stringp hold)) | |
| 746 (error "Invalid element in `package-load-list'")) | |
| 747 ((version-list-< (version-to-list hold) next-version) | |
| 748 (error "Package `%s' held at version %s, \ | |
| 749 but version %s required" | |
| 750 (symbol-name next-pkg) hold | |
| 751 (package-version-join next-version))))) | |
| 752 (unless pkg-desc | |
| 753 (error "Package `%s-%s' is unavailable" | |
| 754 (symbol-name next-pkg) | |
| 755 (package-version-join next-version))) | |
| 756 (unless (version-list-<= next-version | |
| 757 (package-desc-vers (cdr pkg-desc))) | |
| 758 (error | |
| 759 "Need package `%s-%s', but only %s is available" | |
| 760 (symbol-name next-pkg) (package-version-join next-version) | |
| 761 (package-version-join (package-desc-vers (cdr pkg-desc))))) | |
| 762 ;; Only add to the transaction if we don't already have it. | |
| 763 (unless (memq next-pkg package-list) | |
| 764 (push next-pkg package-list)) | |
| 765 (setq package-list | |
| 766 (package-compute-transaction package-list | |
| 767 (package-desc-reqs | |
| 768 (cdr pkg-desc)))))))) | |
| 769 package-list) | |
| 770 | |
| 771 (defun package-read-from-string (str) | |
| 772 "Read a Lisp expression from STR. | |
| 773 Signal an error if the entire string was not used." | |
| 774 (let* ((read-data (read-from-string str)) | |
| 775 (more-left | |
| 776 (condition-case nil | |
| 777 ;; The call to `ignore' suppresses a compiler warning. | |
| 778 (progn (ignore (read-from-string | |
| 779 (substring str (cdr read-data)))) | |
| 780 t) | |
| 781 (end-of-file nil)))) | |
| 782 (if more-left | |
| 783 (error "Can't read whole string") | |
| 784 (car read-data)))) | |
| 785 | |
| 786 (defun package--read-archive-file (file) | |
| 787 "Re-read archive file FILE, if it exists. | |
| 788 Will return the data from the file, or nil if the file does not exist. | |
| 789 Will throw an error if the archive version is too new." | |
| 790 (let ((filename (expand-file-name file package-user-dir))) | |
| 791 (when (file-exists-p filename) | |
| 792 (with-temp-buffer | |
| 793 (insert-file-contents-literally filename) | |
| 794 (let ((contents (read (current-buffer)))) | |
| 795 (if (> (car contents) package-archive-version) | |
| 796 (error "Package archive version %d is higher than %d" | |
| 797 (car contents) package-archive-version)) | |
| 798 (cdr contents)))))) | |
| 799 | |
| 800 (defun package-read-all-archive-contents () | |
| 801 "Re-read `archive-contents', if it exists. | |
| 802 If successful, set `package-archive-contents'." | |
| 803 (setq package-archive-contents nil) | |
| 804 (dolist (archive package-archives) | |
| 805 (package-read-archive-contents (car archive)))) | |
| 806 | |
| 807 (defun package-read-archive-contents (archive) | |
| 808 "Re-read archive contents for ARCHIVE. | |
| 809 If successful, set the variable `package-archive-contents'. | |
| 810 If the archive version is too new, signal an error." | |
| 811 ;; Version 1 of 'archive-contents' is identical to our internal | |
| 812 ;; representation. | |
| 813 (let* ((dir (concat "archives/" archive)) | |
| 814 (contents-file (concat dir "/archive-contents")) | |
| 815 contents) | |
| 816 (when (setq contents (package--read-archive-file contents-file)) | |
| 817 (dolist (package contents) | |
| 818 (package--add-to-archive-contents package archive))))) | |
| 819 | |
| 820 (defun package--add-to-archive-contents (package archive) | |
| 821 "Add the PACKAGE from the given ARCHIVE if necessary. | |
| 822 Also, add the originating archive to the end of the package vector." | |
| 823 (let* ((name (car package)) | |
| 824 (version (aref (cdr package) 0)) | |
| 825 (entry (cons (car package) | |
| 826 (vconcat (cdr package) (vector archive)))) | |
| 827 (existing-package (cdr (assq name package-archive-contents)))) | |
| 828 (when (or (not existing-package) | |
| 829 (version-list-< (aref existing-package 0) version)) | |
| 830 (add-to-list 'package-archive-contents entry)))) | |
| 831 | |
| 832 (defun package-download-transaction (package-list) | |
| 833 "Download and install all the packages in PACKAGE-LIST. | |
| 834 PACKAGE-LIST should be a list of package names (symbols). | |
| 835 This function assumes that all package requirements in | |
| 836 PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed | |
| 837 using `package-compute-transaction'." | |
| 838 (dolist (elt package-list) | |
| 839 (let* ((desc (cdr (assq elt package-archive-contents))) | |
| 840 ;; As an exception, if package is "held" in | |
| 841 ;; `package-load-list', download the held version. | |
| 842 (hold (cadr (assq elt package-load-list))) | |
| 843 (v-string (or (and (stringp hold) hold) | |
| 844 (package-version-join (package-desc-vers desc)))) | |
| 845 (kind (package-desc-kind desc))) | |
| 846 (cond | |
| 847 ((eq kind 'tar) | |
| 848 (package-download-tar elt v-string)) | |
| 849 ((eq kind 'single) | |
| 850 (package-download-single elt v-string | |
| 851 (package-desc-doc desc) | |
| 852 (package-desc-reqs desc))) | |
| 853 (t | |
| 854 (error "Unknown package kind: %s" (symbol-name kind))))))) | |
| 855 | |
| 856 ;;;###autoload | |
| 857 (defun package-install (name) | |
| 858 "Install the package named NAME. | |
| 859 Interactively, prompt for the package name. | |
| 860 The package is found on one of the archives in `package-archives'." | |
| 861 (interactive | |
| 862 (list (intern (completing-read "Install package: " | |
| 863 (mapcar (lambda (elt) | |
| 864 (cons (symbol-name (car elt)) | |
| 865 nil)) | |
| 866 package-archive-contents) | |
| 867 nil t)))) | |
| 868 (let ((pkg-desc (assq name package-archive-contents))) | |
| 869 (unless pkg-desc | |
| 870 (error "Package `%s' is not available for installation" | |
| 871 (symbol-name name))) | |
| 872 (package-download-transaction | |
| 873 (package-compute-transaction (list name) | |
| 874 (package-desc-reqs (cdr pkg-desc))))) | |
| 875 ;; Try to activate it. | |
| 876 (package-initialize)) | |
| 877 | |
| 878 (defun package-strip-rcs-id (str) | |
| 879 "Strip RCS version ID from the version string STR. | |
| 880 If the result looks like a dotted numeric version, return it. | |
| 881 Otherwise return nil." | |
| 882 (when str | |
| 883 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) | |
| 884 (setq str (substring str (match-end 0)))) | |
| 885 (condition-case nil | |
| 886 (if (version-to-list str) | |
| 887 str) | |
| 888 (error nil)))) | |
| 889 | |
| 890 (defun package-buffer-info () | |
| 891 "Return a vector describing the package in the current buffer. | |
| 892 The vector has the form | |
| 893 | |
| 894 [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] | |
| 895 | |
| 896 FILENAME is the file name, a string, sans the \".el\" extension. | |
| 897 REQUIRES is a requires list, or nil. | |
| 898 DESCRIPTION is the package description, a string. | |
| 899 VERSION is the version, a string. | |
| 900 COMMENTARY is the commentary section, a string, or nil if none. | |
| 901 | |
| 902 If the buffer does not contain a conforming package, signal an | |
| 903 error. If there is a package, narrow the buffer to the file's | |
| 904 boundaries." | |
| 905 (goto-char (point-min)) | |
| 906 (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) | |
| 907 (error "Packages lacks a file header")) | |
| 908 (let ((file-name (match-string-no-properties 1)) | |
| 909 (desc (match-string-no-properties 2)) | |
| 910 (start (line-beginning-position))) | |
| 911 (unless (search-forward (concat ";;; " file-name ".el ends here")) | |
| 912 (error "Package lacks a terminating comment")) | |
| 913 ;; Try to include a trailing newline. | |
| 914 (forward-line) | |
| 915 (narrow-to-region start (point)) | |
| 916 (require 'lisp-mnt) | |
| 917 ;; Use some headers we've invented to drive the process. | |
| 918 (let* ((requires-str (lm-header "package-requires")) | |
| 919 (requires (if requires-str | |
| 920 (package-read-from-string requires-str))) | |
| 921 ;; Prefer Package-Version; if defined, the package author | |
| 922 ;; probably wants us to use it. Otherwise try Version. | |
| 923 (pkg-version | |
| 924 (or (package-strip-rcs-id (lm-header "package-version")) | |
| 925 (package-strip-rcs-id (lm-header "version")))) | |
| 926 (commentary (lm-commentary))) | |
| 927 (unless pkg-version | |
| 928 (error | |
| 929 "Package lacks a \"Version\" or \"Package-Version\" header")) | |
| 930 ;; Turn string version numbers into list form. | |
| 931 (setq requires | |
| 932 (mapcar | |
| 933 (lambda (elt) | |
| 934 (list (car elt) | |
| 935 (version-to-list (car (cdr elt))))) | |
| 936 requires)) | |
| 937 (vector file-name requires desc pkg-version commentary)))) | |
| 938 | |
| 939 (defun package-tar-file-info (file) | |
| 940 "Find package information for a tar file. | |
| 941 FILE is the name of the tar file to examine. | |
| 942 The return result is a vector like `package-buffer-info'." | |
| 943 (let ((default-directory (file-name-directory file)) | |
| 944 (file (file-name-nondirectory file))) | |
| 945 (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) | |
| 946 (error "Invalid package name `%s'" file)) | |
| 947 (let* ((pkg-name (match-string-no-properties 1 file)) | |
| 948 (pkg-version (match-string-no-properties 2 file)) | |
| 949 ;; Extract the package descriptor. | |
| 950 (pkg-def-contents (shell-command-to-string | |
| 951 ;; Requires GNU tar. | |
| 952 (concat "tar -xOf " file " " | |
| 953 | |
| 954 pkg-name "-" pkg-version "/" | |
| 955 pkg-name "-pkg.el"))) | |
| 956 (pkg-def-parsed (package-read-from-string pkg-def-contents))) | |
| 957 (unless (eq (car pkg-def-parsed) 'define-package) | |
| 958 (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) | |
| 959 (let ((name-str (nth 1 pkg-def-parsed)) | |
| 960 (version-string (nth 2 pkg-def-parsed)) | |
| 961 (docstring (nth 3 pkg-def-parsed)) | |
| 962 (requires (nth 4 pkg-def-parsed)) | |
| 963 (readme (shell-command-to-string | |
| 964 ;; Requires GNU tar. | |
| 965 (concat "tar -xOf " file " " | |
| 966 pkg-name "-" pkg-version "/README")))) | |
| 967 (unless (equal pkg-version version-string) | |
| 968 (error "Package has inconsistent versions")) | |
| 969 (unless (equal pkg-name name-str) | |
| 970 (error "Package has inconsistent names")) | |
| 971 ;; Kind of a hack. | |
| 972 (if (string-match ": Not found in archive" readme) | |
| 973 (setq readme nil)) | |
| 974 ;; Turn string version numbers into list form. | |
| 975 (if (eq (car requires) 'quote) | |
| 976 (setq requires (car (cdr requires)))) | |
| 977 (setq requires | |
| 978 (mapcar (lambda (elt) | |
| 979 (list (car elt) | |
| 980 (version-to-list (cadr elt)))) | |
| 981 requires)) | |
| 982 (vector pkg-name requires docstring version-string readme))))) | |
| 983 | |
| 984 ;;;###autoload | |
| 985 (defun package-install-from-buffer (pkg-info type) | |
| 986 "Install a package from the current buffer. | |
| 987 When called interactively, the current buffer is assumed to be a | |
| 988 single .el file that follows the packaging guidelines; see info | |
| 989 node `(elisp)Packaging'. | |
| 990 | |
| 991 When called from Lisp, PKG-INFO is a vector describing the | |
| 992 information, of the type returned by `package-buffer-info'; and | |
| 993 TYPE is the package type (either `single' or `tar')." | |
| 994 (interactive (list (package-buffer-info) 'single)) | |
| 995 (save-excursion | |
| 996 (save-restriction | |
| 997 (let* ((file-name (aref pkg-info 0)) | |
| 998 (requires (aref pkg-info 1)) | |
| 999 (desc (if (string= (aref pkg-info 2) "") | |
| 1000 "No description available." | |
| 1001 (aref pkg-info 2))) | |
| 1002 (pkg-version (aref pkg-info 3))) | |
| 1003 ;; Download and install the dependencies. | |
| 1004 (let ((transaction (package-compute-transaction nil requires))) | |
| 1005 (package-download-transaction transaction)) | |
| 1006 ;; Install the package itself. | |
| 1007 (cond | |
| 1008 ((eq type 'single) | |
| 1009 (package-unpack-single file-name pkg-version desc requires)) | |
| 1010 ((eq type 'tar) | |
| 1011 (package-unpack (intern file-name) pkg-version)) | |
| 1012 (t | |
| 1013 (error "Unknown type: %s" (symbol-name type)))) | |
| 1014 ;; Try to activate it. | |
| 1015 (package-initialize))))) | |
| 1016 | |
| 1017 ;;;###autoload | |
| 1018 (defun package-install-file (file) | |
| 1019 "Install a package from a file. | |
| 1020 The file can either be a tar file or an Emacs Lisp file." | |
| 1021 (interactive "fPackage file name: ") | |
| 1022 (with-temp-buffer | |
| 1023 (insert-file-contents-literally file) | |
| 1024 (cond | |
| 1025 ((string-match "\\.el$" file) | |
| 1026 (package-install-from-buffer (package-buffer-info) 'single)) | |
| 1027 ((string-match "\\.tar$" file) | |
| 1028 (package-install-from-buffer (package-tar-file-info file) 'tar)) | |
| 1029 (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) | |
| 1030 | |
| 1031 (defun package-delete (name version) | |
| 1032 (let ((dir (package--dir name version))) | |
| 1033 (if (string-equal (file-name-directory dir) | |
| 1034 (file-name-as-directory | |
| 1035 (expand-file-name package-user-dir))) | |
| 1036 (progn | |
| 1037 (delete-directory dir t t) | |
| 1038 (message "Package `%s-%s' deleted." name version)) | |
| 1039 ;; Don't delete "system" packages | |
| 1040 (error "Package `%s-%s' is a system package, not deleting" | |
| 1041 name version)))) | |
| 1042 | |
| 1043 (defun package-archive-base (name) | |
| 1044 "Return the archive containing the package NAME." | |
| 1045 (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) | |
| 1046 (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) | |
| 1047 | |
| 1048 (defun package--download-one-archive (archive file) | |
| 1049 "Retrieve an archive file FILE from ARCHIVE, and cache it. | |
| 1050 ARCHIVE should be a cons cell of the form (NAME . LOCATION), | |
| 1051 similar to an entry in `package-alist'. Save the cached copy to | |
| 1052 \"archives/NAME/archive-contents\" in `package-user-dir'." | |
| 1053 (let* ((dir (expand-file-name "archives" package-user-dir)) | |
| 1054 (dir (expand-file-name (car archive) dir))) | |
| 1055 (package--with-work-buffer (cdr archive) file | |
| 1056 ;; Read the retrieved buffer to make sure it is valid (e.g. it | |
| 1057 ;; may fetch a URL redirect page). | |
| 1058 (when (listp (read buffer)) | |
| 1059 (make-directory dir t) | |
| 1060 (setq buffer-file-name (expand-file-name file dir)) | |
| 1061 (let ((version-control 'never)) | |
| 1062 (save-buffer)))))) | |
| 1063 | |
| 1064 (defun package-refresh-contents () | |
| 1065 "Download the ELPA archive description if needed. | |
| 1066 This informs Emacs about the latest versions of all packages, and | |
| 1067 makes them available for download." | |
| 1068 (interactive) | |
| 1069 (unless (file-exists-p package-user-dir) | |
| 1070 (make-directory package-user-dir t)) | |
| 1071 (dolist (archive package-archives) | |
| 1072 (condition-case-no-debug nil | |
| 1073 (package--download-one-archive archive "archive-contents") | |
| 1074 (error (message "Failed to download `%s' archive." | |
| 1075 (car archive))))) | |
| 1076 (package-read-all-archive-contents)) | |
| 1077 | |
| 1078 (defvar package--initialized nil) | |
| 1079 | |
| 1080 ;;;###autoload | |
| 1081 (defun package-initialize (&optional no-activate) | |
| 1082 "Load Emacs Lisp packages, and activate them. | |
| 1083 The variable `package-load-list' controls which packages to load. | |
| 1084 If optional arg NO-ACTIVATE is non-nil, don't activate packages." | |
| 1085 (interactive) | |
| 1086 (setq package-alist nil | |
| 1087 package-obsolete-alist nil) | |
| 1088 (package-load-all-descriptors) | |
| 1089 (package-read-all-archive-contents) | |
| 1090 (unless no-activate | |
| 1091 (dolist (elt package-alist) | |
| 1092 (package-activate (car elt) (package-desc-vers (cdr elt))))) | |
| 1093 (setq package--initialized t)) | |
| 1094 | |
| 1095 | |
| 1096 ;;;; Package description buffer. | |
| 1097 | |
| 1098 ;;;###autoload | |
| 1099 (defun describe-package (package) | |
| 1100 "Display the full documentation of PACKAGE (a symbol)." | |
| 1101 (interactive | |
| 1102 (let* ((guess (function-called-at-point)) | |
| 1103 packages val) | |
| 1104 (require 'finder-inf nil t) | |
| 1105 ;; Load the package list if necessary (but don't activate them). | |
| 1106 (unless package--initialized | |
| 1107 (package-initialize t)) | |
| 1108 (setq packages (append (mapcar 'car package-alist) | |
| 1109 (mapcar 'car package-archive-contents) | |
| 1110 (mapcar 'car package--builtins))) | |
| 1111 (unless (memq guess packages) | |
| 1112 (setq guess nil)) | |
| 1113 (setq packages (mapcar 'symbol-name packages)) | |
| 1114 (setq val | |
| 1115 (completing-read (if guess | |
| 1116 (format "Describe package (default %s): " | |
| 1117 guess) | |
| 1118 "Describe package: ") | |
| 1119 packages nil t nil nil guess)) | |
| 1120 (list (if (equal val "") guess (intern val))))) | |
| 1121 (if (or (null package) (not (symbolp package))) | |
| 1122 (message "No package specified") | |
| 1123 (help-setup-xref (list #'describe-package package) | |
| 1124 (called-interactively-p 'interactive)) | |
| 1125 (with-help-window (help-buffer) | |
| 1126 (with-current-buffer standard-output | |
| 1127 (describe-package-1 package))))) | |
| 1128 | |
| 1129 (defun describe-package-1 (package) | |
| 1130 (require 'lisp-mnt) | |
| 1131 (let ((package-name (symbol-name package)) | |
| 1132 (built-in (assq package package--builtins)) | |
| 1133 desc pkg-dir reqs version installable) | |
| 1134 (prin1 package) | |
| 1135 (princ " is ") | |
| 1136 (cond | |
| 1137 ;; Loaded packages are in `package-alist'. | |
| 1138 ((setq desc (cdr (assq package package-alist))) | |
| 1139 (setq version (package-version-join (package-desc-vers desc))) | |
| 1140 (if (setq pkg-dir (package--dir package-name version)) | |
| 1141 (insert "an installed package.\n\n") | |
| 1142 ;; This normally does not happen. | |
| 1143 (insert "a deleted package.\n\n"))) | |
| 1144 ;; Available packages are in `package-archive-contents'. | |
| 1145 ((setq desc (cdr (assq package package-archive-contents))) | |
| 1146 (setq version (package-version-join (package-desc-vers desc)) | |
| 1147 installable t) | |
| 1148 (if built-in | |
| 1149 (insert "a built-in package.\n\n") | |
| 1150 (insert "an uninstalled package.\n\n"))) | |
| 1151 (built-in | |
| 1152 (setq desc (cdr built-in) | |
| 1153 version (package-version-join (package-desc-vers desc))) | |
| 1154 (insert "a built-in package.\n\n")) | |
| 1155 (t | |
| 1156 (insert "an orphan package.\n\n"))) | |
| 1157 | |
| 1158 (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") | |
| 1159 (cond (pkg-dir | |
| 1160 (insert (propertize "Installed" | |
| 1161 'font-lock-face 'font-lock-comment-face)) | |
| 1162 (insert " in `") | |
| 1163 ;; Todo: Add button for uninstalling. | |
| 1164 (help-insert-xref-button (file-name-as-directory pkg-dir) | |
| 1165 'help-package-def pkg-dir) | |
| 1166 (if built-in | |
| 1167 (insert "',\n shadowing a " | |
| 1168 (propertize "built-in package" | |
| 1169 'font-lock-face 'font-lock-builtin-face) | |
| 1170 ".") | |
| 1171 (insert "'."))) | |
| 1172 (installable | |
| 1173 (if built-in | |
| 1174 (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) | |
| 1175 " Alternate version available -- ") | |
| 1176 (insert "Available -- ")) | |
| 1177 (let ((button-text (if (display-graphic-p) "Install" "[Install]")) | |
| 1178 (button-face (if (display-graphic-p) | |
| 1179 '(:box (:line-width 2 :color "dark grey") | |
| 1180 :background "light grey" | |
| 1181 :foreground "black") | |
| 1182 'link))) | |
| 1183 (insert-text-button button-text 'face button-face 'follow-link t | |
| 1184 'package-symbol package | |
| 1185 'action 'package-install-button-action))) | |
| 1186 (built-in | |
| 1187 (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) | |
| 1188 (t (insert "Deleted."))) | |
| 1189 (insert "\n") | |
| 1190 (and version (> (length version) 0) | |
| 1191 (insert " " | |
| 1192 (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) | |
| 1193 | |
| 1194 (setq reqs (if desc (package-desc-reqs desc))) | |
| 1195 (when reqs | |
| 1196 (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") | |
| 1197 (let ((first t) | |
| 1198 name vers text) | |
| 1199 (dolist (req reqs) | |
| 1200 (setq name (car req) | |
| 1201 vers (cadr req) | |
| 1202 text (format "%s-%s" (symbol-name name) | |
| 1203 (package-version-join vers))) | |
| 1204 (cond (first (setq first nil)) | |
| 1205 ((>= (+ 2 (current-column) (length text)) | |
| 1206 (window-width)) | |
| 1207 (insert ",\n ")) | |
| 1208 (t (insert ", "))) | |
| 1209 (help-insert-xref-button text 'help-package name)) | |
| 1210 (insert "\n"))) | |
| 1211 (insert " " (propertize "Summary" 'font-lock-face 'bold) | |
| 1212 ": " (if desc (package-desc-doc desc)) "\n\n") | |
| 1213 | |
| 1214 (if built-in | |
| 1215 ;; For built-in packages, insert the commentary. | |
| 1216 (let ((fn (locate-file (concat package-name ".el") load-path | |
| 1217 load-file-rep-suffixes)) | |
| 1218 (opoint (point))) | |
| 1219 (insert (or (lm-commentary fn) "")) | |
| 1220 (save-excursion | |
| 1221 (goto-char opoint) | |
| 1222 (when (re-search-forward "^;;; Commentary:\n" nil t) | |
| 1223 (replace-match "")) | |
| 1224 (while (re-search-forward "^\\(;+ ?\\)" nil t) | |
| 1225 (replace-match "")))) | |
| 1226 (let ((readme (expand-file-name (concat package-name "-readme.txt") | |
| 1227 package-user-dir)) | |
| 1228 readme-string) | |
| 1229 ;; For elpa packages, try downloading the commentary. If that | |
| 1230 ;; fails, try an existing readme file in `package-user-dir'. | |
| 1231 (cond ((condition-case nil | |
| 1232 (package--with-work-buffer (package-archive-base package) | |
| 1233 (concat package-name "-readme.txt") | |
| 1234 (setq buffer-file-name | |
| 1235 (expand-file-name readme package-user-dir)) | |
| 1236 (let ((version-control 'never)) | |
| 1237 (save-buffer)) | |
| 1238 (setq readme-string (buffer-string)) | |
| 1239 t) | |
| 1240 (error nil)) | |
| 1241 (insert readme-string)) | |
| 1242 ((file-readable-p readme) | |
| 1243 (insert-file-contents readme) | |
| 1244 (goto-char (point-max)))))))) | |
| 1245 | |
| 1246 (defun package-install-button-action (button) | |
| 1247 (let ((package (button-get button 'package-symbol))) | |
| 1248 (when (y-or-n-p (format "Install package `%s'? " package)) | |
| 1249 (package-install package) | |
| 1250 (revert-buffer nil t) | |
| 1251 (goto-char (point-min))))) | |
| 1252 | |
| 1253 | |
| 1254 ;;;; Package menu mode. | |
| 1255 | |
| 1256 (defvar package-menu-mode-map | |
| 1257 (let ((map (copy-keymap special-mode-map)) | |
| 1258 (menu-map (make-sparse-keymap "Package"))) | |
| 1259 (set-keymap-parent map button-buffer-map) | |
| 1260 (define-key map "\C-m" 'package-menu-describe-package) | |
| 1261 (define-key map "n" 'next-line) | |
| 1262 (define-key map "p" 'previous-line) | |
| 1263 (define-key map "u" 'package-menu-mark-unmark) | |
| 1264 (define-key map "\177" 'package-menu-backup-unmark) | |
| 1265 (define-key map "d" 'package-menu-mark-delete) | |
| 1266 (define-key map "i" 'package-menu-mark-install) | |
| 1267 (define-key map "r" 'package-menu-refresh) | |
| 1268 (define-key map "~" 'package-menu-mark-obsolete-for-deletion) | |
| 1269 (define-key map "x" 'package-menu-execute) | |
| 1270 (define-key map "h" 'package-menu-quick-help) | |
| 1271 (define-key map "?" 'package-menu-describe-package) | |
| 1272 (define-key map [follow-link] 'mouse-face) | |
| 1273 (define-key map [mouse-2] 'mouse-select-window) | |
| 1274 (define-key map [menu-bar package-menu] (cons "Package" menu-map)) | |
| 1275 (define-key menu-map [mq] | |
| 1276 '(menu-item "Quit" quit-window | |
| 1277 :help "Quit package selection")) | |
| 1278 (define-key menu-map [s1] '("--")) | |
| 1279 (define-key menu-map [mn] | |
| 1280 '(menu-item "Next" next-line | |
| 1281 :help "Next Line")) | |
| 1282 (define-key menu-map [mp] | |
| 1283 '(menu-item "Previous" previous-line | |
| 1284 :help "Previous Line")) | |
| 1285 (define-key menu-map [s2] '("--")) | |
| 1286 (define-key menu-map [mu] | |
| 1287 '(menu-item "Unmark" package-menu-mark-unmark | |
| 1288 :help "Clear any marks on a package and move to the next line")) | |
| 1289 (define-key menu-map [munm] | |
| 1290 '(menu-item "Unmark backwards" package-menu-backup-unmark | |
| 1291 :help "Back up one line and clear any marks on that package")) | |
| 1292 (define-key menu-map [md] | |
| 1293 '(menu-item "Mark for deletion" package-menu-mark-delete | |
| 1294 :help "Mark a package for deletion and move to the next line")) | |
| 1295 (define-key menu-map [mi] | |
| 1296 '(menu-item "Mark for install" package-menu-mark-install | |
| 1297 :help "Mark a package for installation and move to the next line")) | |
| 1298 (define-key menu-map [s3] '("--")) | |
| 1299 (define-key menu-map [mg] | |
| 1300 '(menu-item "Update package list" revert-buffer | |
| 1301 :help "Update the list of packages")) | |
| 1302 (define-key menu-map [mr] | |
| 1303 '(menu-item "Refresh package list" package-menu-refresh | |
| 1304 :help "Download the ELPA archive")) | |
| 1305 (define-key menu-map [s4] '("--")) | |
| 1306 (define-key menu-map [mt] | |
| 1307 '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion | |
| 1308 :help "Mark all obsolete packages for deletion")) | |
| 1309 (define-key menu-map [mx] | |
| 1310 '(menu-item "Execute actions" package-menu-execute | |
| 1311 :help "Perform all the marked actions")) | |
| 1312 (define-key menu-map [s5] '("--")) | |
| 1313 (define-key menu-map [mh] | |
| 1314 '(menu-item "Help" package-menu-quick-help | |
| 1315 :help "Show short key binding help for package-menu-mode")) | |
| 1316 (define-key menu-map [mc] | |
| 1317 '(menu-item "View Commentary" package-menu-view-commentary | |
| 1318 :help "Display information about this package")) | |
| 1319 map) | |
| 1320 "Local keymap for `package-menu-mode' buffers.") | |
| 1321 | |
| 1322 (defvar package-menu-sort-button-map | |
| 1323 (let ((map (make-sparse-keymap))) | |
| 1324 (define-key map [header-line mouse-1] 'package-menu-sort-by-column) | |
| 1325 (define-key map [header-line mouse-2] 'package-menu-sort-by-column) | |
| 1326 (define-key map [follow-link] 'mouse-face) | |
| 1327 map) | |
| 1328 "Local keymap for package menu sort buttons.") | |
| 1329 | |
| 1330 (put 'package-menu-mode 'mode-class 'special) | |
| 1331 | |
| 1332 (define-derived-mode package-menu-mode special-mode "Package Menu" | |
| 1333 "Major mode for browsing a list of packages. | |
| 1334 Letters do not insert themselves; instead, they are commands. | |
| 1335 \\<package-menu-mode-map> | |
| 1336 \\{package-menu-mode-map}" | |
| 1337 (setq truncate-lines t) | |
| 1338 (setq buffer-read-only t) | |
| 1339 (set (make-local-variable 'revert-buffer-function) 'package-menu-revert) | |
| 1340 (setq header-line-format | |
| 1341 (mapconcat | |
| 1342 (lambda (pair) | |
| 1343 (let ((column (car pair)) | |
| 1344 (name (cdr pair))) | |
| 1345 (concat | |
| 1346 ;; Insert a space that aligns the button properly. | |
| 1347 (propertize " " 'display (list 'space :align-to column) | |
| 1348 'face 'fixed-pitch) | |
| 1349 ;; Set up the column button. | |
| 1350 (propertize name | |
| 1351 'column-name name | |
| 1352 'help-echo "mouse-1: sort by column" | |
| 1353 'mouse-face 'highlight | |
| 1354 'keymap package-menu-sort-button-map)))) | |
| 1355 ;; We take a trick from buff-menu and have a dummy leading | |
| 1356 ;; space to align the header line with the beginning of the | |
| 1357 ;; text. This doesn't really work properly on Emacs 21, but | |
| 1358 ;; it is close enough. | |
| 1359 '((0 . "") | |
| 1360 (2 . "Package") | |
| 1361 (20 . "Version") | |
| 1362 (32 . "Status") | |
| 1363 (43 . "Description")) | |
| 1364 ""))) | |
| 1365 | |
| 1366 (defun package-menu-refresh () | |
| 1367 "Download the Emacs Lisp package archive. | |
| 1368 This fetches the contents of each archive specified in | |
| 1369 `package-archives', and then refreshes the package menu." | |
| 1370 (interactive) | |
| 1371 (unless (eq major-mode 'package-menu-mode) | |
| 1372 (error "The current buffer is not a Package Menu")) | |
| 1373 (package-refresh-contents) | |
| 1374 (package--generate-package-list)) | |
| 1375 | |
| 1376 (defun package-menu-revert (&optional arg noconfirm) | |
| 1377 "Update the list of packages. | |
| 1378 This function is the `revert-buffer-function' for Package Menu | |
| 1379 buffers. The arguments are ignored." | |
| 1380 (interactive) | |
| 1381 (unless (eq major-mode 'package-menu-mode) | |
| 1382 (error "The current buffer is not a Package Menu")) | |
| 1383 (package--generate-package-list)) | |
| 1384 | |
| 1385 (defun package-menu-describe-package () | |
| 1386 "Describe the package in the current line." | |
| 1387 (interactive) | |
| 1388 (let ((name (package-menu-get-package))) | |
| 1389 (if name | |
| 1390 (describe-package (intern name)) | |
| 1391 (message "No package on this line")))) | |
| 1392 | |
| 1393 (defun package-menu-mark-internal (what) | |
| 1394 (unless (eobp) | |
| 1395 (let ((buffer-read-only nil)) | |
| 1396 (beginning-of-line) | |
| 1397 (delete-char 1) | |
| 1398 (insert what) | |
| 1399 (forward-line)))) | |
| 1400 | |
| 1401 ;; fixme numeric argument | |
| 1402 (defun package-menu-mark-delete (num) | |
| 1403 "Mark a package for deletion and move to the next line." | |
| 1404 (interactive "p") | |
| 1405 (if (string-equal (package-menu-get-status) "installed") | |
| 1406 (package-menu-mark-internal "D") | |
| 1407 (forward-line))) | |
| 1408 | |
| 1409 (defun package-menu-mark-install (num) | |
| 1410 "Mark a package for installation and move to the next line." | |
| 1411 (interactive "p") | |
| 1412 (if (string-equal (package-menu-get-status) "available") | |
| 1413 (package-menu-mark-internal "I") | |
| 1414 (forward-line))) | |
| 1415 | |
| 1416 (defun package-menu-mark-unmark (num) | |
| 1417 "Clear any marks on a package and move to the next line." | |
| 1418 (interactive "p") | |
| 1419 (package-menu-mark-internal " ")) | |
| 1420 | |
| 1421 (defun package-menu-backup-unmark () | |
| 1422 "Back up one line and clear any marks on that package." | |
| 1423 (interactive) | |
| 1424 (forward-line -1) | |
| 1425 (package-menu-mark-internal " ") | |
| 1426 (forward-line -1)) | |
| 1427 | |
| 1428 (defun package-menu-mark-obsolete-for-deletion () | |
| 1429 "Mark all obsolete packages for deletion." | |
| 1430 (interactive) | |
| 1431 (save-excursion | |
| 1432 (goto-char (point-min)) | |
| 1433 (forward-line 2) | |
| 1434 (while (not (eobp)) | |
| 1435 (if (looking-at ".*\\s obsolete\\s ") | |
| 1436 (package-menu-mark-internal "D") | |
| 1437 (forward-line 1))))) | |
| 1438 | |
| 1439 (defun package-menu-quick-help () | |
| 1440 "Show short key binding help for package-menu-mode." | |
| 1441 (interactive) | |
| 1442 (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) | |
| 1443 | |
| 1444 (define-obsolete-function-alias | |
| 1445 'package-menu-view-commentary 'package-menu-describe-package "24.1") | |
| 1446 | |
| 1447 ;; Return the name of the package on the current line. | |
| 1448 (defun package-menu-get-package () | |
| 1449 (save-excursion | |
| 1450 (beginning-of-line) | |
| 1451 (if (looking-at ". \\([^ \t]*\\)") | |
| 1452 (match-string-no-properties 1)))) | |
| 1453 | |
| 1454 ;; Return the version of the package on the current line. | |
| 1455 (defun package-menu-get-version () | |
| 1456 (save-excursion | |
| 1457 (beginning-of-line) | |
| 1458 (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)") | |
| 1459 (match-string 1)))) | |
| 1460 | |
| 1461 (defun package-menu-get-status () | |
| 1462 (save-excursion | |
| 1463 (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)") | |
| 1464 (match-string 1) | |
| 1465 ""))) | |
| 1466 | |
| 1467 (defun package-menu-execute () | |
| 1468 "Perform marked Package Menu actions. | |
| 1469 Packages marked for installation are downloaded and installed; | |
| 1470 packages marked for deletion are removed." | |
| 1471 (interactive) | |
| 1472 (let (install-list delete-list cmd) | |
| 1473 (save-excursion | |
| 1474 (goto-char (point-min)) | |
| 1475 (while (not (eobp)) | |
| 1476 (setq cmd (char-after)) | |
| 1477 (cond | |
| 1478 ((eq cmd ?\s) t) | |
| 1479 ((eq cmd ?D) | |
| 1480 (push (cons (package-menu-get-package) | |
| 1481 (package-menu-get-version)) | |
| 1482 delete-list)) | |
| 1483 ((eq cmd ?I) | |
| 1484 (push (package-menu-get-package) install-list))) | |
| 1485 (forward-line))) | |
| 1486 ;; Delete packages, prompting if necessary. | |
| 1487 (when delete-list | |
| 1488 (if (yes-or-no-p | |
| 1489 (if (= (length delete-list) 1) | |
| 1490 (format "Delete package `%s-%s'? " | |
| 1491 (caar delete-list) | |
| 1492 (cdr (car delete-list))) | |
| 1493 (format "Delete these %d packages (%s)? " | |
| 1494 (length delete-list) | |
| 1495 (mapconcat (lambda (elt) | |
| 1496 (concat (car elt) "-" (cdr elt))) | |
| 1497 delete-list | |
| 1498 ", ")))) | |
| 1499 (dolist (elt delete-list) | |
| 1500 (condition-case-no-debug err | |
| 1501 (package-delete (car elt) (cdr elt)) | |
| 1502 (error (message (cadr err))))) | |
| 1503 (error "Aborted"))) | |
| 1504 (when install-list | |
| 1505 (if (yes-or-no-p | |
| 1506 (if (= (length install-list) 1) | |
| 1507 (format "Install package `%s'? " (car install-list)) | |
| 1508 (format "Install these %d packages (%s)? " | |
| 1509 (length install-list) | |
| 1510 (mapconcat 'identity install-list ", ")))) | |
| 1511 (dolist (elt install-list) | |
| 1512 (package-install (intern elt))))) | |
| 1513 ;; If we deleted anything, regenerate `package-alist'. This is done | |
| 1514 ;; automatically if we installed a package. | |
| 1515 (and delete-list (null install-list) | |
| 1516 (package-initialize)) | |
| 1517 (if (or delete-list install-list) | |
| 1518 (package-menu-revert) | |
| 1519 (message "No operations specified.")))) | |
| 1520 | |
| 1521 (defun package-print-package (package version key desc) | |
| 1522 (let ((face | |
| 1523 (cond ((string= key "built-in") 'font-lock-builtin-face) | |
| 1524 ((string= key "available") 'default) | |
| 1525 ((string= key "held") 'font-lock-constant-face) | |
| 1526 ((string= key "disabled") 'font-lock-warning-face) | |
| 1527 ((string= key "installed") 'font-lock-comment-face) | |
| 1528 (t ; obsolete, but also the default. | |
| 1529 'font-lock-warning-face)))) | |
| 1530 (insert (propertize " " 'font-lock-face face)) | |
| 1531 (insert-text-button (symbol-name package) | |
| 1532 'face 'link | |
| 1533 'follow-link t | |
| 1534 'package-symbol package | |
| 1535 'action (lambda (button) | |
| 1536 (describe-package | |
| 1537 (button-get button 'package-symbol)))) | |
| 1538 (indent-to 20 1) | |
| 1539 (insert (propertize (package-version-join version) 'font-lock-face face)) | |
| 1540 (indent-to 32 1) | |
| 1541 (insert (propertize key 'font-lock-face face)) | |
| 1542 ;; FIXME: this 'when' is bogus... | |
| 1543 (when desc | |
| 1544 (indent-to 43 1) | |
| 1545 (let ((opoint (point))) | |
| 1546 (insert (propertize desc 'font-lock-face face)) | |
| 1547 (upcase-region opoint (min (point) (1+ opoint))))) | |
| 1548 (insert "\n"))) | |
| 1549 | |
| 1550 (defun package-list-maybe-add (package version status description result) | |
| 1551 (unless (assoc (cons package version) result) | |
| 1552 (push (list (cons package version) status description) result)) | |
| 1553 result) | |
| 1554 | |
| 1555 (defvar package-menu-package-list nil | |
| 1556 "List of packages to display in the Package Menu buffer. | |
| 1557 A value of nil means to display all packages.") | |
| 1558 | |
| 1559 (defvar package-menu-sort-key nil | |
| 1560 "Sort key for the current Package Menu buffer.") | |
| 1561 | |
| 1562 (defun package--generate-package-list () | |
| 1563 "Populate the current Package Menu buffer." | |
| 1564 (let ((inhibit-read-only t) | |
| 1565 info-list name desc hold builtin) | |
| 1566 (erase-buffer) | |
| 1567 ;; List installed packages | |
| 1568 (dolist (elt package-alist) | |
| 1569 (setq name (car elt)) | |
| 1570 (when (or (null package-menu-package-list) | |
| 1571 (memq name package-menu-package-list)) | |
| 1572 (setq desc (cdr elt) | |
| 1573 hold (cadr (assq name package-load-list))) | |
| 1574 (setq info-list | |
| 1575 (package-list-maybe-add | |
| 1576 name (package-desc-vers desc) | |
| 1577 ;; FIXME: it turns out to be tricky to see if this | |
| 1578 ;; package is presently activated. | |
| 1579 (if (stringp hold) "held" "installed") | |
| 1580 (package-desc-doc desc) | |
| 1581 info-list)))) | |
| 1582 | |
| 1583 ;; List built-in packages | |
| 1584 (dolist (elt package--builtins) | |
| 1585 (setq name (car elt)) | |
| 1586 (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. | |
| 1587 (or (null package-menu-package-list) | |
| 1588 (memq name package-menu-package-list))) | |
| 1589 (setq desc (cdr elt)) | |
| 1590 (setq info-list | |
| 1591 (package-list-maybe-add | |
| 1592 name (package-desc-vers desc) | |
| 1593 "built-in" | |
| 1594 (package-desc-doc desc) | |
| 1595 info-list)))) | |
| 1596 | |
| 1597 ;; List available and disabled packages | |
| 1598 (dolist (elt package-archive-contents) | |
| 1599 (setq name (car elt) | |
| 1600 desc (cdr elt) | |
| 1601 hold (assq name package-load-list)) | |
| 1602 (when (or (null package-menu-package-list) | |
| 1603 (memq name package-menu-package-list)) | |
| 1604 (setq info-list | |
| 1605 (package-list-maybe-add name | |
| 1606 (package-desc-vers desc) | |
| 1607 (if (and hold (null (cadr hold))) | |
| 1608 "disabled" | |
| 1609 "available") | |
| 1610 (package-desc-doc (cdr elt)) | |
| 1611 info-list)))) | |
| 1612 ;; List obsolete packages | |
| 1613 (mapc (lambda (elt) | |
| 1614 (mapc (lambda (inner-elt) | |
| 1615 (setq info-list | |
| 1616 (package-list-maybe-add (car elt) | |
| 1617 (package-desc-vers | |
| 1618 (cdr inner-elt)) | |
| 1619 "obsolete" | |
| 1620 (package-desc-doc | |
| 1621 (cdr inner-elt)) | |
| 1622 info-list))) | |
| 1623 (cdr elt))) | |
| 1624 package-obsolete-alist) | |
| 1625 | |
| 1626 (setq info-list | |
| 1627 (sort info-list | |
| 1628 (cond ((string= package-menu-sort-key "Package") | |
| 1629 'package-menu--name-predicate) | |
| 1630 ((string= package-menu-sort-key "Version") | |
| 1631 'package-menu--version-predicate) | |
| 1632 ((string= package-menu-sort-key "Description") | |
| 1633 'package-menu--description-predicate) | |
| 1634 (t ; By default, sort by package status | |
| 1635 'package-menu--status-predicate)))) | |
| 1636 | |
| 1637 (dolist (elt info-list) | |
| 1638 (package-print-package (car (car elt)) | |
| 1639 (cdr (car elt)) | |
| 1640 (car (cdr elt)) | |
| 1641 (car (cdr (cdr elt))))) | |
| 1642 (goto-char (point-min)) | |
| 1643 (set-buffer-modified-p nil) | |
| 1644 (current-buffer))) | |
| 1645 | |
| 1646 (defun package-menu--version-predicate (left right) | |
| 1647 (let ((vleft (or (cdr (car left)) '(0))) | |
| 1648 (vright (or (cdr (car right)) '(0)))) | |
| 1649 (if (version-list-= vleft vright) | |
| 1650 (package-menu--name-predicate left right) | |
| 1651 (version-list-< vleft vright)))) | |
| 1652 | |
| 1653 (defun package-menu--status-predicate (left right) | |
| 1654 (let ((sleft (cadr left)) | |
| 1655 (sright (cadr right))) | |
| 1656 (cond ((string= sleft sright) | |
| 1657 (package-menu--name-predicate left right)) | |
| 1658 ((string= sleft "available") t) | |
| 1659 ((string= sright "available") nil) | |
| 1660 ((string= sleft "installed") t) | |
| 1661 ((string= sright "installed") nil) | |
| 1662 ((string= sleft "held") t) | |
| 1663 ((string= sright "held") nil) | |
| 1664 ((string= sleft "built-in") t) | |
| 1665 ((string= sright "built-in") nil) | |
| 1666 ((string= sleft "obsolete") t) | |
| 1667 ((string= sright "obsolete") nil) | |
| 1668 (t (string< sleft sright))))) | |
| 1669 | |
| 1670 (defun package-menu--description-predicate (left right) | |
| 1671 (let ((sleft (car (cddr left))) | |
| 1672 (sright (car (cddr right)))) | |
| 1673 (if (string= sleft sright) | |
| 1674 (package-menu--name-predicate left right) | |
| 1675 (string< sleft sright)))) | |
| 1676 | |
| 1677 (defun package-menu--name-predicate (left right) | |
| 1678 (string< (symbol-name (caar left)) | |
| 1679 (symbol-name (caar right)))) | |
| 1680 | |
| 1681 (defun package-menu-sort-by-column (&optional e) | |
| 1682 "Sort the package menu by the column of the mouse click E." | |
| 1683 (interactive "e") | |
| 1684 (let* ((pos (event-start e)) | |
| 1685 (obj (posn-object pos)) | |
| 1686 (col (if obj | |
| 1687 (get-text-property (cdr obj) 'column-name (car obj)) | |
| 1688 (get-text-property (posn-point pos) 'column-name))) | |
| 1689 (buf (window-buffer (posn-window (event-start e))))) | |
| 1690 (with-current-buffer buf | |
| 1691 (when (eq major-mode 'package-menu-mode) | |
| 1692 (setq package-menu-sort-key col) | |
| 1693 (package--generate-package-list))))) | |
| 1694 | |
| 1695 (defun package--list-packages (&optional packages) | |
| 1696 "Generate and pop to the *Packages* buffer. | |
| 1697 Optional PACKAGES is a list of names of packages (symbols) to | |
| 1698 list; the default is to display everything in `package-alist'." | |
| 1699 (require 'finder-inf nil t) | |
| 1700 (let ((buf (get-buffer-create "*Packages*"))) | |
| 1701 (with-current-buffer buf | |
| 1702 (package-menu-mode) | |
| 1703 (set (make-local-variable 'package-menu-package-list) packages) | |
| 1704 (set (make-local-variable 'package-menu-sort-key) nil) | |
| 1705 (package--generate-package-list)) | |
| 1706 ;; The package menu buffer has keybindings. If the user types | |
| 1707 ;; `M-x list-packages', that suggests it should become current. | |
| 1708 (switch-to-buffer buf))) | |
| 1709 | |
| 1710 ;;;###autoload | |
| 1711 (defun list-packages () | |
| 1712 "Display a list of packages. | |
| 1713 Fetches the updated list of packages before displaying. | |
| 1714 The list is displayed in a buffer named `*Packages*'." | |
| 1715 (interactive) | |
| 1716 ;; Initialize the package system if necessary. | |
| 1717 (unless package--initialized | |
| 1718 (package-initialize t)) | |
| 1719 (package-refresh-contents) | |
| 1720 (package--list-packages)) | |
| 1721 | |
| 1722 ;;;###autoload | |
| 1723 (defalias 'package-list-packages 'list-packages) | |
| 1724 | |
| 1725 (defun package-list-packages-no-fetch () | |
| 1726 "Display a list of packages. | |
| 1727 Does not fetch the updated list of packages before displaying. | |
| 1728 The list is displayed in a buffer named `*Packages*'." | |
| 1729 (interactive) | |
| 1730 (package--list-packages)) | |
| 1731 | |
| 1732 (provide 'package) | |
| 1733 | |
| 1734 ;;; package.el ends here |