Mercurial > hg > xemacs-beta

comparison lisp/package-get.el @ 1410:44de306310b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-04-14 03:40:26 by youngs] 2003-04-14 Steve Youngs <youngs@xemacs.org> * package-admin.el (package-admin-find-top-directory): Use 'directory-sep-char'. (package-admin-get-install-dir): Ditto. This is so PUI won't break on platforms that don't use '/' as the directory separator. * package-get.el (package-get-pgp-available-p): New. (package-get-require-signed-base-updates): Use it. (package-get-update-base-from-buffer): Move the code that finds the gpg stuff into `package-get-pgp-available-p'. Now if you have Mailcrypt and a PGP binary installed and set up on your system, PUI will automatically default to doing PGP verification, otherwise it'll default to off. (package-get-require-base): Use the DATUM arg to `error'. (package-get-locate-index-file): Ditto. (package-get-update-base): Ditto. (package-get-update-base-entries): Ditto. (package-get-all): Ditto. (package-get-dependencies): Ditto. (package-get-info): Ditto. (package-get): Ditto. * package-info.el (batch-update-package-info): Use the DATUM arg to `error'. * package-net.el (package-net-batch-generate-bin-ini): Use the DATUM arg to `error'. * package-ui.el (pui-toggle-package-key): Use the DATUM arg to `error'. (pui-toggle-package-delete-key): Ditto. (pui-install-selected-packages): Ditto. (pui-add-required-packages): Ditto. (pui-display-info): Ditto. (list-packages-mode): Ditto. * packages.el (package-require): Use the DATUM arg to `error'.
author youngs
date Mon, 14 Apr 2003 03:40:27 +0000
parents 69a674f5861f
children dea9705187d3
comparison
equal deleted inserted replaced
1409:d9b958c0f772 1410:44de306310b8
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 ;; Copyright (C) 2002 Ben Wing. 4 ;; Copyright (C) 2002 Ben Wing.
5 ;; Copyright (C) 2003, Steve Youngs
5 6
6 ;; Author: Pete Ware <ware@cis.ohio-state.edu> 7 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
7 ;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com> 8 ;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com>
8 ;; Jan Vroonhof <vroonhof@math.ethz.ch> 9 ;; Jan Vroonhof <vroonhof@math.ethz.ch>
10 ;; Steve Youngs <youngs@xemacs.org>
9 ;; Keywords: internal 11 ;; Keywords: internal
10 12
11 ;; This file is part of XEmacs. 13 ;; This file is part of XEmacs.
12 14
13 ;; XEmacs is free software; you can redistribute it and/or modify it 15 ;; XEmacs is free software; you can redistribute it and/or modify it
378 "*If Non-nil always make sure we are using the latest package index (base). 380 "*If Non-nil always make sure we are using the latest package index (base).
379 Otherwise respect the `force-current' argument of `package-get-require-base'." 381 Otherwise respect the `force-current' argument of `package-get-require-base'."
380 :type 'boolean 382 :type 'boolean
381 :group 'package-get) 383 :group 'package-get)
382 384
383 (defcustom package-get-require-signed-base-updates t 385 (defun package-get-pgp-available-p ()
384 "*If set to a non-nil value, require explicit user confirmation for updates 386 "Checks the availability of Mailcrypt and PGP executable.
385 to the package-get database which cannot have their signature verified via PGP. 387
386 When nil, no PGP verification will be done." 388 Returns t if both are found, nil otherwise. As a side effect, set
389 `mc-default-scheme' dependent on the PGP executable found."
390 (let (result)
391 (when (featurep 'mailcrypt-autoloads)
392 (autoload 'mc-setversion "mc-setversion"))
393 (when-fboundp 'mc-setversion
394 (cond ((locate-file "gpg" exec-path
395 '("" ".btm" ".bat" ".cmd" ".exe" ".com")
396 'executable)
397 (mc-setversion "gpg")
398 (setq result t))
399 ((locate-file "pgpe" exec-path
400 '("" ".btm" ".bat" ".cmd" ".exe" ".com")
401 'executable)
402 (mc-setversion "5.0")
403 (setq result t))
404 ((locate-file "pgp" exec-path
405 '("" ".btm" ".bat" ".cmd" ".exe" ".com")
406 'executable)
407 (mc-setversion "2.6")
408 (setq result t))))
409 (if result
410 result
411 nil)))
412
413 (defcustom package-get-require-signed-base-updates (package-get-pgp-available-p)
414 "*If non-nil, try to verify the package index database via PGP.
415
416 If nil, no PGP verification is done. If the package index database
417 entries are not PGP signed and this variable is non-nil, require user
418 confirmation to continue with the package-get procedure.
419
420 The default for this variable is the return value of
421 `package-get-pgp-available-p', non-nil if both the \"Mailcrypt\"
422 package and a suitable PGP executable are available, nil otherwise."
387 :type 'boolean 423 :type 'boolean
388 :group 'package-get) 424 :group 'package-get)
389 425
390 (defvar package-entries-are-signed nil 426 (defvar package-entries-are-signed nil
391 "Non-nil when the package index file has been PGP signed.") 427 "Non-nil when the package index file has been PGP signed.")
411 package-get-base 447 package-get-base
412 (or (not force-current) package-get-was-current)) 448 (or (not force-current) package-get-was-current))
413 (package-get-update-base nil force-current)) 449 (package-get-update-base nil force-current))
414 (if (or (not (boundp 'package-get-base)) 450 (if (or (not (boundp 'package-get-base))
415 (not package-get-base)) 451 (not package-get-base))
416 (error "Package-get database not loaded") 452 (error 'void-variable
453 "Package-get database not loaded")
417 (setq package-get-was-current force-current))) 454 (setq package-get-was-current force-current)))
418 455
419 (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----" 456 (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----"
420 "Text for start of PGP signed messages.") 457 "Text for start of PGP signed messages.")
421 (defconst package-get-pgp-signature-begin-line "^-----BEGIN PGP SIGNATURE-----" 458 (defconst package-get-pgp-signature-begin-line "^-----BEGIN PGP SIGNATURE-----"
456 is non-nil." 493 is non-nil."
457 (or (package-get-locate-file package-get-base-filename t no-remote) 494 (or (package-get-locate-file package-get-base-filename t no-remote)
458 (if (file-exists-p package-get-user-index-filename) 495 (if (file-exists-p package-get-user-index-filename)
459 package-get-user-index-filename) 496 package-get-user-index-filename)
460 (locate-data-file package-get-base-filename) 497 (locate-data-file package-get-base-filename)
461 (error "Can't locate a package index file."))) 498 (error 'search-failed
499 "Can't locate a package index file.")))
462 500
463 (defun package-get-maybe-save-index (filename) 501 (defun package-get-maybe-save-index (filename)
464 "Offer to save the current buffer as the local package index file, 502 "Offer to save the current buffer as the local package index file,
465 if different." 503 if different."
466 (let ((location (package-get-locate-index-file t))) 504 (let ((location (package-get-locate-index-file t)))
489 (file-name-nondirectory dflt))))) 527 (file-name-nondirectory dflt)))))
490 (setq db-file (expand-file-name (or db-file 528 (setq db-file (expand-file-name (or db-file
491 (package-get-locate-index-file 529 (package-get-locate-index-file
492 (not force-current))))) 530 (not force-current)))))
493 (if (not (file-exists-p db-file)) 531 (if (not (file-exists-p db-file))
494 (error "Package-get database file `%s' does not exist" db-file)) 532 (error 'file-error
533 (format "Package-get database file `%s' does not exist" db-file)))
495 (if (not (file-readable-p db-file)) 534 (if (not (file-readable-p db-file))
496 (error "Package-get database file `%s' not readable" db-file)) 535 (error 'file-error
536 (format "Package-get database file `%s' not readable" db-file)))
497 (let ((buf (get-buffer-create "*package database*"))) 537 (let ((buf (get-buffer-create "*package database*")))
498 (unwind-protect 538 (unwind-protect
499 (save-excursion 539 (save-excursion
500 (set-buffer buf) 540 (set-buffer buf)
501 (erase-buffer buf) 541 (erase-buffer buf)
523 (when (re-search-forward package-get-pgp-signature-begin-line nil t) 563 (when (re-search-forward package-get-pgp-signature-begin-line nil t)
524 (setq content-end (match-beginning 0)) 564 (setq content-end (match-beginning 0))
525 (setq package-entries-are-signed t)) 565 (setq package-entries-are-signed t))
526 (re-search-forward package-get-pgp-signature-end-line nil t) 566 (re-search-forward package-get-pgp-signature-end-line nil t)
527 (setq package-get-continue-update-base t) 567 (setq package-get-continue-update-base t)
528 (if package-get-require-signed-base-updates 568 ;; This is a little overkill because the default value of
529 (if package-entries-are-signed 569 ;; `package-get-require-signed-base-updates' is the return of
530 (if (featurep 'mailcrypt-autoloads) 570 ;; `package-get-pgp-available-p', but we have to allow for
531 (progn 571 ;; someone explicitly setting
532 (setq package-get-continue-update-base nil) 572 ;; `package-get-require-signed-base-updates' to t. --SY
533 (autoload 'mc-setversion "mc-setversion") 573 (when (and package-get-require-signed-base-updates
534 (with-fboundp 'mc-setversion 574 (package-get-pgp-available-p))
535 (cond ((locate-file "gpg" exec-path 575 (if package-entries-are-signed
536 '("" ".btm" ".bat" ".cmd" ".exe" 576 (let (good-sig)
537 ".com") 'executable)
538 (mc-setversion "gpg"))
539 ((locate-file "pgpe" exec-path
540 '("" ".btm" ".bat" ".cmd" ".exe"
541 ".com") 'executable)
542 (mc-setversion "5.0"))
543 ((locate-file "pgp" exec-path
544 '("" ".btm" ".bat" ".cmd" ".exe"
545 ".com") 'executable)
546 (mc-setversion "2.6"))
547 (t
548 (error 'search-failed
549 "Can't find a suitable PGP executable"))))
550 (autoload 'mc-verify "mc-toplev")
551 (declare-fboundp (mc-verify))
552 (setq package-get-continue-update-base t))
553 (error 'unimplemented "`mailcrypt' package unavailable"))
554 (if (yes-or-no-p
555 "Package Index is not PGP signed. Continue anyway? ")
556 (setq package-get-continue-update-base t)
557 (setq package-get-continue-update-base nil) 577 (setq package-get-continue-update-base nil)
558 (error "Package database not updated")))) 578 (autoload 'mc-verify "mc-toplev")
579 (when (declare-fboundp (mc-verify))
580 (setq good-sig t))
581 (if good-sig
582 (setq package-get-continue-update-base t)
583 (error 'process-error
584 "GnuPG error. Package database not updated")))
585 (if (yes-or-no-p
586 "Package Index is not PGP signed. Continue anyway? ")
587 (setq package-get-continue-update-base t)
588 (setq package-get-continue-update-base nil)
589 (warn "Package database not updated"))))
559 ;; ToDo: We should call package-get-maybe-save-index on the region 590 ;; ToDo: We should call package-get-maybe-save-index on the region
560 (if package-get-continue-update-base 591 (when package-get-continue-update-base
561 (progn 592 (package-get-update-base-entries content-beg content-end)
562 (package-get-update-base-entries content-beg content-end) 593 (message "Updated package database")))))
563 (message "Updated package-get database"))))))
564 594
565 (defun package-get-update-base-entries (start end) 595 (defun package-get-update-base-entries (start end)
566 "Update the package-get database with the entries found between 596 "Update the package-get database with the entries found between
567 START and END in the current buffer." 597 START and END in the current buffer."
568 (save-excursion 598 (save-excursion
569 (goto-char start) 599 (goto-char start)
570 (if (not (re-search-forward "^(package-get-update-base-entry" nil t)) 600 (if (not (re-search-forward "^(package-get-update-base-entry" nil t))
571 (error "Buffer does not contain package-get database entries")) 601 (error 'search-failed
602 "Buffer does not contain package-get database entries"))
572 (beginning-of-line) 603 (beginning-of-line)
573 (let ((count 0)) 604 (let ((count 0))
574 (while (and (< (point) end) 605 (while (and (< (point) end)
575 (re-search-forward "^(package-get-update-base-entry" nil t)) 606 (re-search-forward "^(package-get-update-base-entry" nil t))
576 (beginning-of-line) 607 (beginning-of-line)
577 (let ((entry (read (current-buffer)))) 608 (let ((entry (read (current-buffer))))
578 (if (or (not (consp entry)) 609 (if (or (not (consp entry))
579 (not (eq (car entry) 'package-get-update-base-entry))) 610 (not (eq (car entry) 'package-get-update-base-entry)))
580 (error "Invalid package-get database entry found")) 611 (error 'syntax-error
612 "Invalid package-get database entry found"))
581 (package-get-update-base-entry 613 (package-get-update-base-entry
582 (car (cdr (car (cdr entry))))) 614 (car (cdr (car (cdr entry)))))
583 (setq count (1+ count)))) 615 (setq count (1+ count))))
584 (message "Got %d package-get database entries" count)))) 616 (message "Got %d package-get database entries" count))))
585 617
706 (let* ((reqd-package (package-get-package-provider 738 (let* ((reqd-package (package-get-package-provider
707 (car this-requires) t)) 739 (car this-requires) t))
708 (reqd-version (cadr reqd-package)) 740 (reqd-version (cadr reqd-package))
709 (reqd-name (car reqd-package))) 741 (reqd-name (car reqd-package)))
710 (if (null reqd-name) 742 (if (null reqd-name)
711 (error "Unable to find a provider for %s" 743 (error 'search-failed
712 (car this-requires))) 744 (format "Unable to find a provider for %s"
745 (car this-requires))))
713 (if (not (setq fetched-packages 746 (if (not (setq fetched-packages
714 (package-get-all reqd-name reqd-version 747 (package-get-all reqd-name reqd-version
715 fetched-packages 748 fetched-packages
716 install-dir))) 749 install-dir)))
717 (throw 'exit nil)))) 750 (throw 'exit nil))))
738 (mapcar 771 (mapcar
739 #'(lambda (reqd) 772 #'(lambda (reqd)
740 (let* ((reqd-package (package-get-package-provider reqd)) 773 (let* ((reqd-package (package-get-package-provider reqd))
741 (reqd-name (car reqd-package))) 774 (reqd-name (car reqd-package)))
742 (if (null reqd-name) 775 (if (null reqd-name)
743 (error "Unable to find a provider for %s" reqd)) 776 (error 'search-failed
777 (format "Unable to find a provider for %s" reqd)))
744 reqd-name)) 778 reqd-name))
745 this-requires) 779 this-requires)
746 dependencies)) 780 dependencies))
747 (this-provides (package-get-info-prop this-package 'provides))) 781 (this-provides (package-get-info-prop this-package 'provides)))
748 (setq dependencies 782 (setq dependencies
834 (let ((all-pkgs package-get-base) 868 (let ((all-pkgs package-get-base)
835 info) 869 info)
836 (loop until (equal package (caar all-pkgs)) 870 (loop until (equal package (caar all-pkgs))
837 do (setq all-pkgs (cdr all-pkgs)) 871 do (setq all-pkgs (cdr all-pkgs))
838 do (if (not all-pkgs) 872 do (if (not all-pkgs)
839 (error (format "%s is not a valid package" package)))) 873 (error 'invalid-argument
874 (format "%s is not a valid package" package))))
840 (setq info (plist-get (cadar all-pkgs) information)) 875 (setq info (plist-get (cadar all-pkgs) information))
841 (if (interactive-p) 876 (if (interactive-p)
842 (if arg 877 (if arg
843 (insert (format "%s" info)) 878 (insert (format "%s" info))
844 (if (package-get-key package :version) 879 (if (package-get-key package :version)
883 (base-filename (package-get-info-prop this-package 'filename)) 918 (base-filename (package-get-info-prop this-package 'filename))
884 (package-status t) 919 (package-status t)
885 filenames full-package-filename) 920 filenames full-package-filename)
886 (if (and (equal (package-get-info package 'category) "mule") 921 (if (and (equal (package-get-info package 'category) "mule")
887 (not (featurep 'mule))) 922 (not (featurep 'mule)))
888 (error "Mule package %s can't be installed with a non-Mule XEmacs" 923 (error 'invalid-state
889 package)) 924 "Mule packages can't be installed with a non-Mule XEmacs"))
890 (if (null this-package) 925 (if (null this-package)
891 (if package-get-remote 926 (if package-get-remote
892 (error "Couldn't find package %s with version %s" 927 (error 'search-failed
893 package version) 928 (format "Couldn't find package %s with version %s"
894 (error "No download site or local package location specified."))) 929 package version))
930 (error 'syntax-error
931 "No download site or local package location specified.")))
895 (if (null base-filename) 932 (if (null base-filename)
896 (error "No filename associated with package %s, version %s" 933 (error 'syntax-error
897 package version)) 934 (format "No filename associated with package %s, version %s"
935 package version)))
898 (setq install-dir (package-admin-get-install-dir package install-dir)) 936 (setq install-dir (package-admin-get-install-dir package install-dir))
899 937
900 ;; If they asked for the latest using version=nil, don't get an older 938 ;; If they asked for the latest using version=nil, don't get an older
901 ;; version than we already have. 939 ;; version than we already have.
902 (if installed 940 (if installed
974 (setq search-filenames (cdr search-filenames)))))) 1012 (setq search-filenames (cdr search-filenames))))))
975 1013
976 (if (or (not full-package-filename) 1014 (if (or (not full-package-filename)
977 (not (file-exists-p full-package-filename))) 1015 (not (file-exists-p full-package-filename)))
978 (if package-get-remote 1016 (if package-get-remote
979 (error "Unable to find file %s" base-filename) 1017 (error 'search-failed
980 (error 1018 (format "Unable to find file %s" base-filename))
981 "No download sites or local package locations specified."))) 1019 (error 'syntax-error
1020 "No download sites or local package locations specified.")))
982 ;; Validate the md5 checksum 1021 ;; Validate the md5 checksum
983 ;; Doing it with XEmacs removes the need for an external md5 program 1022 ;; Doing it with XEmacs removes the need for an external md5 program
984 (message "Validating checksum for `%s'..." package) (sit-for 0) 1023 (message "Validating checksum for `%s'..." package) (sit-for 0)
985 (with-temp-buffer 1024 (with-temp-buffer
986 (insert-file-contents-literally full-package-filename) 1025 (insert-file-contents-literally full-package-filename)
987 (if (not (string= (md5 (current-buffer)) 1026 (if (not (string= (md5 (current-buffer))
988 (package-get-info-prop this-package 1027 (package-get-info-prop this-package
989 'md5sum))) 1028 'md5sum)))
990 (progn 1029 (progn
991 (delete-file full-package-filename) 1030 (delete-file full-package-filename)
992 (error "Package %s does not match md5 checksum %s has been deleted" 1031 (error 'process-error
993 base-filename full-package-filename)))) 1032 (format "Package %s does not match md5 checksum %s has been deleted"
1033 base-filename full-package-filename)))))
994 1034
995 (package-admin-delete-binary-package package install-dir) 1035 (package-admin-delete-binary-package package install-dir)
996 1036
997 (message "Installing package `%s' ..." package) (sit-for 0) 1037 (message "Installing package `%s' ..." package) (sit-for 0)
998 (let ((status 1038 (let ((status