Mercurial > hg > xemacs-beta
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 |