comparison lisp/package-get.el @ 377:d883f39b8495 r21-2b4

Import from CVS: tag r21-2b4
author cvs
date Mon, 13 Aug 2007 11:05:42 +0200
parents a300bb07d72d
children 8626e4521993
comparison
equal deleted inserted replaced
376:e2295b4d9f2e 377:d883f39b8495
1 ;;; package-get.el --- Retrieve XEmacs package 1 ;;; package-get.el --- Retrieve XEmacs package
2 2
3 ;; Copyright (C) 1998 by Pete Ware 3 ;; Copyright (C) 1998 by Pete Ware
4 4
5 ;; Author: Pete Ware <ware@cis.ohio-state.edu> 5 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
6 ;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com>
7 ;; Jan Vroonhof <vroonhof@math.ethz.ch>
6 ;; Keywords: internal 8 ;; Keywords: internal
7 9
8 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
9 11
10 ;; XEmacs is free software; you can redistribute it and/or modify it 12 ;; XEmacs is free software; you can redistribute it and/or modify it
26 28
27 ;;; Commentary: 29 ;;; Commentary:
28 30
29 ;; package-get - 31 ;; package-get -
30 ;; Retrieve a package and any other required packages from an archive 32 ;; Retrieve a package and any other required packages from an archive
33 ;;
34 ;;
35 ;; Note (JV): Most of this no longer aplies!
31 ;; 36 ;;
32 ;; The idea: 37 ;; The idea:
33 ;; A new XEmacs lisp-only release is generated with the following steps: 38 ;; A new XEmacs lisp-only release is generated with the following steps:
34 ;; 1. The maintainer runs some yet to be written program that 39 ;; 1. The maintainer runs some yet to be written program that
35 ;; generates all the dependency information. This should 40 ;; generates all the dependency information. This should
158 "*Where to store temporary files for staging." 163 "*Where to store temporary files for staging."
159 :tag "Temporary directory" 164 :tag "Temporary directory"
160 :type 'directory 165 :type 'directory
161 :group 'package-get) 166 :group 'package-get)
162 167
163 ;; JV Any Custom expert know to get "Host" and "Dir" for the remote option 168 (define-widget 'host-name 'string
164 (defcustom package-get-remote 169 "A Host name."
165 '(("ftp.xemacs.org" "/pub/xemacs/packages")) 170 :tag "Host")
171
172 (defcustom package-get-remote nil
166 "*List of remote sites to contact for downloading packages. 173 "*List of remote sites to contact for downloading packages.
167 List format is '(site-name directory-on-site). Each site is tried in 174 List format is '(site-name directory-on-site). Each site is tried in
168 order until the package is found. As a special case, `site-name' can be 175 order until the package is found. As a special case, `site-name' can be
169 `nil', in which case `directory-on-site' is treated as a local directory." 176 `nil', in which case `directory-on-site' is treated as a local directory."
170 :tag "Package repository" 177 :tag "Package repository"
171 :type '(repeat (choice (list :tag "Local" (const :tag "Local" nil) directory ) 178 :type '(repeat (choice (list :tag "Local" (const :tag "Local" nil) directory )
172 (list :tag "Remote" string string) )) 179 (list :tag "Remote" host-name directory) ))
173 :group 'package-get) 180 :group 'package-get)
174 181
175 (defcustom package-get-remove-copy nil 182 (defcustom package-get-download-sites
183 '(
184 ;; North America
185 ("xemacs.org" "ftp.xemacs.org" "pub/xemacs/packages")
186 ("cso.uiuc.edu" "ftp.cso.uiuc.edu" "pub/packages/xemacs/packages")
187
188 ;; South America
189 ("unicamp.br" "ftp.unicamp.br" "pub/xemacs/packages")
190
191 ;; Europe
192 ("sunsite.cnlab-switch.ch" "sunsite.cnlab-switch.ch" "mirror/xemacs/packages")
193 ("tu-darmstadt.de" "ftp.tu-darmstadt.de" "pub/editors/xemacs/packages")
194 ("sunsite.auc.dk" "sunsite.auc.dk" "pub/emacs/xemacs/packages")
195 ("pasteur.fr" "ftp.pasteur.fr" "pub/computing/xemacs/packages")
196 ("cenatls.cena.dgac.fr" "ftp.cenatls.cena.dgac.fr" "pub/Emacs/xemacs/packages")
197 ("kfki.hu" "ftp.kfki.hu" "pub/packages/xemacs/packages")
198 ("uniroma2.it" "ftp.uniroma2.it" "unix/misc/dist/XEMACS/packages")
199 ("icm.edu.pl" "ftp.icm.edu.pl" "pub/unix/editors/xemacs/packages")
200 ("sunet.se" "ftp.sunet.se" "pub/gnu/xemacs/packages")
201 ("doc.ic.ac.uk" "ftp.doc.ic.ac.uk" "packages/xemacs/packages")
202 ("srcc.msu.su" "ftp1.srcc.msu.su" "mirror/ftp.xemacs.org/packages")
203
204 ;; Asia
205 ("usyd.edu.au" "ftp.usyd.edu.au" "pub/Xemacs/packages")
206 ("netlab.is.tsukuba.ac.jp" "ftp.netlab.is.tsukuba.ac.jp" "pub/GNU/xemacs/packages")
207 ("jaist.ac.jp" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages")
208 ("ring.aist.go.jp" "ring.aist.go.jp" "pub/text/xemacs/packages")
209 ("ring.asahi-net.or.jp" "ring.asahi-net.or.jp" "pub/text/xemacs/packages")
210 ("SunSITE.sut.ac.jp" "SunSITE.sut.ac.jp" "pub/archives/packages/xemacs/packages")
211 ("dti.ad.jp" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages")
212 ("kreonet.re.kr" "ftp.kreonet.re.kr" "pub/tools/emacs/xemacs/packages")
213 )
214 "*List of remote sites available for downloading packages.
215 List format is '(site-description site-name directory-on-site).
216 SITE-DESCRIPTION is a textual description of the site. SITE-NAME
217 is the internet address of the download site. DIRECTORY-ON-SITE
218 is the directory on the site in which packages may be found.
219 This variable is used to initialize `package-get-remote', the
220 variable actually used to specify package download sites."
221 :tag "Package download sites"
222 :type '(repeat (list hostname directory))
223 :group 'package-get)
224
225 (defcustom package-get-remove-copy t
176 "*After copying and installing a package, if this is T, then remove the 226 "*After copying and installing a package, if this is T, then remove the
177 copy. Otherwise, keep it around." 227 copy. Otherwise, keep it around."
178 :type 'boolean 228 :type 'boolean
179 :group 'package-get) 229 :group 'package-get)
180 230
181 (defcustom package-get-base-filename 231 ;; #### it may make sense for this to be a list of names.
182 "/ftp.xemacs.org:/pub/xemacs/packages/package-index.LATEST" 232 ;; #### also, should we rename "*base*" to "*index*" or "*db*"?
183 "*Name of the default package database file, usually on ftp.xemacs.org." 233 ;; "base" is a pretty poor name.
234 (defcustom package-get-base-filename "package-index.LATEST.pgp"
235 "*Name of the default package-get database file.
236 This may either be a relative path, in which case it is interpreted
237 with respect to `package-get-remote', or an absolute path."
184 :type 'file 238 :type 'file
185 :group 'package-get) 239 :group 'package-get)
186 240
187 ;;;###autoload 241 (defcustom package-get-always-update nil
188 (defun package-get-require-base () 242 "*If Non-nil always make sure we are using the latest package index (base).
189 "Require that a package-get database has been loaded." 243 Otherwise respect the `force-current' argument of `package-get-require-base'."
190 (when (or (not (boundp 'package-get-base)) 244 :type 'boolean
191 (not package-get-base)) 245 :group 'package-get)
192 (package-get-update-base)) 246
193 (when (or (not (boundp 'package-get-base)) 247 (defcustom package-get-require-signed-base-updates t
194 (not package-get-base)) 248 "*If set to a non-nil value, require explicit user confirmation for updates
195 (error "Package-get database not loaded"))) 249 to the package-get database which cannot have their signature verified via PGP.
250 When nil, updates which are not PGP signed are allowed without confirmation."
251 :type 'boolean
252 :group 'package-get)
253
254 (defvar package-get-was-current nil
255 "Non-nil we did our best to fetch a current database.")
256
257 ;;;###autoload
258 (defun package-get-download-menu ()
259 "Build the `Add Download Site' menu."
260 (mapcar (lambda (site)
261 (vector (car site)
262 `(push (quote ,(cdr site))
263 package-get-remote)))
264 package-get-download-sites))
265
266 ;;;###autoload
267 (defun package-get-require-base (&optional force-current)
268 "Require that a package-get database has been loaded.
269 If the optional FORCE-CURRENT argument or the value of
270 `package-get-always-update' is Non-nil, try to update the database
271 from a location in `package-get-remote'. Otherwise a local copy is used
272 if available and remote access is never done.
273
274 Please use FORCE-CURRENT only when the user is explictly dealing with packages
275 and remote access is likely in the near future."
276 (setq force-current (or force-current package-get-always-update))
277 (unless (and (boundp 'package-get-base)
278 package-get-base
279 (or (not force-current) package-get-was-current))
280 (package-get-update-base nil force-current))
281 (if (or (not (boundp 'package-get-base))
282 (not package-get-base))
283 (error "Package-get database not loaded")
284 (setq package-get-was-current force-current)))
196 285
197 (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----" 286 (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----"
198 "Text for start of PGP signed messages.") 287 "Text for start of PGP signed messages.")
199 (defconst package-get-pgp-signature-begin-line "^-----BEGIN PGP SIGNATURE-----" 288 (defconst package-get-pgp-signature-begin-line "^-----BEGIN PGP SIGNATURE-----"
200 "Text for beginning of PGP signature.") 289 "Text for beginning of PGP signature.")
202 "Text for end of PGP signature.") 291 "Text for end of PGP signature.")
203 292
204 ;;;###autoload 293 ;;;###autoload
205 (defun package-get-update-base-entry (entry) 294 (defun package-get-update-base-entry (entry)
206 "Update an entry in `package-get-base'." 295 "Update an entry in `package-get-base'."
207 (let ((existing (assoc (car entry) package-get-base))) 296 (let ((existing (assq (car entry) package-get-base)))
208 (if existing 297 (if existing
209 (setcdr existing (cdr entry)) 298 (setcdr existing (cdr entry))
210 (setq package-get-base (cons entry package-get-base))))) 299 (setq package-get-base (cons entry package-get-base))
211 300 (package-get-custom-add-entry (car entry) (car (cdr entry))))))
212 ;;;###autoload 301
213 (defun package-get-update-base (&optional db-file) 302 (defun package-get-locate-file (file &optional nil-if-not-found no-remote)
214 "Update the package-get database file with entries from DB-FILE." 303 "Locate an existing FILE with respect to `package-get-remote'.
215 (interactive (list 304 If FILE is an absolute path or is not found, simply return FILE.
216 (read-file-name "Load package-get database: " 305 If optional argument NIL-IF-NOT-FOUND is non-nil, return nil
217 (file-name-directory package-get-base-filename) 306 if FILE can not be located.
218 package-get-base-filename 307 If NO-REMOTE is non-nil never search remote locations."
219 t 308 (if (file-name-absolute-p file)
220 (file-name-nondirectory package-get-base-filename)))) 309 file
221 (setq db-file (expand-file-name (or db-file package-get-base-filename))) 310 (let ((entries package-get-remote)
311 (expanded nil))
312 (while entries
313 (unless (and no-remote (caar entries))
314 (let ((expn (package-get-remote-filename (car entries) file)))
315 (if (and expn (file-exists-p expn))
316 (setq entries nil
317 expanded expn))))
318 (setq entries (cdr entries)))
319 (or expanded
320 (and (not nil-if-not-found)
321 file)))))
322
323 (defun package-get-locate-index-file (no-remote)
324 "Locate the package-get index file. Do not return remote paths if NO-REMOTE
325 is non-nil."
326 (or (package-get-locate-file package-get-base-filename t no-remote)
327 (locate-data-file package-get-base-filename)
328 package-get-base-filename))
329
330 (defvar package-get-user-package-location user-init-directory)
331
332 (defun package-get-maybe-save-index (filename)
333 "Offer to save the current buffer as the local package index file,
334 if different."
335 (let ((location (package-get-locate-index-file t)))
336 (unless (and filename (equal filename location))
337 (unless (equal (md5 (current-buffer))
338 (with-temp-buffer
339 (insert-file-contents location)
340 (md5 (current-buffer))))
341 (unless (file-writable-p location)
342 (setq location (expand-file-name package-get-base-filename
343 (expand-file-name "etc/" package-get-user-package-location))))
344 (when (y-or-n-p (concat "Update package index in" location "? "))
345 (write-file location))))))
346
347
348 ;;;###autoload
349 (defun package-get-update-base (&optional db-file force-current)
350 "Update the package-get database file with entries from DB-FILE.
351 Unless FORCE-CURRENT is non-nil never try to update the database."
352 (interactive
353 (let ((dflt (package-get-locate-index-file nil)))
354 (list (read-file-name "Load package-get database: "
355 (file-name-directory dflt)
356 dflt
357 t
358 (file-name-nondirectory dflt)))))
359 (setq db-file (expand-file-name (or db-file
360 (package-get-locate-index-file
361 (not force-current)))))
222 (if (not (file-exists-p db-file)) 362 (if (not (file-exists-p db-file))
223 (error "Package-get database file `%s' does not exist" db-file)) 363 (error "Package-get database file `%s' does not exist" db-file))
224 (if (not (file-readable-p db-file)) 364 (if (not (file-readable-p db-file))
225 (error "Package-get database file `%s' not readable" db-file)) 365 (error "Package-get database file `%s' not readable" db-file))
226 (let ((buf (get-buffer-create "*package database*"))) 366 (let ((buf (get-buffer-create "*package database*")))
227 (unwind-protect 367 (unwind-protect
228 (save-excursion 368 (save-excursion
229 (set-buffer buf) 369 (set-buffer buf)
230 (erase-buffer buf) 370 (erase-buffer buf)
231 (insert-file-contents-internal db-file) 371 (insert-file-contents-internal db-file)
232 (package-get-update-base-from-buffer buf)) 372 (package-get-update-base-from-buffer buf)
373 (if (file-remote-p db-file)
374 (package-get-maybe-save-index db-file)))
233 (kill-buffer buf)))) 375 (kill-buffer buf))))
234 376
235 ;;;###autoload 377 ;;;###autoload
236 (defun package-get-update-base-from-buffer (&optional buf) 378 (defun package-get-update-base-from-buffer (&optional buf)
237 "Update the package-get database with entries from BUFFER. 379 "Update the package-get database with entries from BUFFER.
251 (when (re-search-forward package-get-pgp-signature-begin-line nil t) 393 (when (re-search-forward package-get-pgp-signature-begin-line nil t)
252 (setq content-end (match-beginning 0))) 394 (setq content-end (match-beginning 0)))
253 (when (re-search-forward package-get-pgp-signature-end-line nil t) 395 (when (re-search-forward package-get-pgp-signature-end-line nil t)
254 (setq end (point))) 396 (setq end (point)))
255 (if (not (and content-beg content-end beg end)) 397 (if (not (and content-beg content-end beg end))
256 (or (yes-or-no-p "Package-get entries not PGP signed, continue? ") 398 (or (not package-get-require-signed-base-updates)
399 (yes-or-no-p "Package-get entries not PGP signed, continue? ")
257 (error "Package-get database not updated"))) 400 (error "Package-get database not updated")))
258 (if (and content-beg content-end beg end) 401 (if (and content-beg content-end beg end)
259 (if (not (condition-case nil 402 (if (not (condition-case nil
260 (or (fboundp 'mc-pgp-verify-region) 403 (or (fboundp 'mc-pgp-verify-region)
261 (load-library "mc-pgp") 404 (load-library "mc-pgp")
262 (fboundp 'mc-pgp-verify-region)) 405 (fboundp 'mc-pgp-verify-region))
263 (error nil))) 406 (error nil)))
264 (or (yes-or-no-p 407 (or (not package-get-require-signed-base-updates)
408 (yes-or-no-p
265 "No mailcrypt; can't verify package-get DB signature, continue? ") 409 "No mailcrypt; can't verify package-get DB signature, continue? ")
266 (error "Package-get database not updated")))) 410 (error "Package-get database not updated"))))
267 (if (and beg end 411 (if (and beg end
268 (fboundp 'mc-pgp-verify-region) 412 (fboundp 'mc-pgp-verify-region)
269 (or (not 413 (or (not
270 (condition-case err 414 (condition-case err
271 (mc-pgp-verify-region beg end) 415 (mc-pgp-verify-region beg end)
272 (file-error 416 (file-error
273 (and (string-match "No such file" (nth 2 err)) 417 (and (string-match "No such file" (nth 2 err))
274 (yes-or-no-p 418 (or (not package-get-require-signed-base-updates)
275 "Can't find PGP, continue without package-get DB verification? "))) 419 (yes-or-no-p
420 (concat "Can't find PGP, continue without "
421 "package-get DB verification? ")))))
276 (t nil))))) 422 (t nil)))))
277 (error "Package-get PGP signature failed to verify")) 423 (error "Package-get PGP signature failed to verify"))
424 ;; ToDo: We shoud call package-get-maybe-save-index on the region
278 (package-get-update-base-entries content-beg content-end) 425 (package-get-update-base-entries content-beg content-end)
279 (message "Updated package-get database")))) 426 (message "Updated package-get database"))))
280 427
281 (defun package-get-update-base-entries (beg end) 428 (defun package-get-update-base-entries (beg end)
282 "Update the package-get database with the entries found between 429 "Update the package-get database with the entries found between
297 (package-get-update-base-entry 444 (package-get-update-base-entry
298 (car (cdr (car (cdr entry))))) 445 (car (cdr (car (cdr entry)))))
299 (setq count (1+ count)))) 446 (setq count (1+ count))))
300 (message "Got %d package-get database entries" count)))) 447 (message "Got %d package-get database entries" count))))
301 448
449 ;;;###autoload
450 (defun package-get-save-base (file)
451 "Write the package-get database to FILE.
452
453 Note: This database will be unsigned of course."
454 (interactive "FSave package-get database to: ")
455 (package-get-require-base t)
456 (let ((buf (get-buffer-create "*package database*")))
457 (unwind-protect
458 (save-excursion
459 (set-buffer buf)
460 (erase-buffer buf)
461 (goto-char (point-min))
462 (let ((entries package-get-base) entry plist)
463 (insert ";; Package Index file -- Do not edit manually.\n")
464 (insert ";;;@@@\n")
465 (while entries
466 (setq entry (car entries))
467 (setq plist (car (cdr entry)))
468 (insert "(package-get-update-base-entry (quote\n")
469 (insert (format "(%s\n" (symbol-name (car entry))))
470 (while plist
471 (insert (format " %s%s %S\n"
472 (if (eq plist (car (cdr entry))) "(" " ")
473 (symbol-name (car plist))
474 (car (cdr plist))))
475 (setq plist (cdr (cdr plist))))
476 (insert "))\n))\n;;;@@@\n")
477 (setq entries (cdr entries))))
478 (insert ";; Package Index file ends here\n")
479 (write-region (point-min) (point-max) file))
480 (kill-buffer buf))))
481
302 (defun package-get-interactive-package-query (get-version package-symbol) 482 (defun package-get-interactive-package-query (get-version package-symbol)
303 "Perform interactive querying for package and optional version. 483 "Perform interactive querying for package and optional version.
304 Query for a version if GET-VERSION is non-nil. Return package name as 484 Query for a version if GET-VERSION is non-nil. Return package name as
305 a symbol instead of a string if PACKAGE-SYMBOL is non-nil. 485 a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
306 The return value is suitable for direct passing to `interactive'." 486 The return value is suitable for direct passing to `interactive'."
307 (package-get-require-base) 487 (package-get-require-base t)
308 (let ( (table (mapcar '(lambda (item) 488 (let ( (table (mapcar '(lambda (item)
309 (let ( (name (symbol-name (car item))) ) 489 (let ( (name (symbol-name (car item))) )
310 (cons name name) 490 (cons name name)
311 )) 491 ))
312 package-get-base)) 492 package-get-base))
345 525
346 ;;;###autoload 526 ;;;###autoload
347 (defun package-get-update-all () 527 (defun package-get-update-all ()
348 "Fetch and install the latest versions of all currently installed packages." 528 "Fetch and install the latest versions of all currently installed packages."
349 (interactive) 529 (interactive)
350 (package-get-require-base) 530 (package-get-require-base t)
351 ;; Load a fresh copy 531 ;; Load a fresh copy
352 (catch 'exit 532 (catch 'exit
353 (mapcar (lambda (pkg) 533 (mapcar (lambda (pkg)
354 (if (not (package-get (car pkg) nil 'never)) 534 (if (not (package-get (car pkg) nil 'never))
355 (throw 'exit nil) ;; Bail out if error detected 535 (throw 'exit nil) ;; Bail out if error detected
390 ;; in `fetched-packages' the list of things provided -- this 570 ;; in `fetched-packages' the list of things provided -- this
391 ;; keeps us from going into a loop 571 ;; keeps us from going into a loop
392 (while this-requires 572 (while this-requires
393 (if (not (member (car this-requires) fetched-packages)) 573 (if (not (member (car this-requires) fetched-packages))
394 (let* ((reqd-package (package-get-package-provider 574 (let* ((reqd-package (package-get-package-provider
395 (car this-requires))) 575 (car this-requires) t))
396 (reqd-version (cadr reqd-package)) 576 (reqd-version (cadr reqd-package))
397 (reqd-name (car reqd-package))) 577 (reqd-name (car reqd-package)))
398 (if (null reqd-name) 578 (if (null reqd-name)
399 (error "Unable to find a provider for %s" 579 (error "Unable to find a provider for %s"
400 (car this-requires))) 580 (car this-requires)))
413 (defun package-get-dependencies (packages) 593 (defun package-get-dependencies (packages)
414 "Compute dependencies for PACKAGES. 594 "Compute dependencies for PACKAGES.
415 Uses `package-get-base' to determine just what is required and what 595 Uses `package-get-base' to determine just what is required and what
416 package provides that functionality. Returns the list of packages 596 package provides that functionality. Returns the list of packages
417 required by PACKAGES." 597 required by PACKAGES."
418 (package-get-require-base) 598 (package-get-require-base t)
419 (let ((orig-packages packages) 599 (let ((orig-packages packages)
420 dependencies provided) 600 dependencies provided)
421 (while packages 601 (while packages
422 (let* ((package (car packages)) 602 (let* ((package (car packages))
423 (the-package (package-get-info-find-package 603 (the-package (package-get-info-find-package
507 687
508 Returns `t' upon success, the symbol `error' if the package was 688 Returns `t' upon success, the symbol `error' if the package was
509 successfully installed but errors occurred during initialization, or 689 successfully installed but errors occurred during initialization, or
510 `nil' upon error." 690 `nil' upon error."
511 (interactive (package-get-interactive-package-query nil t)) 691 (interactive (package-get-interactive-package-query nil t))
692 (catch 'skip-update
512 (let* ((this-package 693 (let* ((this-package
513 (package-get-info-version 694 (package-get-info-version
514 (package-get-info-find-package package-get-base 695 (package-get-info-find-package package-get-base
515 package) version)) 696 package) version))
697 (latest (package-get-info-prop this-package 'version))
698 (installed (package-get-key package :version))
516 (this-requires (package-get-info-prop this-package 'requires)) 699 (this-requires (package-get-info-prop this-package 'requires))
517 (found nil) 700 (found nil)
518 (search-dirs package-get-remote) 701 (search-dirs package-get-remote)
519 (base-filename (package-get-info-prop this-package 'filename)) 702 (base-filename (package-get-info-prop this-package 'filename))
520 (package-status t) 703 (package-status t)
527 package version)) 710 package version))
528 (setq install-dir 711 (setq install-dir
529 (package-admin-get-install-dir package install-dir 712 (package-admin-get-install-dir package install-dir
530 (or (eq package 'mule-base) (memq 'mule-base this-requires)))) 713 (or (eq package 'mule-base) (memq 'mule-base this-requires))))
531 714
715 ;; If they asked for the latest using version=nil, don't get an older
716 ;; version than we already have.
717 (if installed
718 (if (> (if (stringp installed)
719 (string-to-number installed)
720 installed)
721 (if (stringp latest)
722 (string-to-number latest)
723 latest))
724 (if (not (null version))
725 (warn "Installing %s package version %s, you had a newer version %s"
726 package latest installed)
727 (warn "Skipping %s package, you have a newer version %s"
728 package installed)
729 (throw 'skip-update t))))
730
532 ;; Contrive a list of possible package filenames. 731 ;; Contrive a list of possible package filenames.
533 ;; Ugly. Is there a better way to do this? 732 ;; Ugly. Is there a better way to do this?
534 (setq filenames (cons base-filename nil)) 733 (setq filenames (cons base-filename nil))
535 (if (string-match "^\\(..*\\)\.tar\.gz$" base-filename) 734 (if (string-match "^\\(..*\\)\.tar\.gz$" base-filename)
536 (setq filenames (append filenames 735 (setq filenames (append filenames
537 (list (concat (match-string 1 base-filename) 736 (list (concat (match-string 1 base-filename)
538 ".tgz"))))) 737 ".tgz")))))
539 738
540 (setq version (package-get-info-prop this-package 'version)) 739 (setq version latest)
541 (unless (and (eq conflict 'never) 740 (unless (and (eq conflict 'never)
542 (package-get-installedp package version)) 741 (package-get-installedp package version))
543 ;; Find the package from the search list in package-get-remote 742 ;; Find the package from the search list in package-get-remote
544 ;; and copy it into the staging directory. Then validate 743 ;; and copy it into the staging directory. Then validate
545 ;; the checksum. Finally, install the package. 744 ;; the checksum. Finally, install the package.
655 )) 854 ))
656 (setq found t)) 855 (setq found t))
657 (if (and found package-get-remove-copy) 856 (if (and found package-get-remove-copy)
658 (delete-file full-package-filename)) 857 (delete-file full-package-filename))
659 package-status 858 package-status
660 )) 859 )))
661 860
662 (defun package-get-info-find-package (which name) 861 (defun package-get-info-find-package (which name)
663 "Look in WHICH for the package called NAME and return all the info 862 "Look in WHICH for the package called NAME and return all the info
664 associated with it. See `package-get-base' for info on the format 863 associated with it. See `package-get-base' for info on the format
665 returned. 864 returned.
756 (package-get-info-find-package packages-package-list 955 (package-get-info-find-package packages-package-list
757 package) ':version) 956 package) ':version)
758 (if (floatp version) version (string-to-number version)))) 957 (if (floatp version) version (string-to-number version))))
759 958
760 ;;;###autoload 959 ;;;###autoload
761 (defun package-get-package-provider (sym) 960 (defun package-get-package-provider (sym &optional force-current)
762 "Search for a package that provides SYM and return the name and 961 "Search for a package that provides SYM and return the name and
763 version. Searches in `package-get-base' for SYM. If SYM is a 962 version. Searches in `package-get-base' for SYM. If SYM is a
764 consp, then it must match a corresponding (provide (SYM VERSION)) from 963 consp, then it must match a corresponding (provide (SYM VERSION)) from
765 the package." 964 the package.
965
966 If FORCE-CURRENT is non-nil make sure the database is up to date. This might
967 lead to Emacs accessing remote sites."
766 (interactive "SSymbol: ") 968 (interactive "SSymbol: ")
767 (package-get-require-base) 969 (package-get-require-base force-current)
768 (let ((packages package-get-base) 970 (let ((packages package-get-base)
769 (done nil) 971 (done nil)
770 (found nil)) 972 (found nil))
771 (while (and (not done) packages) 973 (while (and (not done) packages)
772 (let* ((this-name (caar packages)) 974 (let* ((this-name (caar packages))
773 (this-package (cdr (car packages)))) ;strip off package name 975 (this-package (cdr (car packages)))) ;strip off package name
774 (while (and (not done) this-package) 976 (while (and (not done) this-package)
775 (if (or (eq this-name sym) 977 (if (or (eq this-name sym)
776 (eq (cons this-name 978 (eq (cons this-name
777 (package-get-info-prop (car this-package) 'version)) 979 (package-get-info-prop (car this-package) 'version))
778 sym) 980 sym)
779 (member sym (package-get-info-prop (car this-package) 'provides))) 981 (member sym
982 (package-get-info-prop (car this-package) 'provides)))
780 (progn (setq done t) 983 (progn (setq done t)
781 (setq found (list (caar packages) 984 (setq found
782 (package-get-info-prop (car this-package) 'version)))) 985 (list (caar packages)
986 (package-get-info-prop (car this-package) 'version))))
783 (setq this-package (cdr this-package))))) 987 (setq this-package (cdr this-package)))))
784 (setq packages (cdr packages))) 988 (setq packages (cdr packages)))
785 found)) 989 found))
786 990
787 ;; 991 ;;
794 998
795 ;;;###autoload 999 ;;;###autoload
796 (defun package-get-custom () 1000 (defun package-get-custom ()
797 "Fetch and install the latest versions of all customized packages." 1001 "Fetch and install the latest versions of all customized packages."
798 (interactive) 1002 (interactive)
799 (package-get-require-base) 1003 (package-get-require-base t)
800 ;; Load a fresh copy 1004 ;; Load a fresh copy
801 (load "package-get-custom.el") 1005 (load "package-get-custom.el")
802 (mapcar (lambda (pkg) 1006 (mapcar (lambda (pkg)
803 (if (eval (intern (concat (symbol-name (car pkg)) "-package"))) 1007 (if (eval (intern (concat (symbol-name (car pkg)) "-package")))
804 (package-get-all (car pkg) nil)) 1008 (package-get (car pkg) nil))
805 t) 1009 t)
806 package-get-base)) 1010 package-get-base))
807 1011
808 (defun package-get-ever-installed-p (pkg &optional notused) 1012 (defun package-get-ever-installed-p (pkg &optional notused)
809 (string-match "-package$" (symbol-name pkg)) 1013 (string-match "-package$" (symbol-name pkg))
812 (if (package-get-info-find-package 1016 (if (package-get-info-find-package
813 packages-package-list 1017 packages-package-list
814 (intern (substring (symbol-name pkg) 0 (match-beginning 0)))) 1018 (intern (substring (symbol-name pkg) 0 (match-beginning 0))))
815 t))) 1019 t)))
816 1020
817 (defun package-get-file-installed-p (file &optional paths) 1021 (defvar package-get-custom-groups nil
818 "Return absolute-path of FILE if FILE exists in PATHS. 1022 "List of package-get-custom groups")
819 If PATHS is omitted, `load-path' is used." 1023
820 (if (null paths) 1024 (defun package-get-custom-add-entry (package props)
821 (setq paths load-path) 1025 (let* ((category (plist-get props 'category))
822 ) 1026 (group (intern (concat category "-packages")))
823 (catch 'tag 1027 (custom-var (intern (concat (symbol-name package) "-package")))
824 (let (path) 1028 (description (plist-get props 'description)))
825 (while paths 1029 (when (not (memq group package-get-custom-groups))
826 (setq path (expand-file-name file (car paths))) 1030 (setq package-get-custom-groups (cons package
827 (if (file-exists-p path) 1031 package-get-custom-groups))
828 (throw 'tag path) 1032 (eval `(defgroup ,group nil
829 ) 1033 ,(concat category " package group")
830 (setq paths (cdr paths)) 1034 :group 'packages)))
831 )))) 1035 (eval `(defcustom ,custom-var nil
832 1036 ,description
833 (defun package-get-create-custom () 1037 :group ',group
834 "Creates a package customization file package-get-custom.el. 1038 :initialize 'package-get-ever-installed-p
835 Entries in the customization file are retrieved from package-get-base.el." 1039 :type 'boolean))))
836 (interactive) 1040
837 ;; Load a fresh copy 1041
838 (let ((custom-buffer (find-file-noselect
839 (or (package-get-file-installed-p
840 "package-get-custom.el")
841 (expand-file-name
842 "package-get-custom.el"
843 (file-name-directory
844 (package-get-file-installed-p
845 "package-get-base.el"))
846 ))))
847 (pkg-groups nil))
848
849 ;; clear existing stuff
850 (delete-region (point-min custom-buffer)
851 (point-max custom-buffer) custom-buffer)
852 (insert-string "(require 'package-get)\n" custom-buffer)
853
854 (mapcar (lambda (pkg)
855 (let ((category (plist-get (car (cdr pkg)) 'category)))
856 (or (memq (intern category) pkg-groups)
857 (progn
858 (setq pkg-groups (cons (intern category) pkg-groups))
859 (insert-string
860 (concat "(defgroup " category "-packages nil\n"
861 " \"" category " package group\"\n"
862 " :group 'packages)\n\n") custom-buffer)))
863
864 (insert-string
865 (concat "(defcustom " (symbol-name (car pkg))
866 "-package nil \n"
867 " \"" (plist-get (car (cdr pkg)) 'description) "\"\n"
868 " :group '" category "-packages\n"
869 " :initialize 'package-get-ever-installed-p\n"
870 " :type 'boolean)\n\n") custom-buffer)))
871 package-get-base) custom-buffer)
872 )
873
874 ;; need this first to avoid infinite dependency loops
875 (provide 'package-get) 1042 (provide 'package-get)
876
877 ;; potentially update the custom dependencies every time we load this
878 (when nil ;; #### disable for now... -gk
879 (unless noninteractive
880 (let ((custom-file (package-get-file-installed-p "package-get-custom.el"))
881 (package-file (package-get-file-installed-p "package-get-base.el")))
882 ;; update custom file if it doesn't exist
883 (if (or (not custom-file)
884 (and (< (car (nth 5 (file-attributes custom-file)))
885 (car (nth 5 (file-attributes package-file))))
886 (< (car (nth 5 (file-attributes custom-file)))
887 (car (nth 5 (file-attributes package-file))))))
888 (save-excursion
889 (message "generating package customizations...")
890 (set-buffer (package-get-create-custom))
891 (save-buffer)
892 (message "generating package customizations...done")))
893 (load "package-get-custom.el")))
894 )
895
896 ;;; package-get.el ends here 1043 ;;; package-get.el ends here