Mercurial > dotfiles
comparison .elisp/package.el @ 211:8980dc2deda0
emacs: use package.el to bootstrap instead of checking in all needed libs
| author | Augie Fackler <durin42@gmail.com> |
|---|---|
| date | Sat, 13 Feb 2010 20:00:15 -0600 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 210:0590f34b92a0 | 211:8980dc2deda0 |
|---|---|
| 1 ;;; package.el --- Simple package system for Emacs | |
| 2 | |
| 3 ;; Copyright (C) 2007, 2008, 2009 Tom Tromey <tromey@redhat.com> | |
| 4 | |
| 5 ;; Author: Tom Tromey <tromey@redhat.com> | |
| 6 ;; Created: 10 Mar 2007 | |
| 7 ;; Version: 0.9.4 | |
| 8 ;; Keywords: tools | |
| 9 | |
| 10 ;; This file is not (yet) part of GNU Emacs. | |
| 11 ;; However, it is distributed under the same license. | |
| 12 | |
| 13 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 14 ;; it under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 3, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 21 ;; GNU General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
| 26 ;; Boston, MA 02110-1301, USA. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; To use this, put package.el somewhere on your load-path. Then add | |
| 31 ;; this to your .emacs: | |
| 32 ;; | |
| 33 ;; (load "package") | |
| 34 ;; (package-initialize) | |
| 35 ;; | |
| 36 ;; This will automatically make available the packages you have | |
| 37 ;; installed using package.el. If your .emacs will refer to these | |
| 38 ;; packages, you may want to initialize the package manager near the | |
| 39 ;; top. | |
| 40 ;; | |
| 41 ;; Note that if you want to be able to automatically download and | |
| 42 ;; install packages from ELPA (the Emacs Lisp Package Archive), then | |
| 43 ;; you will need the 'url' package. This comes with Emacs 22; Emacs | |
| 44 ;; 21 users will have to find it elsewhere. | |
| 45 ;; | |
| 46 ;; If you installed package.el via the auto-installer: | |
| 47 ;; | |
| 48 ;; http://tromey.com/elpa/ | |
| 49 ;; | |
| 50 ;; then you do not need to edit your .emacs, as the installer will | |
| 51 ;; have done this for you. The installer will also install the url | |
| 52 ;; package if you need it. | |
| 53 | |
| 54 ;; Other external functions you may want to use: | |
| 55 ;; | |
| 56 ;; M-x package-list-packages | |
| 57 ;; Enters a mode similar to buffer-menu which lets you manage | |
| 58 ;; packages. You can choose packages for install (mark with "i", | |
| 59 ;; then "x" to execute) or deletion (not implemented yet), and you | |
| 60 ;; can see what packages are available. This will automatically | |
| 61 ;; fetch the latest list of packages from ELPA. | |
| 62 ;; | |
| 63 ;; M-x package-list-packages-no-fetch | |
| 64 ;; Like package-list-packages, but does not automatically fetch the | |
| 65 ;; new list of packages. | |
| 66 ;; | |
| 67 ;; M-x package-install-from-buffer | |
| 68 ;; Install a package consisting of a single .el file that appears | |
| 69 ;; in the current buffer. This only works for packages which | |
| 70 ;; define a Version header properly; package.el also supports the | |
| 71 ;; extension headers Package-Version (in case Version is an RCS id | |
| 72 ;; or similar), and Package-Requires (if the package requires other | |
| 73 ;; packages). | |
| 74 ;; | |
| 75 ;; M-x package-install-file | |
| 76 ;; Install a package from the indicated file. The package can be | |
| 77 ;; either a tar file or a .el file. A tar file must contain an | |
| 78 ;; appropriately-named "-pkg.el" file; a .el file must be properly | |
| 79 ;; formatted as with package-install-from-buffer. | |
| 80 | |
| 81 ;; The idea behind package.el is to be able to download packages and | |
| 82 ;; install them. Packages are versioned and have versioned | |
| 83 ;; dependencies. Furthermore, this supports built-in packages which | |
| 84 ;; may or may not be newer than user-specified packages. This makes | |
| 85 ;; it possible to upgrade Emacs and automatically disable packages | |
| 86 ;; which have moved from external to core. (Note though that we don't | |
| 87 ;; currently register any of these, so this feature does not actually | |
| 88 ;; work.) | |
| 89 | |
| 90 ;; This code supports a single package repository, ELPA. All packages | |
| 91 ;; must be registered there. | |
| 92 | |
| 93 ;; A package is described by its name and version. The distribution | |
| 94 ;; format is either a tar file or a single .el file. | |
| 95 | |
| 96 ;; A tar file should be named "NAME-VERSION.tar". The tar file must | |
| 97 ;; unpack into a directory named after the package and version: | |
| 98 ;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el" | |
| 99 ;; which consists of a call to define-package. It may also contain a | |
| 100 ;; "dir" file and the info files it references. | |
| 101 | |
| 102 ;; A .el file will be named "NAME-VERSION.el" in ELPA, but will be | |
| 103 ;; installed as simply "NAME.el" in a directory named "NAME-VERSION". | |
| 104 | |
| 105 ;; The downloader will download all dependent packages. It will also | |
| 106 ;; byte-compile the package's Lisp at install time. | |
| 107 | |
| 108 ;; At activation time we will set up the load-path and the info path, | |
| 109 ;; and we will load the package's autoloads. If a package's | |
| 110 ;; dependencies are not available, we will not activate that package. | |
| 111 | |
| 112 ;; Conceptually a package has multiple state transitions: | |
| 113 ;; | |
| 114 ;; * Download. Fetching the package from ELPA. | |
| 115 ;; * Install. Untar the package, or write the .el file, into | |
| 116 ;; ~/.emacs.d/elpa/ directory. | |
| 117 ;; * Byte compile. Currently this phase is done during install, | |
| 118 ;; but we may change this. | |
| 119 ;; * Activate. Evaluate the autoloads for the package to make it | |
| 120 ;; available to the user. | |
| 121 ;; * Load. Actually load the package and run some code from it. | |
| 122 | |
| 123 ;;; Thanks: | |
| 124 ;;; (sorted by sort-lines): | |
| 125 | |
| 126 ;; Jim Blandy <jimb@red-bean.com> | |
| 127 ;; Karl Fogel <kfogel@red-bean.com> | |
| 128 ;; Kevin Ryde <user42@zip.com.au> | |
| 129 ;; Lawrence Mitchell | |
| 130 ;; Michael Olson <mwolson@member.fsf.org> | |
| 131 ;; Sebastian Tennant <sebyte@smolny.plus.com> | |
| 132 ;; Stefan Monnier <monnier@iro.umontreal.ca> | |
| 133 ;; Vinicius Jose Latorre <viniciusjl@ig.com.br> | |
| 134 ;; Phil Hagelberg <phil@hagelb.org> | |
| 135 ;; Samuel Bronson <naesten@gmail.com> | |
| 136 | |
| 137 ;;; History: | |
| 138 ;; | |
| 139 ;; Originally written by Tom Tromey, multiple archive support added by Phil | |
| 140 ;; Hagelberg. | |
| 141 | |
| 142 ;;; Code: | |
| 143 | |
| 144 (defcustom package-archives '(("elpa" . "http://tromey.com/elpa/")) | |
| 145 "An alist of archives (names and URLs) from which to fetch. | |
| 146 The default points to ELPA, the Emacs Lisp Package Archive. | |
| 147 Note that some code in package.el assumes that this is an http: URL." | |
| 148 :type '(alist :key-type (string :tag "Archive name") | |
| 149 :value-type (string :tag "Archive URL")) | |
| 150 :group 'package | |
| 151 :package-version '("package.el" . "0.9.3")) | |
| 152 | |
| 153 (defconst package-archive-version 1 | |
| 154 "Version number of the package archive understood by this file. | |
| 155 Lower version numbers than this will probably be understood as well.") | |
| 156 | |
| 157 (defconst package-el-version "0.9.4" | |
| 158 "Version of package.el.") | |
| 159 | |
| 160 ;; We don't prime the cache since it tends to get out of date. | |
| 161 (defvar package-archive-contents | |
| 162 nil | |
| 163 "A representation of the contents of the ELPA archive. | |
| 164 This is an alist mapping package names (symbols) to package | |
| 165 descriptor vectors. These are like the vectors for `package-alist' | |
| 166 but have extra entries: one which is 'tar for tar packages and | |
| 167 'single for single-file packages, and one which is the name of | |
| 168 the archive from which it came.") | |
| 169 | |
| 170 (defvar package-user-dir | |
| 171 (expand-file-name (convert-standard-filename "~/.emacs.d/elpa")) | |
| 172 "Name of the directory where the user's packages are stored.") | |
| 173 | |
| 174 (defvar package-directory-list | |
| 175 (list (file-name-as-directory package-user-dir) | |
| 176 "/usr/share/emacs/site-lisp/elpa/") | |
| 177 "List of directories to search for packages.") | |
| 178 | |
| 179 (defun package-version-split (string) | |
| 180 "Split a package STRING into a version list." | |
| 181 (mapcar 'string-to-int (split-string string "[.]"))) | |
| 182 | |
| 183 (defconst package--builtins-base | |
| 184 ;; We use package-version split here to make sure to pick up the | |
| 185 ;; minor version. | |
| 186 `((emacs . [,(package-version-split emacs-version) nil | |
| 187 "GNU Emacs"]) | |
| 188 (package . [,(package-version-split package-el-version) | |
| 189 nil "Simple package system for GNU Emacs"])) | |
| 190 "Packages which are always built-in.") | |
| 191 | |
| 192 (defvar package--builtins | |
| 193 (delq nil | |
| 194 (append | |
| 195 package--builtins-base | |
| 196 (if (>= emacs-major-version 22) | |
| 197 ;; FIXME: emacs 22 includes tramp, rcirc, maybe | |
| 198 ;; other things... | |
| 199 '((erc . [(5 2) nil "An Emacs Internet Relay Chat client"]) | |
| 200 ;; The external URL is version 1.15, so make sure the | |
| 201 ;; built-in one looks newer. | |
| 202 (url . [(1 16) nil "URL handling libary"]))) | |
| 203 (if (>= emacs-major-version 23) | |
| 204 '(;; Strangely, nxml-version is missing in Emacs 23. | |
| 205 ;; We pick the merge date as the version. | |
| 206 (nxml . [(20071123) nil "Major mode for editing XML documents."]) | |
| 207 (bubbles . [(0 5) nil "Puzzle game for Emacs."]))))) | |
| 208 "Alist of all built-in packages. | |
| 209 Maps the package name to a vector [VERSION REQS DOCSTRING].") | |
| 210 | |
| 211 (defvar package-alist package--builtins | |
| 212 "Alist of all packages available for activation. | |
| 213 Maps the package name to a vector [VERSION REQS DOCSTRING].") | |
| 214 | |
| 215 (defvar package-activated-list | |
| 216 (mapcar #'car package-alist) | |
| 217 "List of the names of all activated packages.") | |
| 218 | |
| 219 (defvar package-obsolete-alist nil | |
| 220 "Representation of obsolete packages. | |
| 221 Like `package-alist', but maps package name to a second alist. | |
| 222 The inner alist is keyed by version.") | |
| 223 | |
| 224 (defun package-version-join (l) | |
| 225 "Turn a list L of version numbers into a version string." | |
| 226 (mapconcat 'int-to-string l ".")) | |
| 227 | |
| 228 (defun package--version-first-nonzero (l) | |
| 229 "Find the first non-zero number in the list L. | |
| 230 | |
| 231 Returns the value of the first non-zero integer in L, or 0 if | |
| 232 none is found." | |
| 233 (while (and l (= (car l) 0)) | |
| 234 (setq l (cdr l))) | |
| 235 (if l (car l) 0)) | |
| 236 | |
| 237 (defun package-version-compare (v1 v2 fun) | |
| 238 "Compare two version V1 and V2 lists according to FUN. | |
| 239 | |
| 240 FUN can be <, <=, =, >, >=, or /=." | |
| 241 (while (and v1 v2 (= (car v1) (car v2))) | |
| 242 (setq v1 (cdr v1) | |
| 243 v2 (cdr v2))) | |
| 244 (if v1 | |
| 245 (if v2 | |
| 246 ;; Both not null; we know the cars are not =. | |
| 247 (funcall fun (car v1) (car v2)) | |
| 248 ;; V1 not null, V2 null. | |
| 249 (funcall fun (package--version-first-nonzero v1) 0)) | |
| 250 (if v2 | |
| 251 ;; V1 null, V2 not null. | |
| 252 (funcall fun 0 (package--version-first-nonzero v2)) | |
| 253 ;; Both null. | |
| 254 (funcall fun 0 0)))) | |
| 255 | |
| 256 (defun package--test-version-compare () | |
| 257 "Test suite for `package-version-compare'." | |
| 258 (unless (and (package-version-compare '(0) '(0) '=) | |
| 259 (not (package-version-compare '(1) '(0) '=)) | |
| 260 (package-version-compare '(1 0 1) '(1) '>=) | |
| 261 (package-version-compare '(1 0 1) '(1) '>) | |
| 262 (not (package-version-compare '(0 9 1) '(1 0 2) '>=))) | |
| 263 (error "Failed")) | |
| 264 t) | |
| 265 | |
| 266 (defun package-strip-version (dirname) | |
| 267 "Strip the version from a combined package name and version. | |
| 268 E.g., if DIRNAME is \"quux-23.0\", will return \"quux\"" | |
| 269 (if (string-match "^\\(.*\\)-[0-9]+\\([.][0-9]+\\)*$" dirname) | |
| 270 (match-string 1 dirname))) | |
| 271 | |
| 272 (defun package-load-descriptor (dir package) | |
| 273 "Load the description file in directory DIR for a PACKAGE. | |
| 274 Return nil if the package could not be found." | |
| 275 (let* ((pkg-dir (expand-file-name package dir)) | |
| 276 (pkg-file (expand-file-name | |
| 277 (concat (package-strip-version package) "-pkg") pkg-dir))) | |
| 278 (when (and (file-directory-p pkg-dir) | |
| 279 (file-exists-p (concat pkg-file ".el"))) | |
| 280 (load pkg-file nil t)))) | |
| 281 | |
| 282 (defun package-load-all-descriptors () | |
| 283 "Load descriptors of all packages. | |
| 284 Uses `package-directory-list' to find packages." | |
| 285 (mapc (lambda (dir) | |
| 286 (if (file-directory-p dir) | |
| 287 (mapc (lambda (name) | |
| 288 (package-load-descriptor dir name)) | |
| 289 (directory-files dir nil "^[^.]")))) | |
| 290 package-directory-list)) | |
| 291 | |
| 292 (defsubst package-desc-vers (desc) | |
| 293 "Extract version from a package description vector DESC." | |
| 294 (aref desc 0)) | |
| 295 | |
| 296 (defsubst package-desc-reqs (desc) | |
| 297 "Extract requirements from a package description vector DESC." | |
| 298 (aref desc 1)) | |
| 299 | |
| 300 (defsubst package-desc-doc (desc) | |
| 301 "Extract doc string from a package description vector DESC." | |
| 302 (aref desc 2)) | |
| 303 | |
| 304 (defsubst package-desc-kind (desc) | |
| 305 "Extract the kind of download from an archive package description vector DESC." | |
| 306 (aref desc 3)) | |
| 307 | |
| 308 (defun package-do-activate (package pkg-vec) | |
| 309 "Set up a single PACKAGE. | |
| 310 | |
| 311 Modifies `load-path' to include the package directory and loads | |
| 312 the `autoload' file for the package. PKG-VEC is the package info | |
| 313 as retrieved from the package mirror." | |
| 314 (let* ((pkg-name (symbol-name package)) | |
| 315 (pkg-ver-str (package-version-join (package-desc-vers pkg-vec))) | |
| 316 (dir-list package-directory-list) | |
| 317 (pkg-dir)) | |
| 318 (while dir-list | |
| 319 (let ((subdir (concat (car dir-list) pkg-name "-" pkg-ver-str "/"))) | |
| 320 (if (file-directory-p subdir) | |
| 321 (progn | |
| 322 (setq pkg-dir subdir) | |
| 323 (setq dir-list nil)) | |
| 324 (setq dir-list (cdr dir-list))))) | |
| 325 (unless pkg-dir | |
| 326 (error "Internal error: could not find directory for %s-%s" | |
| 327 pkg-name pkg-ver-str)) | |
| 328 (if (file-exists-p (concat pkg-dir "dir")) | |
| 329 (progn | |
| 330 ;; FIXME: not the friendliest, but simple. | |
| 331 (require 'info) | |
| 332 (info-initialize) | |
| 333 (setq Info-directory-list (cons pkg-dir Info-directory-list)))) | |
| 334 (setq load-path (cons pkg-dir load-path)) | |
| 335 ;; Load the autoloads and activate the package. | |
| 336 (load (concat pkg-dir (symbol-name package) "-autoloads") | |
| 337 nil t) | |
| 338 (setq package-activated-list (cons package package-activated-list)) | |
| 339 ;; Don't return nil. | |
| 340 t)) | |
| 341 | |
| 342 (defun package--built-in (package version) | |
| 343 "Return true if PACKAGE at VERSION is built-in to Emacs." | |
| 344 (let ((elt (assq package package--builtins))) | |
| 345 (and elt | |
| 346 (package-version-compare (package-desc-vers (cdr elt)) version '=)))) | |
| 347 | |
| 348 ;; FIXME: return a reason instead? | |
| 349 (defun package-activate (package version) | |
| 350 "Try to activate PACKAGE at version VERSION. | |
| 351 Return nil if the package could not be activated. | |
| 352 Recursively activates all dependencies of the named package." | |
| 353 ;; Assume the user knows what he is doing -- go ahead and activate a | |
| 354 ;; newer version of a package if an older one has already been | |
| 355 ;; activated. This is not ideal; we'd at least need to check to see | |
| 356 ;; if the package has actually been loaded, and not merely | |
| 357 ;; activated. However, don't try to activate 'emacs', as that makes | |
| 358 ;; no sense. | |
| 359 (unless (eq package 'emacs) | |
| 360 (let* ((pkg-desc (assq package package-alist)) | |
| 361 (this-version (package-desc-vers (cdr pkg-desc))) | |
| 362 (req-list (package-desc-reqs (cdr pkg-desc))) | |
| 363 ;; If the package was never activated, we want to do it | |
| 364 ;; now. | |
| 365 (keep-going (or (not (memq package package-activated-list)) | |
| 366 (package-version-compare this-version version '>)))) | |
| 367 (while (and req-list keep-going) | |
| 368 (or (package-activate (car (car req-list)) | |
| 369 (car (cdr (car req-list)))) | |
| 370 (setq keep-going nil)) | |
| 371 (setq req-list (cdr req-list))) | |
| 372 (if keep-going | |
| 373 (package-do-activate package (cdr pkg-desc)) | |
| 374 ;; We get here if a dependency failed to activate -- but we | |
| 375 ;; can also get here if the requested package was already | |
| 376 ;; activated. Return non-nil in the latter case. | |
| 377 (and (memq package package-activated-list) | |
| 378 (package-version-compare this-version version '>=)))))) | |
| 379 | |
| 380 (defun package-mark-obsolete (package pkg-vec) | |
| 381 "Put PACKAGE on the obsolete list, if not already there. | |
| 382 | |
| 383 PKG-VEC describes the version of PACKAGE to mark obsolete." | |
| 384 (let ((elt (assq package package-obsolete-alist))) | |
| 385 (if elt | |
| 386 ;; If this obsolete version does not exist in the list, update | |
| 387 ;; it the list. | |
| 388 (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) | |
| 389 (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) | |
| 390 (cdr elt)))) | |
| 391 ;; Make a new association. | |
| 392 (setq package-obsolete-alist | |
| 393 (cons (cons package (list (cons (package-desc-vers pkg-vec) | |
| 394 pkg-vec))) | |
| 395 package-obsolete-alist))))) | |
| 396 | |
| 397 ;; (define-package "emacs" "21.4.1" "GNU Emacs core package.") | |
| 398 ;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0"))) | |
| 399 (defun define-package (name-str version-string | |
| 400 &optional docstring requirements) | |
| 401 "Define a new package. | |
| 402 NAME-STR is the name of the package, a string. | |
| 403 VERSION-STRING is the version of the package, a dotted sequence | |
| 404 of integers. | |
| 405 DOCSTRING is the optional description. | |
| 406 REQUIREMENTS is a list of requirements on other packages. | |
| 407 Each requirement is of the form (OTHER-PACKAGE \"VERSION\")." | |
| 408 (let* ((name (intern name-str)) | |
| 409 (pkg-desc (assq name package-alist)) | |
| 410 (new-version (package-version-split version-string)) | |
| 411 (new-pkg-desc | |
| 412 (cons name | |
| 413 (vector new-version | |
| 414 (mapcar | |
| 415 (lambda (elt) | |
| 416 (list (car elt) | |
| 417 (package-version-split (car (cdr elt))))) | |
| 418 requirements) | |
| 419 docstring)))) | |
| 420 ;; Only redefine a package if the redefinition is newer. | |
| 421 (if (or (not pkg-desc) | |
| 422 (package-version-compare new-version | |
| 423 (package-desc-vers (cdr pkg-desc)) | |
| 424 '>)) | |
| 425 (progn | |
| 426 (when pkg-desc | |
| 427 ;; Remove old package and declare it obsolete. | |
| 428 (setq package-alist (delq pkg-desc package-alist)) | |
| 429 (package-mark-obsolete (car pkg-desc) (cdr pkg-desc))) | |
| 430 ;; Add package to the alist. | |
| 431 (setq package-alist (cons new-pkg-desc package-alist))) | |
| 432 ;; You can have two packages with the same version, for instance | |
| 433 ;; one in the system package directory and one in your private | |
| 434 ;; directory. We just let the first one win. | |
| 435 (unless (package-version-compare new-version | |
| 436 (package-desc-vers (cdr pkg-desc)) | |
| 437 '=) | |
| 438 ;; The package is born obsolete. | |
| 439 (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc)))))) | |
| 440 | |
| 441 ;; From Emacs 22. | |
| 442 (defun package-autoload-ensure-default-file (file) | |
| 443 "Make sure that the autoload file FILE exists and if not create it." | |
| 444 (unless (file-exists-p file) | |
| 445 (write-region | |
| 446 (concat ";;; " (file-name-nondirectory file) | |
| 447 " --- automatically extracted autoloads\n" | |
| 448 ";;\n" | |
| 449 ";;; Code:\n\n" | |
| 450 " \n;; Local Variables:\n" | |
| 451 ";; version-control: never\n" | |
| 452 ";; no-byte-compile: t\n" | |
| 453 ";; no-update-autoloads: t\n" | |
| 454 ";; End:\n" | |
| 455 ";;; " (file-name-nondirectory file) | |
| 456 " ends here\n") | |
| 457 nil file)) | |
| 458 file) | |
| 459 | |
| 460 (defun package-generate-autoloads (name pkg-dir) | |
| 461 "Generate autoload definitions for package NAME in PKG-DIR." | |
| 462 (let* ((auto-name (concat name "-autoloads.el")) | |
| 463 (ignore-name (concat name "-pkg.el")) | |
| 464 (generated-autoload-file (concat pkg-dir auto-name)) | |
| 465 (version-control 'never)) | |
| 466 ;; In Emacs 22 `update-directory-autoloads' does not seem | |
| 467 ;; to be autoloaded... | |
| 468 (require 'autoload) | |
| 469 (unless (fboundp 'autoload-ensure-default-file) | |
| 470 (package-autoload-ensure-default-file generated-autoload-file)) | |
| 471 (update-directory-autoloads pkg-dir))) | |
| 472 | |
| 473 (defun package-untar-buffer () | |
| 474 "Untar the current buffer. | |
| 475 This uses `tar-untar-buffer' if it is available. | |
| 476 Otherwise it uses an external `tar' program. | |
| 477 `default-directory' should be set by the caller." | |
| 478 (require 'tar-mode) | |
| 479 (if (fboundp 'tar-untar-buffer) | |
| 480 (progn | |
| 481 ;; tar-mode messes with narrowing, so we just let it have the | |
| 482 ;; whole buffer to play with. | |
| 483 (delete-region (point-min) (point)) | |
| 484 (tar-mode) | |
| 485 (tar-untar-buffer)) | |
| 486 ;; FIXME: check the result. | |
| 487 (call-process-region (point) (point-max) "tar" nil '(nil nil) nil | |
| 488 "xf" "-"))) | |
| 489 | |
| 490 (defun package-unpack (name version) | |
| 491 "Unpack a package tar from the current buffer. | |
| 492 | |
| 493 Unpack the package, using NAME and VERSION to determine the | |
| 494 target. The current buffer is expected to contain a tarred | |
| 495 package archive." | |
| 496 (let ((pkg-dir (concat (file-name-as-directory package-user-dir) | |
| 497 (symbol-name name) "-" version "/"))) | |
| 498 ;; Be careful!! | |
| 499 (make-directory package-user-dir t) | |
| 500 (if (file-directory-p pkg-dir) | |
| 501 (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're | |
| 502 ; more confident | |
| 503 (directory-files pkg-dir t "^[^.]"))) | |
| 504 (let* ((default-directory (file-name-as-directory package-user-dir))) | |
| 505 (package-untar-buffer) | |
| 506 (package-generate-autoloads (symbol-name name) pkg-dir) | |
| 507 (let ((load-path (cons pkg-dir load-path))) | |
| 508 (byte-recompile-directory pkg-dir 0 t))))) | |
| 509 | |
| 510 (defun package-unpack-single (file-name version desc requires) | |
| 511 "Install the contents of the current buffer as a package. | |
| 512 | |
| 513 FILE-NAME is the name of the current file being unpacked. | |
| 514 package.el itself is handled specially, so this information is | |
| 515 important. | |
| 516 | |
| 517 VERSION is the version (as a string) of the file being unpacked. | |
| 518 | |
| 519 DESC is a brief description of the package. | |
| 520 | |
| 521 REQUIRES is a list of symbols which this package needs to run." | |
| 522 (let* ((dir (file-name-as-directory package-user-dir))) | |
| 523 ;; Special case "package". | |
| 524 (if (string= file-name "package") | |
| 525 (write-region (point-min) (point-max) (concat dir file-name ".el") | |
| 526 nil nil nil nil) | |
| 527 (let ((pkg-dir (file-name-as-directory | |
| 528 (concat dir file-name "-" version)))) | |
| 529 (make-directory pkg-dir t) | |
| 530 (write-region (point-min) (point-max) | |
| 531 (concat pkg-dir file-name ".el") | |
| 532 nil nil nil 'excl) | |
| 533 (let ((print-level nil) | |
| 534 (print-length nil)) | |
| 535 (write-region | |
| 536 (concat | |
| 537 (prin1-to-string | |
| 538 (list 'define-package | |
| 539 file-name | |
| 540 version | |
| 541 desc | |
| 542 (list 'quote | |
| 543 ;; Turn version lists into string form. | |
| 544 (mapcar | |
| 545 (lambda (elt) | |
| 546 (list (car elt) | |
| 547 (package-version-join (car (cdr elt))))) | |
| 548 requires)))) | |
| 549 "\n") | |
| 550 nil | |
| 551 (concat pkg-dir file-name "-pkg.el") | |
| 552 nil nil nil 'excl)) | |
| 553 (package-generate-autoloads file-name pkg-dir) | |
| 554 (let ((load-path (cons pkg-dir load-path))) | |
| 555 (byte-recompile-directory pkg-dir 0 t)))))) | |
| 556 | |
| 557 (defun package-handle-response () | |
| 558 "Handle the response from the server. | |
| 559 Parse the HTTP response and throw if an error occurred. | |
| 560 The url package seems to require extra processing for this. | |
| 561 This should be called in a `save-excursion', in the download buffer. | |
| 562 It will move point to somewhere in the headers." | |
| 563 (let ((type (url-type url-current-object))) | |
| 564 (cond | |
| 565 ((equal type "http") | |
| 566 (let ((response (url-http-parse-response))) | |
| 567 (when (or (< response 200) (>= response 300)) | |
| 568 (display-buffer (current-buffer)) | |
| 569 (error "Error during download request:%s" | |
| 570 (buffer-substring-no-properties (point) (progn | |
| 571 (end-of-line) | |
| 572 (point))))))) | |
| 573 ((equal type "file") | |
| 574 nil)))) | |
| 575 | |
| 576 (defun package-download-single (name version desc requires) | |
| 577 "Download and install a single-file package. | |
| 578 | |
| 579 NAME, VERSION, DESC, and REQUIRES are used to build the package | |
| 580 info." | |
| 581 (let ((buffer (url-retrieve-synchronously | |
| 582 (concat (package-archive-for name) | |
| 583 (symbol-name name) "-" version ".el")))) | |
| 584 (save-excursion | |
| 585 (set-buffer buffer) | |
| 586 (package-handle-response) | |
| 587 (re-search-forward "^$" nil 'move) | |
| 588 (forward-char) | |
| 589 (delete-region (point-min) (point)) | |
| 590 (package-unpack-single (symbol-name name) version desc requires) | |
| 591 (kill-buffer buffer)))) | |
| 592 | |
| 593 (defun package-download-tar (name version) | |
| 594 "Download and install a tar package NAME at VERSION." | |
| 595 (let ((tar-buffer (url-retrieve-synchronously | |
| 596 (concat (package-archive-for name) | |
| 597 (symbol-name name) "-" version ".tar")))) | |
| 598 (save-excursion | |
| 599 (set-buffer tar-buffer) | |
| 600 (package-handle-response) | |
| 601 | |
| 602 ;; Skip past url-retrieve headers, which would otherwise confuse poor | |
| 603 ;; tar-mode. | |
| 604 (goto-char (point-min)) | |
| 605 (re-search-forward "^$" nil 'move) | |
| 606 (forward-char) | |
| 607 | |
| 608 (package-unpack name version) | |
| 609 (kill-buffer tar-buffer)))) | |
| 610 | |
| 611 (defun package-installed? (package &optional min-version) | |
| 612 "Check whether PACKAGE is installed and at least MIN-VERSION." | |
| 613 (let ((pkg-desc (assq package package-alist))) | |
| 614 (and pkg-desc | |
| 615 (package-version-compare min-version | |
| 616 (package-desc-vers (cdr pkg-desc)) | |
| 617 '<=)))) | |
| 618 | |
| 619 (defun package-compute-transaction (result requirements) | |
| 620 "Recursively prepare a transaction, resolving dependencies. | |
| 621 | |
| 622 RESULT is a flattened list of packages to install. | |
| 623 `package-compute-transaction' recursively builds this argument | |
| 624 before passing it up to the caller. | |
| 625 | |
| 626 REQUIREMENTS is a list of required packages, to be recursively | |
| 627 processed to resolve all dependencies (if possible)." | |
| 628 (while requirements | |
| 629 (let* ((elt (car requirements)) | |
| 630 (next-pkg (car elt)) | |
| 631 (next-version (car (cdr elt)))) | |
| 632 (unless (package-installed? next-pkg next-version) | |
| 633 (let ((pkg-desc (assq next-pkg package-archive-contents))) | |
| 634 (unless pkg-desc | |
| 635 (error "Package '%s' not available for installation" | |
| 636 (symbol-name next-pkg))) | |
| 637 (unless (package-version-compare (package-desc-vers (cdr pkg-desc)) | |
| 638 next-version | |
| 639 '>=) | |
| 640 (error | |
| 641 "Need package '%s' with version %s, but only %s is available" | |
| 642 (symbol-name next-pkg) (package-version-join next-version) | |
| 643 (package-version-join (package-desc-vers (cdr pkg-desc))))) | |
| 644 ;; Only add to the transaction if we don't already have it. | |
| 645 (unless (memq next-pkg result) | |
| 646 (setq result (cons next-pkg result))) | |
| 647 (setq result | |
| 648 (package-compute-transaction result | |
| 649 (package-desc-reqs | |
| 650 (cdr pkg-desc))))))) | |
| 651 (setq requirements (cdr requirements))) | |
| 652 result) | |
| 653 | |
| 654 (defun package-read-from-string (str) | |
| 655 "Read a Lisp expression from STR. | |
| 656 Signal an error if the entire string was not used." | |
| 657 (let* ((read-data (read-from-string str)) | |
| 658 (more-left | |
| 659 (condition-case nil | |
| 660 ;; The call to `ignore' suppresses a compiler warning. | |
| 661 (progn (ignore (read-from-string | |
| 662 (substring str (cdr read-data)))) | |
| 663 t) | |
| 664 (end-of-file nil)))) | |
| 665 (if more-left | |
| 666 (error "Can't read whole string") | |
| 667 (car read-data)))) | |
| 668 | |
| 669 (defun package--read-archive-file (file) | |
| 670 "Re-read archive file FILE, if it exists. | |
| 671 Will return the data from the file, or nil if the file does not exist. | |
| 672 Will throw an error if the archive version is too new." | |
| 673 (let ((filename (concat (file-name-as-directory package-user-dir) | |
| 674 file))) | |
| 675 (if (file-exists-p filename) | |
| 676 (with-temp-buffer | |
| 677 (insert-file-contents-literally filename) | |
| 678 (let ((contents (package-read-from-string | |
| 679 (buffer-substring-no-properties (point-min) | |
| 680 (point-max))))) | |
| 681 (if (> (car contents) package-archive-version) | |
| 682 (error "Package archive version %d is greater than %d - upgrade package.el" | |
| 683 (car contents) package-archive-version)) | |
| 684 (cdr contents)))))) | |
| 685 | |
| 686 (defun package-read-all-archive-contents () | |
| 687 "Read the archive description of each of the archives in `package-archives'." | |
| 688 (dolist (archive package-archives) | |
| 689 (package-read-archive-contents (car archive))) | |
| 690 (let ((builtins (package--read-archive-file | |
| 691 (concat "archives/" (caar package-archives) | |
| 692 "/builtin-packages")))) | |
| 693 (if builtins | |
| 694 ;; Version 1 of 'builtin-packages' is a list where the car is | |
| 695 ;; a split emacs version and the cdr is an alist suitable for | |
| 696 ;; package--builtins. | |
| 697 (let ((our-version (package-version-split emacs-version)) | |
| 698 (result package--builtins-base)) | |
| 699 (setq package--builtins | |
| 700 (dolist (elt builtins result) | |
| 701 (if (package-version-compare our-version (car elt) '>=) | |
| 702 (setq result (append (cdr elt) result))))))))) | |
| 703 | |
| 704 (defun package-read-archive-contents (archive) | |
| 705 "Re-read `archive-contents' and `builtin-packages', for ARCHIVE if they exist. | |
| 706 | |
| 707 Will set `package-archive-contents' and `package--builtins' if | |
| 708 successful. Will throw an error if the archive version is too | |
| 709 new." | |
| 710 (let ((archive-contents (package--read-archive-file | |
| 711 (concat "archives/" archive | |
| 712 "/archive-contents")))) | |
| 713 (if archive-contents | |
| 714 ;; Version 1 of 'archive-contents' is identical to our | |
| 715 ;; internal representation. | |
| 716 ;; TODO: merge archive lists | |
| 717 (dolist (package archive-contents) | |
| 718 (package--add-to-archive-contents package archive))))) | |
| 719 | |
| 720 (defun package--add-to-archive-contents (package archive) | |
| 721 "Add the PACKAGE from the given ARCHIVE if needed. | |
| 722 | |
| 723 Adds the archive from which it came to the end of the package vector." | |
| 724 (let* ((package-name (car package)) | |
| 725 (package-version (aref (cdr package) 0)) | |
| 726 (package-with-archive (cons (car package) | |
| 727 (vconcat (cdr package) (vector archive)))) | |
| 728 (existing-package (cdr (assq package-name package-archive-contents)))) | |
| 729 (when (or (not existing-package) | |
| 730 (package-version-compare package-version | |
| 731 (aref existing-package 0) '>)) | |
| 732 (add-to-list 'package-archive-contents package-with-archive)))) | |
| 733 | |
| 734 (defun package-download-transaction (transaction) | |
| 735 "Download and install all the packages in the given TRANSACTION." | |
| 736 (mapc (lambda (elt) | |
| 737 (let* ((desc (cdr (assq elt package-archive-contents))) | |
| 738 (v-string (package-version-join (package-desc-vers desc))) | |
| 739 (kind (package-desc-kind desc))) | |
| 740 (cond | |
| 741 ((eq kind 'tar) | |
| 742 (package-download-tar elt v-string)) | |
| 743 ((eq kind 'single) | |
| 744 (package-download-single elt v-string | |
| 745 (package-desc-doc desc) | |
| 746 (package-desc-reqs desc))) | |
| 747 (t | |
| 748 (error "Unknown package kind: " (symbol-name kind)))))) | |
| 749 transaction)) | |
| 750 | |
| 751 (defun package-install (name) | |
| 752 "Install the package named NAME. | |
| 753 Interactively, prompts for the package name." | |
| 754 (interactive | |
| 755 (list (progn | |
| 756 (intern (completing-read "Install package: " | |
| 757 (mapcar (lambda (elt) | |
| 758 (cons (symbol-name (car elt)) | |
| 759 nil)) | |
| 760 package-archive-contents) | |
| 761 nil t))))) | |
| 762 (let ((pkg-desc (assq name package-archive-contents))) | |
| 763 (unless pkg-desc | |
| 764 (error "Package '%s' not available for installation" | |
| 765 (symbol-name name))) | |
| 766 (let ((transaction | |
| 767 (package-compute-transaction (list name) | |
| 768 (package-desc-reqs (cdr pkg-desc))))) | |
| 769 (package-download-transaction transaction))) | |
| 770 ;; Try to activate it. | |
| 771 (package-initialize)) | |
| 772 | |
| 773 (defun package-strip-rcs-id (v-str) | |
| 774 "Strip RCS version ID from the version string V-STR. | |
| 775 | |
| 776 If the result looks like a dotted numeric version, return it. | |
| 777 Otherwise return nil." | |
| 778 (if v-str | |
| 779 (if (string-match "[ \t]*\\$\\(?:Revision\\|Id\\):[ \t]\\(?:[^ \t]+,v[ \t]+\\)?\\([0-9.]+\\).*\\$$" v-str) | |
| 780 (match-string 1 v-str) | |
| 781 (if (string-match "^[0-9.]*$" v-str) | |
| 782 v-str)))) | |
| 783 | |
| 784 (defun package-buffer-info () | |
| 785 "Return a vector of information about the package in the current buffer. | |
| 786 The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] | |
| 787 FILENAME is the file name, a string. It does not have the \".el\" extension. | |
| 788 REQUIRES is a requires list, or nil. | |
| 789 DESCRIPTION is the package description (a string). | |
| 790 VERSION is the version, a string. | |
| 791 COMMENTARY is the commentary section, a string, or nil if none. | |
| 792 Throws an exception if the buffer does not contain a conforming package. | |
| 793 If there is a package, narrows the buffer to the file's boundaries. | |
| 794 May narrow buffer or move point even on failure." | |
| 795 (goto-char (point-min)) | |
| 796 (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) | |
| 797 (let ((file-name (match-string 1)) | |
| 798 (desc (match-string 2)) | |
| 799 (start (progn (beginning-of-line) (point)))) | |
| 800 (if (search-forward (concat ";;; " file-name ".el ends here")) | |
| 801 (progn | |
| 802 ;; Try to include a trailing newline. | |
| 803 (forward-line) | |
| 804 (narrow-to-region start (point)) | |
| 805 (require 'lisp-mnt) | |
| 806 ;; Use some headers we've invented to drive the process. | |
| 807 (let* ((requires-str (lm-header "package-requires")) | |
| 808 (requires (if requires-str | |
| 809 (package-read-from-string requires-str))) | |
| 810 ;; Prefer Package-Version, because if it is | |
| 811 ;; defined the package author probably wants us | |
| 812 ;; to use it. Otherwise try Version. | |
| 813 (pkg-version | |
| 814 (or (package-strip-rcs-id (lm-header "package-version")) | |
| 815 (package-strip-rcs-id (lm-header "version")))) | |
| 816 (commentary (lm-commentary))) | |
| 817 (unless pkg-version | |
| 818 (error | |
| 819 "Package does not define a usable \"Version\" or \"Package-Version\" header")) | |
| 820 ;; Turn string version numbers into list form. | |
| 821 (setq requires | |
| 822 (mapcar | |
| 823 (lambda (elt) | |
| 824 (list (car elt) | |
| 825 (package-version-split (car (cdr elt))))) | |
| 826 requires)) | |
| 827 (set-text-properties 0 (length file-name) nil file-name) | |
| 828 (set-text-properties 0 (length pkg-version) nil pkg-version) | |
| 829 (set-text-properties 0 (length desc) nil desc) | |
| 830 (vector file-name requires desc pkg-version commentary))) | |
| 831 (error "Package missing a terminating comment"))) | |
| 832 (error "No starting comment for package"))) | |
| 833 | |
| 834 (defun package-tar-file-info (file) | |
| 835 "Find package information for a tar file. | |
| 836 FILE is the name of the tar file to examine. | |
| 837 The return result is a vector like `package-buffer-info'." | |
| 838 (setq file (expand-file-name file)) | |
| 839 (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) | |
| 840 (error "`%s' doesn't have a package-ish name" file)) | |
| 841 (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) | |
| 842 (pkg-version (match-string-no-properties 2 file)) | |
| 843 ;; Extract the package descriptor. | |
| 844 (pkg-def-contents (shell-command-to-string | |
| 845 ;; Requires GNU tar. | |
| 846 (concat "tar -xOf " file " " | |
| 847 pkg-name "-" pkg-version "/" | |
| 848 pkg-name "-pkg.el"))) | |
| 849 (pkg-def-parsed (package-read-from-string pkg-def-contents))) | |
| 850 (unless (eq (car pkg-def-parsed) 'define-package) | |
| 851 (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name)) | |
| 852 (let ((name-str (nth 1 pkg-def-parsed)) | |
| 853 (version-string (nth 2 pkg-def-parsed)) | |
| 854 (docstring (nth 3 pkg-def-parsed)) | |
| 855 (requires (nth 4 pkg-def-parsed)) | |
| 856 | |
| 857 (readme (shell-command-to-string | |
| 858 ;; Requires GNU tar. | |
| 859 (concat "tar -xOf " file " " | |
| 860 pkg-name "-" pkg-version "/README")))) | |
| 861 (unless (equal pkg-version version-string) | |
| 862 (error "Inconsistent versions!")) | |
| 863 (unless (equal pkg-name name-str) | |
| 864 (error "Inconsistent names!")) | |
| 865 ;; Kind of a hack. | |
| 866 (if (string-match ": Not found in archive" readme) | |
| 867 (setq readme nil)) | |
| 868 ;; Turn string version numbers into list form. | |
| 869 (if (eq (car requires) 'quote) | |
| 870 (setq requires (car (cdr requires)))) | |
| 871 (setq requires | |
| 872 (mapcar | |
| 873 (lambda (elt) | |
| 874 (list (car elt) | |
| 875 (package-version-split (car (cdr elt))))) | |
| 876 requires)) | |
| 877 (vector pkg-name requires docstring version-string readme)))) | |
| 878 | |
| 879 (defun package-install-buffer-internal (pkg-info type) | |
| 880 "Download and install a single package. | |
| 881 | |
| 882 PKG-INFO describes the package to be installed. | |
| 883 | |
| 884 TYPE is either `single' or `tar'." | |
| 885 (save-excursion | |
| 886 (save-restriction | |
| 887 (let* ((file-name (aref pkg-info 0)) | |
| 888 (requires (aref pkg-info 1)) | |
| 889 (desc (if (string= (aref pkg-info 2) "") | |
| 890 "No description available." | |
| 891 (aref pkg-info 2))) | |
| 892 (pkg-version (aref pkg-info 3))) | |
| 893 ;; Download and install the dependencies. | |
| 894 (let ((transaction (package-compute-transaction nil requires))) | |
| 895 (package-download-transaction transaction)) | |
| 896 ;; Install the package itself. | |
| 897 (cond | |
| 898 ((eq type 'single) | |
| 899 (package-unpack-single file-name pkg-version desc requires)) | |
| 900 ((eq type 'tar) | |
| 901 (package-unpack (intern file-name) pkg-version)) | |
| 902 (t | |
| 903 (error "Unknown type: %s" (symbol-name type)))) | |
| 904 ;; Try to activate it. | |
| 905 (package-initialize))))) | |
| 906 | |
| 907 (defun package-install-from-buffer () | |
| 908 "Install a package from the current buffer. | |
| 909 The package is assumed to be a single .el file which | |
| 910 follows the elisp comment guidelines; see | |
| 911 info node `(elisp)Library Headers'." | |
| 912 (interactive) | |
| 913 (package-install-buffer-internal (package-buffer-info) 'single)) | |
| 914 | |
| 915 (defun package-install-file (file) | |
| 916 "Install a package from a FILE. | |
| 917 The file can either be a tar file or an Emacs Lisp file." | |
| 918 (interactive "fPackage file name: ") | |
| 919 (with-temp-buffer | |
| 920 (insert-file-contents-literally file) | |
| 921 (cond | |
| 922 ((string-match "\\.el$" file) (package-install-from-buffer)) | |
| 923 ((string-match "\\.tar$" file) | |
| 924 (package-install-buffer-internal (package-tar-file-info file) 'tar)) | |
| 925 (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) | |
| 926 | |
| 927 (defun package-delete (name version) | |
| 928 "Delete package NAME at VERSION." | |
| 929 (require 'dired) ; for dired-delete-file | |
| 930 (dired-delete-file (concat (file-name-as-directory package-user-dir) | |
| 931 name "-" version) | |
| 932 ;; FIXME: query user? | |
| 933 'always)) | |
| 934 | |
| 935 (defun package--encode (string) | |
| 936 "Encode a STRING by replacing some characters with XML entities." | |
| 937 ;; We need a special case for translating "&" to "&". | |
| 938 (let ((index)) | |
| 939 (while (setq index (string-match "[&]" string index)) | |
| 940 (setq string (replace-match "&" t nil string)) | |
| 941 (setq index (1+ index)))) | |
| 942 (while (string-match "[<]" string) | |
| 943 (setq string (replace-match "<" t nil string))) | |
| 944 (while (string-match "[>]" string) | |
| 945 (setq string (replace-match ">" t nil string))) | |
| 946 (while (string-match "[']" string) | |
| 947 (setq string (replace-match "'" t nil string))) | |
| 948 (while (string-match "[\"]" string) | |
| 949 (setq string (replace-match """ t nil string))) | |
| 950 string) | |
| 951 | |
| 952 (defun package--update-file (file location text) | |
| 953 "Update FILE by finding LOCATION and inserting TEXT." | |
| 954 (save-excursion | |
| 955 (let ((old-buffer (find-buffer-visiting file))) | |
| 956 (with-current-buffer (let ((find-file-visit-truename t)) | |
| 957 (or old-buffer (find-file-noselect file))) | |
| 958 (goto-char (point-min)) | |
| 959 (search-forward location) | |
| 960 (forward-line) | |
| 961 (insert text) | |
| 962 (let ((file-precious-flag t)) | |
| 963 (save-buffer)) | |
| 964 (unless old-buffer | |
| 965 (kill-buffer (current-buffer))))))) | |
| 966 | |
| 967 (defun package-archive-for (name) | |
| 968 "Return the archive containing the package NAME." | |
| 969 (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) | |
| 970 (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) | |
| 971 | |
| 972 (defun package--download-one-archive (archive file) | |
| 973 "Download a single archive file and cache it locally. | |
| 974 | |
| 975 Downloads the archive index from ARCHIVE and stores it in FILE." | |
| 976 (let* ((archive-name (car archive)) | |
| 977 (archive-url (cdr archive)) | |
| 978 (buffer (url-retrieve-synchronously (concat archive-url file)))) | |
| 979 (save-excursion | |
| 980 (set-buffer buffer) | |
| 981 (package-handle-response) | |
| 982 (re-search-forward "^$" nil 'move) | |
| 983 (forward-char) | |
| 984 (delete-region (point-min) (point)) | |
| 985 (make-directory (concat (file-name-as-directory package-user-dir) | |
| 986 "archives/" archive-name) t) | |
| 987 (setq buffer-file-name (concat (file-name-as-directory package-user-dir) | |
| 988 "archives/" archive-name "/" file)) | |
| 989 (let ((version-control 'never)) | |
| 990 (save-buffer)) | |
| 991 (kill-buffer buffer)))) | |
| 992 | |
| 993 (defun package-refresh-contents () | |
| 994 "Download the ELPA archive description if needed. | |
| 995 Invoking this will ensure that Emacs knows about the latest versions | |
| 996 of all packages. This will let Emacs make them available for | |
| 997 download." | |
| 998 (interactive) | |
| 999 (dolist (archive package-archives) | |
| 1000 (package--download-one-archive archive "archive-contents")) | |
| 1001 (package-read-all-archive-contents)) | |
| 1002 | |
| 1003 (defun package-initialize () | |
| 1004 "Load all packages and activate as many as possible." | |
| 1005 (setq package-obsolete-alist nil) | |
| 1006 (package-load-all-descriptors) | |
| 1007 (package-read-all-archive-contents) | |
| 1008 ;; Try to activate all our packages. | |
| 1009 (mapc (lambda (elt) | |
| 1010 (package-activate (car elt) (package-desc-vers (cdr elt)))) | |
| 1011 package-alist)) | |
| 1012 | |
| 1013 | |
| 1014 | |
| 1015 ;;;; Package menu mode. | |
| 1016 | |
| 1017 (defvar package-menu-mode-map | |
| 1018 (let ((map (make-keymap)) | |
| 1019 (menu-map (make-sparse-keymap "Package"))) | |
| 1020 (suppress-keymap map) | |
| 1021 (define-key map "q" 'quit-window) | |
| 1022 (define-key map "n" 'next-line) | |
| 1023 (define-key map "p" 'previous-line) | |
| 1024 (define-key map "u" 'package-menu-mark-unmark) | |
| 1025 (define-key map "\177" 'package-menu-backup-unmark) | |
| 1026 (define-key map "d" 'package-menu-mark-delete) | |
| 1027 (define-key map "i" 'package-menu-mark-install) | |
| 1028 (define-key map "g" 'package-menu-revert) | |
| 1029 (define-key map "r" 'package-menu-refresh) | |
| 1030 (define-key map "~" 'package-menu-mark-obsolete-for-deletion) | |
| 1031 (define-key map "x" 'package-menu-execute) | |
| 1032 (define-key map "h" 'package-menu-quick-help) | |
| 1033 (define-key map "?" 'package-menu-view-commentary) | |
| 1034 (define-key map [menu-bar package-menu] (cons "Package" menu-map)) | |
| 1035 (define-key menu-map [mq] | |
| 1036 '(menu-item "Quit" quit-window | |
| 1037 :help "Quit package selection")) | |
| 1038 (define-key menu-map [s1] '("--")) | |
| 1039 (define-key menu-map [mn] | |
| 1040 '(menu-item "Next" next-line | |
| 1041 :help "Next Line")) | |
| 1042 (define-key menu-map [mp] | |
| 1043 '(menu-item "Previous" previous-line | |
| 1044 :help "Previous Line")) | |
| 1045 (define-key menu-map [s2] '("--")) | |
| 1046 (define-key menu-map [mu] | |
| 1047 '(menu-item "Unmark" package-menu-mark-unmark | |
| 1048 :help "Clear any marks on a package and move to the next line")) | |
| 1049 (define-key menu-map [munm] | |
| 1050 '(menu-item "Unmark backwards" package-menu-backup-unmark | |
| 1051 :help "Back up one line and clear any marks on that package")) | |
| 1052 (define-key menu-map [md] | |
| 1053 '(menu-item "Mark for deletion" package-menu-mark-delete | |
| 1054 :help "Mark a package for deletion and move to the next line")) | |
| 1055 (define-key menu-map [mi] | |
| 1056 '(menu-item "Mark for install" package-menu-mark-install | |
| 1057 :help "Mark a package for installation and move to the next line")) | |
| 1058 (define-key menu-map [s3] '("--")) | |
| 1059 (define-key menu-map [mg] | |
| 1060 '(menu-item "Update package list" package-menu-revert | |
| 1061 :help "Update the list of packages")) | |
| 1062 (define-key menu-map [mr] | |
| 1063 '(menu-item "Refresh package list" package-menu-refresh | |
| 1064 :help "Download the ELPA archive")) | |
| 1065 (define-key menu-map [s4] '("--")) | |
| 1066 (define-key menu-map [mt] | |
| 1067 '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion | |
| 1068 :help "Mark all obsolete packages for deletion")) | |
| 1069 (define-key menu-map [mx] | |
| 1070 '(menu-item "Execute actions" package-menu-execute | |
| 1071 :help "Perform all the marked actions")) | |
| 1072 (define-key menu-map [s5] '("--")) | |
| 1073 (define-key menu-map [mh] | |
| 1074 '(menu-item "Help" package-menu-quick-help | |
| 1075 :help "Show short key binding help for package-menu-mode")) | |
| 1076 (define-key menu-map [mc] | |
| 1077 '(menu-item "View Commentary" package-menu-view-commentary | |
| 1078 :help "Display information about this package")) | |
| 1079 map) | |
| 1080 "Local keymap for `package-menu-mode' buffers.") | |
| 1081 | |
| 1082 (defvar package-menu-sort-button-map | |
| 1083 (let ((map (make-sparse-keymap))) | |
| 1084 (define-key map [header-line mouse-1] 'package-menu-sort-by-column) | |
| 1085 (define-key map [follow-link] 'mouse-face) | |
| 1086 map) | |
| 1087 "Local keymap for package menu sort buttons.") | |
| 1088 | |
| 1089 (put 'package-menu-mode 'mode-class 'special) | |
| 1090 | |
| 1091 (defun package-menu-mode () | |
| 1092 "Major mode for browsing a list of packages. | |
| 1093 Letters do not insert themselves; instead, they are commands. | |
| 1094 \\<package-menu-mode-map> | |
| 1095 \\{package-menu-mode-map}" | |
| 1096 (kill-all-local-variables) | |
| 1097 (use-local-map package-menu-mode-map) | |
| 1098 (setq major-mode 'package-menu-mode) | |
| 1099 (setq mode-name "Package Menu") | |
| 1100 (setq truncate-lines t) | |
| 1101 (setq buffer-read-only t) | |
| 1102 ;; Support Emacs 21. | |
| 1103 (if (fboundp 'run-mode-hooks) | |
| 1104 (run-mode-hooks 'package-menu-mode-hook) | |
| 1105 (run-hooks 'package-menu-mode-hook))) | |
| 1106 | |
| 1107 (defun package-menu-refresh () | |
| 1108 "Download the ELPA archive. | |
| 1109 This fetches the file describing the current contents of | |
| 1110 the Emacs Lisp Package Archive, and then refreshes the | |
| 1111 package menu. This lets you see what new packages are | |
| 1112 available for download." | |
| 1113 (interactive) | |
| 1114 (package-refresh-contents) | |
| 1115 (package-list-packages-internal)) | |
| 1116 | |
| 1117 (defun package-menu-revert () | |
| 1118 "Update the list of packages." | |
| 1119 (interactive) | |
| 1120 (package-list-packages-internal)) | |
| 1121 | |
| 1122 (defun package-menu-mark-internal (what) | |
| 1123 "Internal function to mark a package. | |
| 1124 | |
| 1125 WHAT is the character used to mark the line." | |
| 1126 (unless (eobp) | |
| 1127 (let ((buffer-read-only nil)) | |
| 1128 (beginning-of-line) | |
| 1129 (delete-char 1) | |
| 1130 (insert what) | |
| 1131 (forward-line)))) | |
| 1132 | |
| 1133 (defun package-menu-mark-delete (&optional arg) | |
| 1134 "Mark a package for deletion and move to the next line. | |
| 1135 | |
| 1136 ARG is a (currently unused) numeric argument." | |
| 1137 (interactive "p") | |
| 1138 (package-menu-mark-internal "D")) | |
| 1139 | |
| 1140 (defun package-menu-mark-install (&optional arg) | |
| 1141 "Mark a package for installation and move to the next line. | |
| 1142 | |
| 1143 ARG is a (currently unused) numeric argument." | |
| 1144 (interactive "p") | |
| 1145 (package-menu-mark-internal "I")) | |
| 1146 | |
| 1147 (defun package-menu-mark-unmark (&optional arg) | |
| 1148 "Clear any marks on a package and move to the next line. | |
| 1149 | |
| 1150 ARG is a (currently unused) numeric argument." | |
| 1151 (interactive "p") | |
| 1152 (package-menu-mark-internal " ")) | |
| 1153 | |
| 1154 (defun package-menu-backup-unmark () | |
| 1155 "Back up one line and clear any marks on that package." | |
| 1156 (interactive) | |
| 1157 (forward-line -1) | |
| 1158 (package-menu-mark-internal " ") | |
| 1159 (forward-line -1)) | |
| 1160 | |
| 1161 (defun package-menu-mark-obsolete-for-deletion () | |
| 1162 "Mark all obsolete packages for deletion." | |
| 1163 (interactive) | |
| 1164 (save-excursion | |
| 1165 (goto-char (point-min)) | |
| 1166 (forward-line 2) | |
| 1167 (while (not (eobp)) | |
| 1168 (if (looking-at ".*\\s obsolete\\s ") | |
| 1169 (package-menu-mark-internal "D") | |
| 1170 (forward-line 1))))) | |
| 1171 | |
| 1172 (defun package-menu-quick-help () | |
| 1173 "Show short key binding help for `package-menu-mode'." | |
| 1174 (interactive) | |
| 1175 (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp ?-view commentary")) | |
| 1176 | |
| 1177 (defun package-menu-view-commentary () | |
| 1178 "Display information about this package. | |
| 1179 For single-file packages, shows the commentary section from the header. | |
| 1180 For larger packages, shows the README file." | |
| 1181 (interactive) | |
| 1182 (let* (start-point ok | |
| 1183 (pkg-name (package-menu-get-package)) | |
| 1184 (buffer (url-retrieve-synchronously | |
| 1185 (concat (package-archive-for pkg-name) | |
| 1186 pkg-name "-readme.txt")))) | |
| 1187 (with-current-buffer buffer | |
| 1188 ;; FIXME: it would be nice to work with any URL type. | |
| 1189 (setq start-point url-http-end-of-headers) | |
| 1190 (setq ok (eq (url-http-parse-response) 200))) | |
| 1191 (let ((new-buffer (get-buffer-create "*Package Info*"))) | |
| 1192 (with-current-buffer new-buffer | |
| 1193 (let ((buffer-read-only nil)) | |
| 1194 (erase-buffer) | |
| 1195 (insert "Package information for " pkg-name "\n\n") | |
| 1196 (if ok | |
| 1197 (insert-buffer-substring buffer start-point) | |
| 1198 (insert "This package does not have a README file or commentary comment.\n")) | |
| 1199 (goto-char (point-min)) | |
| 1200 (view-mode))) | |
| 1201 (display-buffer new-buffer t)))) | |
| 1202 | |
| 1203 (defun package-menu-get-package () | |
| 1204 "Return the name of the package on the current line." | |
| 1205 (save-excursion | |
| 1206 (beginning-of-line) | |
| 1207 (if (looking-at ". \\([^ \t]*\\)") | |
| 1208 (match-string-no-properties 1)))) | |
| 1209 | |
| 1210 (defun package-menu-get-version () | |
| 1211 "Return the version of the package on the current line." | |
| 1212 (save-excursion | |
| 1213 (beginning-of-line) | |
| 1214 (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)") | |
| 1215 (match-string 1)))) | |
| 1216 | |
| 1217 (defun package-menu-get-status () | |
| 1218 "Get the status of the current line." | |
| 1219 (save-excursion | |
| 1220 (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)") | |
| 1221 (match-string 1) | |
| 1222 ""))) | |
| 1223 | |
| 1224 (defun package-menu-execute () | |
| 1225 "Perform all the marked actions. | |
| 1226 Packages marked for installation will be downloaded and | |
| 1227 installed. Packages marked for deletion will be removed. | |
| 1228 Note that after installing packages you will want to restart | |
| 1229 Emacs." | |
| 1230 (interactive) | |
| 1231 (goto-char (point-min)) | |
| 1232 (forward-line 2) | |
| 1233 (while (not (eobp)) | |
| 1234 (let ((cmd (char-after)) | |
| 1235 (pkg-name (package-menu-get-package)) | |
| 1236 (pkg-vers (package-menu-get-version)) | |
| 1237 (pkg-status (package-menu-get-status))) | |
| 1238 (cond | |
| 1239 ((eq cmd ?D) | |
| 1240 (when (and (string= pkg-status "installed") | |
| 1241 (string= pkg-name "package")) | |
| 1242 ;; FIXME: actually, we could be tricky and remove all info. | |
| 1243 ;; But that is drastic and the user can do that instead. | |
| 1244 (error "Can't delete most recent version of `package'")) | |
| 1245 ;; Ask for confirmation here? Maybe if package status is ""? | |
| 1246 ;; Or if any lisp from package is actually loaded? | |
| 1247 (message "Deleting %s-%s..." pkg-name pkg-vers) | |
| 1248 (package-delete pkg-name pkg-vers) | |
| 1249 (message "Deleting %s-%s... done" pkg-name pkg-vers)) | |
| 1250 ((eq cmd ?I) | |
| 1251 (package-install (intern pkg-name))))) | |
| 1252 (forward-line)) | |
| 1253 (package-menu-revert)) | |
| 1254 | |
| 1255 (defun package-print-package (package version key desc) | |
| 1256 "Print out a single PACKAGE line for the menu buffer. | |
| 1257 | |
| 1258 PACKAGE is the package name as a symbol. | |
| 1259 | |
| 1260 VERSION is the version as an integer vector. | |
| 1261 | |
| 1262 KEY is the installation status of the package; either | |
| 1263 \"available\" or \"installed\". | |
| 1264 | |
| 1265 DESC is the short description of the package." | |
| 1266 (let ((face | |
| 1267 (cond ((eq package 'emacs) 'font-lock-builtin-face) | |
| 1268 ((string= key "available") 'default) | |
| 1269 ((string= key "installed") 'font-lock-comment-face) | |
| 1270 (t ; obsolete, but also the default. | |
| 1271 ; is warning ok? | |
| 1272 'font-lock-warning-face)))) | |
| 1273 (insert (propertize " " 'font-lock-face face)) | |
| 1274 (insert (propertize (symbol-name package) 'font-lock-face face)) | |
| 1275 (indent-to 20 1) | |
| 1276 (insert (propertize (package-version-join version) 'font-lock-face face)) | |
| 1277 (indent-to 30 1) | |
| 1278 (insert (propertize key 'font-lock-face face)) | |
| 1279 ;; FIXME: this 'when' is bogus... | |
| 1280 (when desc | |
| 1281 (indent-to 41 1) | |
| 1282 (insert (propertize desc 'font-lock-face face))) | |
| 1283 (insert "\n"))) | |
| 1284 | |
| 1285 (defun package-list-maybe-add (package version status description result) | |
| 1286 "Add PACKAGE to the list if it is not already there. | |
| 1287 | |
| 1288 PACKAGE is the package name as a symbol. | |
| 1289 | |
| 1290 VERSION is the package version, as an integer vector. | |
| 1291 | |
| 1292 STATUS is the installation status of the package, either | |
| 1293 \"available\" or \"installed\". | |
| 1294 | |
| 1295 DESCRIPTION is the short description of the package. | |
| 1296 | |
| 1297 RESULT is the list to which to add the package." | |
| 1298 (let ((elt (assoc (cons package version) result))) | |
| 1299 (unless elt | |
| 1300 (setq result (cons (list (cons package version) status description) | |
| 1301 result)))) | |
| 1302 result) | |
| 1303 | |
| 1304 ;; This decides how we should sort; nil means by package name. | |
| 1305 (defvar package-menu-sort-key nil) | |
| 1306 | |
| 1307 (defun package-list-packages-internal () | |
| 1308 "List the available and installed packages." | |
| 1309 (package-initialize) ; FIXME: do this here? | |
| 1310 (with-current-buffer (get-buffer-create "*Packages*") | |
| 1311 (setq buffer-read-only nil) | |
| 1312 (erase-buffer) | |
| 1313 (let ((info-list)) | |
| 1314 (mapc (lambda (elt) | |
| 1315 (setq info-list | |
| 1316 (package-list-maybe-add (car elt) | |
| 1317 (package-desc-vers (cdr elt)) | |
| 1318 ;; FIXME: it turns out to | |
| 1319 ;; be tricky to see if | |
| 1320 ;; this package is | |
| 1321 ;; presently activated. | |
| 1322 ;; That is lame! | |
| 1323 "installed" | |
| 1324 (package-desc-doc (cdr elt)) | |
| 1325 info-list))) | |
| 1326 package-alist) | |
| 1327 (mapc (lambda (elt) | |
| 1328 (setq info-list | |
| 1329 (package-list-maybe-add (car elt) | |
| 1330 (package-desc-vers (cdr elt)) | |
| 1331 "available" | |
| 1332 (package-desc-doc (cdr elt)) | |
| 1333 info-list))) | |
| 1334 package-archive-contents) | |
| 1335 (mapc (lambda (elt) | |
| 1336 (mapc (lambda (inner-elt) | |
| 1337 (setq info-list | |
| 1338 (package-list-maybe-add (car elt) | |
| 1339 (package-desc-vers | |
| 1340 (cdr inner-elt)) | |
| 1341 "obsolete" | |
| 1342 (package-desc-doc | |
| 1343 (cdr inner-elt)) | |
| 1344 info-list))) | |
| 1345 (cdr elt))) | |
| 1346 package-obsolete-alist) | |
| 1347 (let ((selector (cond | |
| 1348 ((string= package-menu-sort-key "Version") | |
| 1349 ;; FIXME this doesn't work. | |
| 1350 #'(lambda (e) (cdr (car e)))) | |
| 1351 ((string= package-menu-sort-key "Status") | |
| 1352 #'(lambda (e) (car (cdr e)))) | |
| 1353 ((string= package-menu-sort-key "Description") | |
| 1354 #'(lambda (e) (car (cdr (cdr e))))) | |
| 1355 (t ; "Package" is default. | |
| 1356 #'(lambda (e) (symbol-name (car (car e)))))))) | |
| 1357 (setq info-list | |
| 1358 (sort info-list | |
| 1359 (lambda (left right) | |
| 1360 (let ((vleft (funcall selector left)) | |
| 1361 (vright (funcall selector right))) | |
| 1362 (string< vleft vright)))))) | |
| 1363 (mapc (lambda (elt) | |
| 1364 (package-print-package (car (car elt)) | |
| 1365 (cdr (car elt)) | |
| 1366 (car (cdr elt)) | |
| 1367 (car (cdr (cdr elt))))) | |
| 1368 info-list)) | |
| 1369 (goto-char (point-min)) | |
| 1370 (current-buffer))) | |
| 1371 | |
| 1372 (defun package-menu-sort-by-column (&optional e) | |
| 1373 "Sort the package menu by the last column clicked, E." | |
| 1374 (interactive (list last-input-event)) | |
| 1375 (if e (mouse-select-window e)) | |
| 1376 (let* ((pos (event-start e)) | |
| 1377 (obj (posn-object pos)) | |
| 1378 (col (if obj | |
| 1379 (get-text-property (cdr obj) 'column-name (car obj)) | |
| 1380 (get-text-property (posn-point pos) 'column-name)))) | |
| 1381 (setq package-menu-sort-key col)) | |
| 1382 (package-list-packages-internal)) | |
| 1383 | |
| 1384 (defun package--list-packages () | |
| 1385 "Display a list of packages. | |
| 1386 Helper function that does all the work for the user-facing functions." | |
| 1387 (with-current-buffer (package-list-packages-internal) | |
| 1388 (package-menu-mode) | |
| 1389 ;; Set up the header line. | |
| 1390 (setq header-line-format | |
| 1391 (mapconcat | |
| 1392 (lambda (pair) | |
| 1393 (let ((column (car pair)) | |
| 1394 (name (cdr pair))) | |
| 1395 (concat | |
| 1396 ;; Insert a space that aligns the button properly. | |
| 1397 (propertize " " 'display (list 'space :align-to column) | |
| 1398 'face 'fixed-pitch) | |
| 1399 ;; Set up the column button. | |
| 1400 (if (string= name "Version") | |
| 1401 name | |
| 1402 (propertize name | |
| 1403 'column-name name | |
| 1404 'help-echo "mouse-1: sort by column" | |
| 1405 'mouse-face 'highlight | |
| 1406 'keymap package-menu-sort-button-map))))) | |
| 1407 ;; We take a trick from buff-menu and have a dummy leading | |
| 1408 ;; space to align the header line with the beginning of the | |
| 1409 ;; text. This doesn't really work properly on Emacs 21, | |
| 1410 ;; but it is close enough. | |
| 1411 '((0 . "") | |
| 1412 (2 . "Package") | |
| 1413 (20 . "Version") | |
| 1414 (30 . "Status") | |
| 1415 (41 . "Description")) | |
| 1416 "")) | |
| 1417 | |
| 1418 ;; It's okay to use pop-to-buffer here. The package menu buffer | |
| 1419 ;; has keybindings, and the user just typed 'M-x | |
| 1420 ;; package-list-packages', suggesting that they might want to use | |
| 1421 ;; them. | |
| 1422 (pop-to-buffer (current-buffer)))) | |
| 1423 | |
| 1424 (defun package-list-packages () | |
| 1425 "Display a list of packages. | |
| 1426 Fetches the updated list of packages before displaying. | |
| 1427 The list is displayed in a buffer named `*Packages*'." | |
| 1428 (interactive) | |
| 1429 (package-refresh-contents) | |
| 1430 (package--list-packages)) | |
| 1431 | |
| 1432 (defun package-list-packages-no-fetch () | |
| 1433 "Display a list of packages. | |
| 1434 Does not fetch the updated list of packages before displaying. | |
| 1435 The list is displayed in a buffer named `*Packages*'." | |
| 1436 (interactive) | |
| 1437 (package--list-packages)) | |
| 1438 | |
| 1439 ;; Make it appear on the menu. | |
| 1440 (define-key-after menu-bar-options-menu [package] | |
| 1441 '(menu-item "Manage Packages" package-list-packages | |
| 1442 :help "Install or uninstall additional Emacs packages")) | |
| 1443 | |
| 1444 (provide 'package) | |
| 1445 | |
| 1446 ;;; package.el ends here |