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