Mercurial > hg > xemacs-beta

changeset 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 d9b958c0f772
children 9d77c73d4103
files lisp/ChangeLog lisp/package-admin.el lisp/package-get.el lisp/package-info.el lisp/package-net.el lisp/package-ui.el lisp/packages.el
diffstat 7 files changed, 179 insertions(+), 79 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/ChangeLog	Mon Apr 14 03:40:27 2003 +0000
@@ -1,3 +1,43 @@
+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'.
+
 2003-03-27  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* menubar-items.el (default-menubar):
--- a/lisp/package-admin.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/package-admin.el	Mon Apr 14 03:40:27 2003 +0000
@@ -1,6 +1,7 @@
 ;;; package-admin.el --- Installation and Maintenance of XEmacs packages
 
 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
+;; Copyright (C) 2003, Steve Youngs.
 
 ;; Author: SL Baur <steve@xemacs.org>
 ;; Keywords: internal
@@ -172,12 +173,14 @@
 	(let ((path-list (paths-decode-directory-path env-value 'drop-empties)))
 	  (cond ((eq type 'std)
 		 (while path-list
-		   (if (equal (substring (car path-list) -16) "xemacs-packages/")
+		   (if (equal (substring (car path-list) -16) 
+			      (concat "xemacs-packages" directory-sep-char))
 		       (setq top-dir (car path-list)))
 		   (setq path-list (cdr path-list))))
 		((eq type 'mule)
 		 (while path-list
-		   (if (equal (substring (car path-list) -14) "mule-packages/")
+		   (if (equal (substring (car path-list) -14) 
+			      (concat "mule-packages" directory-sep-char))
 		       (setq top-dir (car path-list)))
 		   (setq path-list (cdr path-list)))))))
     ;; Wasn't in the environment, try `user-init-directory' if
@@ -197,12 +200,14 @@
 				 (packages-compute-package-locations user-init-directory)))))
 	  (cond ((eq type 'std)
 		 (while path-list
-		   (if (equal (substring (car path-list) -16) "xemacs-packages/")
+		   (if (equal (substring (car path-list) -16) 
+			      (concat "xemacs-packages" directory-sep-char))
 		       (setq top-dir (car path-list)))
 		   (setq path-list (cdr path-list))))
 		((eq type 'mule)
 		 (while path-list
-		   (if (equal (substring (car path-list) -14) "mule-packages/")
+		   (if (equal (substring (car path-list) -14) 
+			      (concat "mule-packages" directory-sep-char))
 		       (setq top-dir (car path-list)))
 		   (setq path-list (cdr path-list)))))))
     ;; Now return either the directory or nil.
@@ -259,7 +264,8 @@
 		  ((equal type "mule")
 		   (setq pkg-dir (package-admin-find-top-directory 'mule)))
 		  (t
-		   (error "Invalid package type")))
+		   (error 'invalid-operation
+			  "Invalid package type")))
 	    (if (and pkg-dir
 		     (file-writable-p (directory-file-name pkg-dir)))
 		pkg-dir
@@ -274,7 +280,8 @@
 			  ((equal type "mule")
 			   (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))
 			  (t
-			   (error "Invalid package type")))
+			   (error 'invalid-operation
+				  "Invalid package type")))
 		    ;; Turn on `package-get-install-to-user-init-directory'
 		    ;; so we don't get asked for each package we try to
 		    ;; install in this session.
@@ -282,7 +289,10 @@
 		    pkg-dir)
 		;; If we get to here XEmacs can't make up its mind and
 		;; neither can the user, nothing left to do except barf. :-(
-		(error "Can't find suitable installation directory for package: %s" package)))))))))
+		(error 'search-failed
+		       (format
+			"Can't find suitable installation directory for package: %s" 
+			package))))))))))
 
 (defun package-admin-get-manifest-file (pkg-topdir package)
   "Return the name of the MANIFEST file for package PACKAGE.
--- a/lisp/package-get.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/package-get.el	Mon Apr 14 03:40:27 2003 +0000
@@ -2,10 +2,12 @@
 
 ;; Copyright (C) 1998 by Pete Ware
 ;; Copyright (C) 2002 Ben Wing.
+;; Copyright (C) 2003, Steve Youngs
 
 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
 ;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com>
 ;;                      Jan Vroonhof    <vroonhof@math.ethz.ch>
+;;                      Steve Youngs    <youngs@xemacs.org>
 ;; Keywords: internal
 
 ;; This file is part of XEmacs.
@@ -380,10 +382,44 @@
   :type 'boolean
   :group 'package-get)
 
-(defcustom package-get-require-signed-base-updates t
-  "*If set to a non-nil value, require explicit user confirmation for updates
-to the package-get database which cannot have their signature verified via PGP.
-When nil, no PGP verification will be done."
+(defun package-get-pgp-available-p ()
+  "Checks the availability of Mailcrypt and PGP executable.
+
+Returns t if both are found, nil otherwise.  As a side effect, set
+`mc-default-scheme' dependent on the PGP executable found."
+  (let (result)
+    (when (featurep 'mailcrypt-autoloads)
+      (autoload 'mc-setversion "mc-setversion"))
+    (when-fboundp 'mc-setversion
+      (cond ((locate-file "gpg" exec-path
+			  '("" ".btm" ".bat" ".cmd" ".exe" ".com")
+			  'executable)
+	     (mc-setversion "gpg")
+	     (setq result t))
+	    ((locate-file "pgpe" exec-path
+			  '("" ".btm" ".bat" ".cmd" ".exe" ".com")
+			  'executable)
+	     (mc-setversion "5.0")
+	     (setq result t))
+	    ((locate-file "pgp" exec-path
+			  '("" ".btm" ".bat" ".cmd" ".exe" ".com")
+			  'executable)
+	     (mc-setversion "2.6")
+	     (setq result t))))
+    (if result
+	result
+      nil)))
+
+(defcustom package-get-require-signed-base-updates (package-get-pgp-available-p)
+  "*If non-nil, try to verify the package index database via PGP.
+
+If nil, no PGP verification is done.  If the package index database
+entries are not PGP signed and this variable is non-nil, require user
+confirmation to continue with the package-get procedure.
+
+The default for this variable is the return value of
+`package-get-pgp-available-p', non-nil if both the \"Mailcrypt\"
+package and a suitable PGP executable are available, nil otherwise."
   :type 'boolean
   :group 'package-get)
 
@@ -413,7 +449,8 @@
     (package-get-update-base nil force-current))
   (if (or (not (boundp 'package-get-base))
 	  (not package-get-base))
-      (error "Package-get database not loaded")
+      (error 'void-variable
+	     "Package-get database not loaded")
     (setq package-get-was-current force-current)))
 
 (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----"
@@ -458,7 +495,8 @@
       (if (file-exists-p package-get-user-index-filename)
 	  package-get-user-index-filename)
       (locate-data-file package-get-base-filename)
-      (error "Can't locate a package index file.")))
+      (error 'search-failed
+	     "Can't locate a package index file.")))
 
 (defun package-get-maybe-save-index (filename)
   "Offer to save the current buffer as the local package index file,
@@ -491,9 +529,11 @@
                                       (package-get-locate-index-file
 				         (not force-current)))))
   (if (not (file-exists-p db-file))
-      (error "Package-get database file `%s' does not exist" db-file))
+      (error 'file-error
+	     (format "Package-get database file `%s' does not exist" db-file)))
   (if (not (file-readable-p db-file))
-      (error "Package-get database file `%s' not readable" db-file))
+      (error 'file-error
+	     (format "Package-get database file `%s' not readable" db-file)))
   (let ((buf (get-buffer-create "*package database*")))
     (unwind-protect
         (save-excursion
@@ -525,42 +565,32 @@
 	(setq package-entries-are-signed t))
       (re-search-forward package-get-pgp-signature-end-line nil t)
       (setq package-get-continue-update-base t)
-      (if package-get-require-signed-base-updates
-	  (if package-entries-are-signed
-	      (if (featurep 'mailcrypt-autoloads)
-		  (progn
-		    (setq package-get-continue-update-base nil)
-		    (autoload 'mc-setversion "mc-setversion")
-		    (with-fboundp 'mc-setversion
-		      (cond ((locate-file "gpg" exec-path
-					  '("" ".btm" ".bat" ".cmd" ".exe"
-					    ".com") 'executable)
-			     (mc-setversion "gpg"))
-			    ((locate-file "pgpe" exec-path
-					  '("" ".btm" ".bat" ".cmd" ".exe"
-					    ".com") 'executable)
-			     (mc-setversion "5.0"))
-			    ((locate-file "pgp" exec-path
-					  '("" ".btm" ".bat" ".cmd" ".exe"
-					    ".com") 'executable)
-			     (mc-setversion "2.6"))
-			    (t
-			     (error 'search-failed
-				    "Can't find a suitable PGP executable"))))
-		    (autoload 'mc-verify "mc-toplev")
-		    (declare-fboundp (mc-verify))
-		    (setq package-get-continue-update-base t))
-		(error 'unimplemented "`mailcrypt' package unavailable"))
-	    (if (yes-or-no-p
-		 "Package Index is not PGP signed.  Continue anyway? ")
-		(setq package-get-continue-update-base t)
+      ;; This is a little overkill because the default value of
+      ;; `package-get-require-signed-base-updates' is the return of
+      ;; `package-get-pgp-available-p', but we have to allow for
+      ;; someone explicitly setting
+      ;; `package-get-require-signed-base-updates' to t. --SY
+      (when (and package-get-require-signed-base-updates
+		 (package-get-pgp-available-p))
+	(if package-entries-are-signed
+	    (let (good-sig)
 	      (setq package-get-continue-update-base nil)
-	      (error "Package database not updated"))))
+	      (autoload 'mc-verify "mc-toplev")
+	      (when (declare-fboundp (mc-verify))
+		(setq good-sig t))
+	      (if good-sig
+		  (setq package-get-continue-update-base t)
+		(error 'process-error 
+		       "GnuPG error.  Package database not updated")))
+	  (if (yes-or-no-p
+	       "Package Index is not PGP signed.  Continue anyway? ")
+	      (setq package-get-continue-update-base t)
+	    (setq package-get-continue-update-base nil)
+	    (warn "Package database not updated"))))
       ;; ToDo: We should call package-get-maybe-save-index on the region
-      (if package-get-continue-update-base
-	  (progn
-	    (package-get-update-base-entries content-beg content-end)
-	    (message "Updated package-get database"))))))
+      (when package-get-continue-update-base
+	(package-get-update-base-entries content-beg content-end)
+	(message "Updated package database")))))
 
 (defun package-get-update-base-entries (start end)
   "Update the package-get database with the entries found between
@@ -568,7 +598,8 @@
   (save-excursion
     (goto-char start)
     (if (not (re-search-forward "^(package-get-update-base-entry" nil t))
-        (error "Buffer does not contain package-get database entries"))
+        (error 'search-failed
+	       "Buffer does not contain package-get database entries"))
     (beginning-of-line)
     (let ((count 0))
       (while (and (< (point) end)
@@ -577,7 +608,8 @@
         (let ((entry (read (current-buffer))))
           (if (or (not (consp entry))
                   (not (eq (car entry) 'package-get-update-base-entry)))
-              (error "Invalid package-get database entry found"))
+              (error 'syntax-error
+		     "Invalid package-get database entry found"))
           (package-get-update-base-entry
            (car (cdr (car (cdr entry)))))
           (setq count (1+ count))))
@@ -708,8 +740,9 @@
 		   (reqd-version (cadr reqd-package))
 		   (reqd-name (car reqd-package)))
 	      (if (null reqd-name)
-		  (error "Unable to find a provider for %s"
-			 (car this-requires)))
+		  (error 'search-failed
+			 (format "Unable to find a provider for %s"
+				 (car this-requires))))
 	      (if (not (setq fetched-packages
 			     (package-get-all reqd-name reqd-version
 					      fetched-packages
@@ -740,7 +773,8 @@
                                   (let* ((reqd-package (package-get-package-provider reqd))
                                          (reqd-name    (car reqd-package)))
                                     (if (null reqd-name)
-                                        (error "Unable to find a provider for %s" reqd))
+                                        (error 'search-failed
+					       (format "Unable to find a provider for %s" reqd)))
                                     reqd-name))
                               this-requires)
                              dependencies))
@@ -836,7 +870,8 @@
       (loop until (equal package (caar all-pkgs))
 	do (setq all-pkgs (cdr all-pkgs))
 	do (if (not all-pkgs)
-	       (error (format "%s is not a valid package" package))))
+	       (error 'invalid-argument
+		      (format "%s is not a valid package" package))))
       (setq info (plist-get (cadar all-pkgs) information))
       (if (interactive-p)
 	  (if arg
@@ -885,16 +920,19 @@
 	 filenames full-package-filename)
     (if (and (equal (package-get-info package 'category) "mule")
 	     (not (featurep 'mule)))
-	(error "Mule package %s can't be installed with a non-Mule XEmacs"
-	       package))
+	(error 'invalid-state 
+	       "Mule packages can't be installed with a non-Mule XEmacs"))
     (if (null this-package)
 	(if package-get-remote
-	    (error "Couldn't find package %s with version %s"
-		   package version)
-	  (error "No download site or local package location specified.")))
+	    (error 'search-failed
+		   (format "Couldn't find package %s with version %s"
+			   package version))
+	  (error 'syntax-error
+		 "No download site or local package location specified.")))
     (if (null base-filename)
-	(error "No filename associated with package %s, version %s"
-	       package version))
+	(error 'syntax-error
+	       (format "No filename associated with package %s, version %s"
+		       package version)))
     (setq install-dir (package-admin-get-install-dir package install-dir))
 
     ;; If they asked for the latest using version=nil, don't get an older
@@ -976,9 +1014,10 @@
       (if (or (not full-package-filename)
 	      (not (file-exists-p full-package-filename)))
 	  (if package-get-remote
-	      (error "Unable to find file %s" base-filename)
-	    (error
-	     "No download sites or local package locations specified.")))
+	      (error 'search-failed
+		     (format "Unable to find file %s" base-filename))
+	    (error 'syntax-error
+		   "No download sites or local package locations specified.")))
       ;; Validate the md5 checksum
       ;; Doing it with XEmacs removes the need for an external md5 program
       (message "Validating checksum for `%s'..." package) (sit-for 0)
@@ -989,8 +1028,9 @@
 						 'md5sum)))
 	    (progn
 	      (delete-file full-package-filename)
-	      (error "Package %s does not match md5 checksum %s has been deleted"
-		     base-filename full-package-filename))))
+	      (error 'process-error
+		     (format "Package %s does not match md5 checksum %s has been deleted"
+			     base-filename full-package-filename)))))
 
       (package-admin-delete-binary-package package install-dir)
 
--- a/lisp/package-info.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/package-info.el	Mon Apr 14 03:40:27 2003 +0000
@@ -94,7 +94,8 @@
 maintainer -- The package maintainer.
 category -- The build category."
   (unless noninteractive
-    (error "`batch-update-package-info' is to be used only with -batch"))
+    (error 'invalid-operation
+	   "`batch-update-package-info' is to be used only with -batch"))
   (let ((version (nth 0 command-line-args-left))
 	(filename (nth 1 command-line-args-left))
 	(requires (nth 2 command-line-args-left))
--- a/lisp/package-net.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/package-net.el	Mon Apr 14 03:40:27 2003 +0000
@@ -136,7 +136,8 @@
 (defun package-net-batch-generate-bin-ini ()
   "Convert the package index to ini file format."
   (unless noninteractive
-    (error "`package-net-batch-generate-bin-ini' is to be used only with -batch"))
+    (error 'invalid-operation
+	   "`package-net-batch-generate-bin-ini' is to be used only with -batch"))
   (package-net-generate-bin-ini package-net-setup-version))
 
 ;;;###autoload
--- a/lisp/package-ui.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/package-ui.el	Mon Apr 14 03:40:27 2003 +0000
@@ -282,7 +282,8 @@
 	(progn
 	  (pui-toggle-package extent)
 	  (forward-line 1))
-      (error "No package under cursor!"))))
+      (error 'invalid-operation
+	     "No package under cursor!"))))
 
 (defun pui-toggle-package-delete (extent)
   (let (pkg-sym)
@@ -305,7 +306,8 @@
 	(progn
 	  (pui-toggle-package-delete extent)
 	  (forward-line 1))
-      (error "No package under cursor!"))))
+      (error 'invalid-operation
+	     "No package under cursor!"))))
 
 (defun pui-current-package ()
   (let ((extent (extent-at (point) (current-buffer) 'pui)))
@@ -394,7 +396,8 @@
 	    (clear-message)))
       (if pui-deleted-packages
 	  (pui-list-packages)
-	(error "No packages have been selected!")))
+	(error 'invalid-operation
+	       "No packages have been selected!")))
     ;; sync with windows type systems
     (package-net-update-installed-db)))
 
@@ -452,7 +455,8 @@
                              nil nil nil nil nil 'pui)
                 (message "added dependencies"))
 	      (clear-message)))
-      (error "No packages have been selected!"))))
+      (error 'invalid-operation
+	     "No packages have been selected!"))))
 
 (defun pui-help-echo (extent &optional force-update)
   "Display additional package info in the modeline.
@@ -502,7 +506,8 @@
 	  (message (pui-help-echo extent t))
 	(if no-error
 	    (clear-message nil)
-	  (error "No package under cursor!"))))))
+	  (error 'invalid-operation
+		 "No package under cursor!"))))))
 
 (defvar pui-menu
   '("Packages"
@@ -550,7 +555,8 @@
   `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
   `\\[pui-quit]' to kill this buffer.
 "
-  (error "You cannot enter this mode directly. Use `pui-list-packages'"))
+  (error 'invalid-operation
+	 "You cannot enter this mode directly. Use `pui-list-packages'"))
 
 (put 'list-packages-mode 'mode-class 'special)
 
--- a/lisp/packages.el	Sun Apr 13 21:52:52 2003 +0000
+++ b/lisp/packages.el	Mon Apr 14 03:40:27 2003 +0000
@@ -134,11 +134,13 @@
 (defun package-require (name version)
   (let ((pkg (assq name packages-package-list)))
     (cond ((null pkg)
-	   (error "Package %s has not been loaded into this XEmacsen"
-		  name))
+	   (error 'invalid-state
+		  (format "Package %s has not been loaded into this XEmacsen"
+			  name)))
 	  ((< (package-get-key name :version) version)
-	   (error "Need version %g of package %s, got version %g"
-		  version name (cdr pkg)))
+	   (error 'search-failed
+		  (format "Need version %g of package %s, got version %g"
+			  version name (cdr pkg))))
 	  (t t))))
 
 (defun package-delete-name (name)