Mercurial > hg > xemacs-beta

diff lisp/package-ui.el @ 1365:02909207294a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-03-20 13:19:56 by youngs] 2003-03-20 Steve Youngs <youngs@xemacs.org> * menubar-items.el (default-menubar): Add a "Pre-Release Download Sites" submenu to "Tools -> Packages" menu. Filter the package download sites menus through `menu-split-long-menu'. * obsolete.el (pui-add-install-directory): New. (package-get-download-menu): New. * package-admin.el: (package-admin-add-single-file-package): Removed. (package-admin-get-install-dir): Don't rely on an installed xemacs-base package to guess where a package needs to be installed to. (package-admin-get-manifest-file): Whitespace clean up. (package-admin-check-manifest): Use `directory-sep-char' to compute regexp. Only search 'lisp' and 'man' directories to determine package name. Don't error is xemacs-base package isn't installed, just don't sort the MANIFEST file and issue a warning. (package-admin-add-binary-package): Whitespace clean up. (package-admin-get-lispdir): Ditto. (package-admin-delete-binary-package): Use `with-temp-buffer' instead of creating a temporary buffer manually. * package-get.el: (package-get-remote): Change custom type so that only either a single directory or remote host:directory can be selected. (package-get-download-sites): Put the sites into alphabetical order of country. Make the description element be "Country (site)" instead of the other way around. (package-get-pre-release-download-sites): New. (package-get-require-signed-base-updates): Default to t. (package-get-download-menu): Removed. (package-get-locate-file): Change to reflect new format of 'package-get-remote'. (package-get-update-base-from-buffer): Whitespace clean up and remove an unneccessary 'when'. (package-get-interactive-package-query): Whitespace clean up. (package-get-update-all): Ditto. (package-get-all): Ditto. (package-get-init-package): Ditto. (package-get-info): New. (package-get): Bring into line with new format of 'package-get-remote'. Error if non-Mule XEmacsen try to install Mule packages. Don't rely on a Mule package having 'mule-base' in its "REQUIRES" to determine if it is a Mule package or not, instead we test "CATEGORY". Better handling of the situation where a partial package tarball exists on the local hard drive from a previous interupted download. Clean up after a failed package install. (package-get-set-version-prop): Removed. (package-get-installedp): Whitespace clean up. * package-ui.el: Whitespace clean up. (pui-info-buffer): Make it a defcustom. (pui-directory-exists): Removed. (pui-package-dir-list): Removed. (pui-add-install-directory): Removed. (package-ui-download-menu): New. (package-ui-pre-release-download-menu): New. (pui-set-local-package-get-directory): New. (pui-package-symbol-char): Whitespace clean up. (pui-update-package-display): Ditto. (pui-toggle-package): Ditto. (pui-toggle-package-key): Ditto. (pui-toggle-package-delete): Ditto. (pui-toggle-package-delete-key): Ditto. (pui-toggle-package-event): Ditto. (pui-toggle-verbosity-redisplay): Ditto. (pui-install-selected-packages): Ditto. (pui-help-echo): Ditto. (pui-display-info): Ditto. (pui-list-packages): Ditto. * packages.el: Whitespace clean up.
author youngs
date Thu, 20 Mar 2003 13:19:59 +0000
parents d83885ef293b
children d638fc15d68b
line wrap: on
line diff
--- a/lisp/package-ui.el	Wed Mar 19 22:52:25 2003 +0000
+++ b/lisp/package-ui.el	Thu Mar 20 13:19:59 2003 +0000
@@ -80,11 +80,10 @@
    :group 'pui
    :type 'face)
    
-
-
-
-(defvar pui-info-buffer "*Packages*"
-  "Buffer to use for displaying package information.")
+(defcustom pui-info-buffer "*Packages*"
+  "*Buffer to use for displaying package information."
+  :group 'pui
+  :type 'string)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; End of user-changeable variables.
@@ -137,46 +136,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Configuration routines
 
-(defun pui-directory-exists (dir)
-  "Check to see if DIR exists in `package-get-remote'."
-  (let (found)
-    (mapcar #'(lambda (item)
-		(if (and (null (car item))
-			 (string-equal (file-name-as-directory (car (cdr item)))
-				       (file-name-as-directory dir)))
-		    (setq found t)))
-	    package-get-remote)
-    found
-    ))
-
-(defun pui-package-dir-list (buffer)
-  "In BUFFER, format the list of package binary paths."
-  (let ( (count 1) paths sys dir)
-    (set-buffer buffer)
-    (buffer-disable-undo buffer)
-    (erase-buffer buffer)
-    (insert "Existing package binary paths:\n\n")
-    (setq paths package-get-remote)
-    (while paths
-      (setq sys (car (car paths))
-	    dir (car (cdr (car paths))))
-      (insert (format "%2s. " count))
-      (if (null sys)
-	  (insert dir)
-	(insert sys ":" dir))
-      (insert "\n")
-      (setq count (1+ count))
-      (setq paths (cdr paths))
-      )
-    (insert "\nThese are the places that will be searched for package binaries.\n")
-    (goto-char (point-min))
-    ))
-
 ;;;###autoload
 (defun package-ui-add-site (site)
   "Add site to package-get-remote and possibly offer to update package list."
   (let ((had-none (null package-get-remote)))
-    (push site package-get-remote)    
+    (setq package-get-remote site)    
     (when (and had-none package-get-was-current
 	       (y-or-n-p "Update Package list?"))
       (setq package-get-was-current nil)
@@ -185,39 +149,49 @@
 	  (save-window-excursion
 	    (pui-list-packages))))
     (set-menubar-dirty-flag)))
-    
+
+;;;###autoload
+(defun package-ui-download-menu ()
+  "Build the `Add Download Site' menu."
+  (mapcar (lambda (site)
+  	    (vector (car site)
+  		    `(if (equal package-get-remote (quote ,(cdr site)))
+ 		      (setq package-get-remote nil)
+ 		      (package-ui-add-site (quote ,(cdr site))))
+		    ;; I've used radio buttons so that only a single
+		    ;; site can be selected, but they are in fact
+		    ;; toggles.  SY.
+  		    :style 'radio
+  		    :selected `(equal package-get-remote (quote ,(cdr site)))))
+  	  package-get-download-sites))
 
 ;;;###autoload
-(defun pui-add-install-directory (dir)
-  "Add a new package binary directory to the head of `package-get-remote'.
+(defun package-ui-pre-release-download-menu ()
+  "Build the 'Pre-Release Download Sites' menu."
+  (mapcar (lambda (site)
+  	    (vector (car site)
+  		    `(if (equal package-get-remote (quote ,(cdr site)))
+ 		      (setq package-get-remote nil)
+ 		      (package-ui-add-site (quote ,(cdr site))))
+		    ;; I've used radio buttons so that only a single
+		    ;; site can be selected, but they are in fact
+		    ;; toggles.  SY.
+  		    :style 'radio
+  		    :selected `(equal package-get-remote (quote ,(cdr site)))))
+  	  package-get-pre-release-download-sites))
+
+;;;###autoload
+(defun pui-set-local-package-get-directory (dir)
+  "Set a new package binary directory in `package-get-remote'.
 Note that no provision is made for saving any changes made by this function.
 It exists mainly as a convenience for one-time package installations from
 disk."
-  (interactive (let ( (tmpbuf (get-buffer-create
-			       "*Existing Package Binary Paths*"))
-		      dir)
-		 (save-window-excursion
-		   (save-excursion
-		     (unwind-protect
-			 (progn
-			   (pui-package-dir-list tmpbuf)
-			   (display-buffer tmpbuf)
-			   (setq dir (read-directory-name
-				      "New package binary directory to add? "
-				      nil nil t))
-			   )
-		       (kill-buffer tmpbuf)
-		       )))
-		 (list dir)
-		 ))
-  (progn
-    (if (not (pui-directory-exists dir))
-	(progn
-	  (setq package-get-remote (cons (list nil dir) package-get-remote))
-	  (message "Package directory \"%s\" added." dir)
-	  )
-      (message "Directory \"%s\" already exists in `package-get-remote'." dir))
-    ))
+  (interactive) 
+  (let ((dir (read-directory-name
+	      "New package binary directory to add? "
+	      nil nil t)))
+    (setq package-get-remote (list nil dir))
+    (message "Package directory \"%s\" added." dir)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Package list/installer routines
@@ -238,8 +212,7 @@
                     version))
               (list " " pui-up-to-date-package-face)
             (list "*" pui-outdated-package-face)))
-      (list "-" pui-uninstalled-package-face))
-    ))
+      (list "-" pui-uninstalled-package-face))))
 
 (defun pui-update-package-display (extent &optional pkg-sym version)
   "Update the package status for EXTENT.
@@ -272,9 +245,7 @@
       (goto-char (extent-start-position extent))
       (delete-char 1)
       (insert sym-char)
-      (set-buffer-modified-p nil)
-      )
-    ))
+      (set-buffer-modified-p nil))))
 
 (defun pui-toggle-package (extent)
   (let (pkg-sym)
@@ -286,8 +257,7 @@
 	    (cons pkg-sym pui-selected-packages))
       (setq pui-deleted-packages
 	    (delete pkg-sym pui-deleted-packages)))
-    (pui-update-package-display extent pkg-sym)
-    ))
+    (pui-update-package-display extent pkg-sym)))
 
 (defun pui-toggle-package-key ()
   "Select/unselect package for installation, using the keyboard."
@@ -296,10 +266,8 @@
     (if (setq extent (extent-at (point) (current-buffer) 'pui))
 	(progn
 	  (pui-toggle-package extent)
-	  (forward-line 1)
-	  )
-      (error "No package under cursor!"))
-    ))
+	  (forward-line 1))
+      (error "No package under cursor!"))))
 
 (defun pui-toggle-package-delete (extent)
   (let (pkg-sym)
@@ -311,8 +279,7 @@
 	    (cons pkg-sym pui-deleted-packages))
       (setq pui-selected-packages
 	    (delete pkg-sym pui-selected-packages)))
-    (pui-update-package-display extent pkg-sym)
-    ))
+    (pui-update-package-display extent pkg-sym)))
   
 
 (defun pui-toggle-package-delete-key ()
@@ -322,10 +289,8 @@
     (if (setq extent (extent-at (point) (current-buffer) 'pui))
 	(progn
 	  (pui-toggle-package-delete extent)
-	  (forward-line 1)
-	  )
-      (error "No package under cursor!"))
-    ))
+	  (forward-line 1))
+      (error "No package under cursor!"))))
 
 (defun pui-current-package ()
   (let ((extent (extent-at (point) (current-buffer) 'pui)))
@@ -335,25 +300,23 @@
 (defun pui-toggle-package-event (event)
   "Select/unselect package for installation, using the mouse."
   (interactive "e")
-  (let* ( (ep (event-point event))
-          (buffer (window-buffer (event-window event)))
-          (extent (extent-at ep buffer 'pui-package))
-          )
-    (pui-toggle-package extent)
-    ))
+  (let* ((ep (event-point event))
+	 (buffer (window-buffer (event-window event)))
+	 (extent (extent-at ep buffer 'pui-package)))
+    (pui-toggle-package extent)))
 
 (defun pui-toggle-verbosity-redisplay ()
   "Toggle verbose package info."
   (interactive)
   (progn
     (setq pui-list-verbose (not pui-list-verbose))
-    (pui-list-packages)
-    ))
+    (pui-list-packages)))
 
 (defun pui-install-selected-packages ()
   "Install selected packages."
   (interactive)
-  (let ( (tmpbuf "*Packages-To-Remove*") do-delete)
+  (let ((tmpbuf "*Packages-To-Remove*") 
+	do-delete)
     (when pui-deleted-packages
       (save-window-excursion
 	(with-output-to-temp-buffer tmpbuf
@@ -362,8 +325,7 @@
 				    #'string<)
 				   :activate-callback nil
 				   :help-string "Packages selected for removal:\n"
-				   :completion-string t
-				   ))
+				   :completion-string t))
 	(setq tmpbuf (get-buffer-create tmpbuf))
 	(display-buffer tmpbuf)
 	(setq do-delete (yes-or-no-p "Remove these packages? "))
@@ -376,7 +338,8 @@
 		(nreverse pui-deleted-packages))
 	(message "Packages deleted"))))
 	 
-  (let ( (tmpbuf "*Packages-To-Install*") do-install)
+  (let ((tmpbuf "*Packages-To-Install*") 
+	do-install)
     (if pui-selected-packages
 	(progn
 	  ;; Don't change window config when asking the user if he really
@@ -390,21 +353,18 @@
 	       (sort (mapcar #'symbol-name pui-selected-packages) #'string<)
 	       :activate-callback nil
 	       :help-string "Packages selected for installation:\n"
-	       :completion-string t
-	       ))
+	       :completion-string t))
 	    (setq tmpbuf (get-buffer-create tmpbuf))
 	    (display-buffer tmpbuf)
 	    (setq do-install (y-or-n-p "Install these packages? "))
-	    (kill-buffer tmpbuf)
-	    )
+	    (kill-buffer tmpbuf))
 	  (if do-install
 	      (progn
 		(save-excursion
 		  ;; Clear old temp buffer history
 		  (set-buffer (get-buffer-create package-admin-temp-buffer))
 		  (buffer-disable-undo package-admin-temp-buffer)
-		  (erase-buffer package-admin-temp-buffer)
-		  )
+		  (erase-buffer package-admin-temp-buffer))
 		(message "Installing selected packages ...") (sit-for 0)
 		(if (catch 'done
 		      (mapcar (lambda (pkg)
@@ -415,18 +375,13 @@
 		      t)
 		    (progn
 		      (pui-list-packages)
-		      (message "Packages installed")
-		      ))
-		)
-	    (clear-message)
-	    )
-	  )
+		      (message "Packages installed"))))
+	    (clear-message)))
       (if pui-deleted-packages
 	  (pui-list-packages)
 	(error "No packages have been selected!")))
     ;; sync with windows type systems
-    (package-net-update-installed-db)
-    ))
+    (package-net-update-installed-db)))
 
 (defun pui-add-required-packages ()
   "Select packages required by those already selected for installation."
@@ -490,8 +445,7 @@
 attached to the extent as properties)."
   (let (pkg-sym info inst-ver auth-ver date maintainer balloon req)
     (if (or force-update (not (current-message))
-	    (string-match ".*: .*: " (current-message))
-	    )
+	    (string-match ".*: .*: " (current-message)))
 	(progn
 	  (setq pkg-sym (extent-property extent 'pui-package)
 		info (extent-property extent 'pui-info)
@@ -520,9 +474,7 @@
 	       "Inst V: %.2f Auth V: %s Maint: %s" 
 	       inst-ver auth-ver maintainer)
 	    (format "%.2f : %s : %s"
-		    inst-ver auth-ver maintainer))
-	  ))
-    ))
+		    inst-ver auth-ver maintainer))))))
 
 (defun pui-display-info (&optional no-error event)
   "Display additional package info in the modeline.
@@ -535,8 +487,7 @@
 	  (message (pui-help-echo extent t))
 	(if no-error
 	    (clear-message nil)
-	  (error "No package under cursor!")))
-      )))
+	  (error "No package under cursor!"))))))
 
 (defvar pui-menu
   '("Packages"
@@ -597,9 +548,9 @@
 select packages for installation via the keyboard or mouse."
   (interactive)
   (package-get-require-base t)
-  (let ( (outbuf (get-buffer-create pui-info-buffer))
-	 (sep-string "===============================================================================\n")
-	 start )
+  (let ((outbuf (get-buffer-create pui-info-buffer))
+	(sep-string "===============================================================================\n")
+	start)
     (message "Creating package list ...") (sit-for 0)
     (set-buffer outbuf)
     (setq buffer-read-only nil)
@@ -643,27 +594,21 @@
 	       (progn
 		 (setq current-vers (package-get-key pkg-sym :version))
 		 (cond
-		  ( (not current-vers)
-		    (setq current-vers "-----") )
-		  ( (stringp current-vers)
-		    (setq current-vers
-			  (format "%.2f"
-				  (string-to-number current-vers))) )
-		  ( (numberp current-vers)
-		    (setq current-vers (format "%.2f" current-vers)) )
-		  )
+		  ((not current-vers)
+		   (setq current-vers "-----"))
+		  ((stringp current-vers)
+		   (setq current-vers
+			 (format "%.2f"
+				 (string-to-number current-vers))))
+		  ((numberp current-vers)
+		   (setq current-vers (format "%.2f" current-vers))))
 		 (insert
 		  (format "%s %-15s %-5.2f  %-5s  %s\n"
 			  (car disp) pkg-sym 
 			  (if (stringp version)
 			      (string-to-number version)
 			    version)
-			  current-vers desc))
-		 ;; (insert
-		 ;;  (format "\t\t  %-12s  %s\n"
-		 ;;    (package-get-info-prop info 'author-version)
-		 ;;    (package-get-info-prop info 'date)))
-		 )
+			  current-vers desc)))
 	     (insert (format "%s %-15s %-5s %s\n"
 			     (car disp)
 			     pkg-sym version desc)))
@@ -681,8 +626,7 @@
 	   (set-extent-property extent 'pui-package pkg-sym)
 	   (set-extent-property extent 'pui-info info)
 	   (set-extent-property extent 'help-echo 'pui-help-echo)
-	   (set-extent-property extent 'keymap pui-package-keymap)
-	   ))
+	   (set-extent-property extent 'keymap pui-package-keymap)))
      (sort (copy-sequence package-get-base)
 	   #'(lambda (a b)
 	       (string< (symbol-name (car a))
@@ -700,9 +644,7 @@
       (set-buffer-menubar current-menubar)
       (add-submenu '() pui-menu)
       (setq mode-popup-menu pui-menu))
-    (clear-message)
-    ;;    (message (substitute-command-keys "Press `\\[pui-help]' for help."))
-    ))
+    (clear-message)))
 
 ;;;###autoload
 (defalias 'list-packages 'pui-list-packages)