Index: lisp/package-admin.el
===================================================================
RCS file: /users/darrylo/sources/.repository/xemacs-21.0/lisp/package-admin.el,v
retrieving revision 1.1.1.1
retrieving revision 1.3
diff -c -r1.1.1.1 -r1.3
*** package-admin.el	1998/04/26 19:31:56	1.1.1.1
--- package-admin.el	1998/08/06 05:21:56	1.3
***************
*** 38,43 ****
--- 38,49 ----
  (defvar package-admin-temp-buffer "*Package Output*"
    "Temporary buffer where output of backend commands is saved.")
  
+ (defvar package-admin-install-function 'package-admin-default-install-function
+   "The function to call to install a package.
+ Three args are passed: FILENAME PKG-DIR BUF
+ Install package FILENAME into directory PKG-DIR, with any messages output
+ to buffer BUF.")
+ 
  ;;;###autoload
  (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
    "Install a single file Lisp package into XEmacs package hierarchy.
***************
*** 57,79 ****
  		  ;; rest of command line follows
  		  package-admin-xemacs file destination)))
  
! ;;;###autoload
! (defun package-admin-add-binary-package (file &optional pkg-dir)
!   "Install a pre-bytecompiled XEmacs package into package hierarchy."
!   (interactive "fPackage tarball: ")
    (when (null pkg-dir)
      (when (or (not (listp late-packages))
  	      (not late-packages))
        (error "No package path"))
      (setq pkg-dir (car (last late-packages))))
  
    (let ((buf (get-buffer-create package-admin-temp-buffer)))
!     (call-process "add-big-package.sh"
! 		  nil
! 		  buf
! 		  t
! 		  ;; rest of command line follows
! 		  package-admin-xemacs file pkg-dir)))
  
  (provide 'package-admin)
  
--- 63,102 ----
  		  ;; rest of command line follows
  		  package-admin-xemacs file destination)))
  
! (defun package-admin-install-function-mswindows (file pkg-dir buf)
!   "Install function for mswindows"
!   (let ( (default-directory pkg-dir) )
!     (call-process "djtar" nil buf t "-x" file)
!     ))
! 
! (defun package-admin-default-install-function (file pkg-dir buf)
!   "Default function to install a package.
! Install package FILENAME into directory PKG-DIR, with any messages output
! to buffer BUF."
!   (call-process "add-big-package.sh"
! 		nil
! 		buf
! 		t
! 		;; rest of command line follows
! 		package-admin-xemacs file pkg-dir))
! 
! (defun package-admin-get-install-dir (pkg-dir)
    (when (null pkg-dir)
      (when (or (not (listp late-packages))
  	      (not late-packages))
        (error "No package path"))
      (setq pkg-dir (car (last late-packages))))
+   pkg-dir
+   )
  
+ ;;;###autoload
+ (defun package-admin-add-binary-package (file &optional pkg-dir)
+   "Install a pre-bytecompiled XEmacs package into package hierarchy."
+   (interactive "fPackage tarball: ")
+   (setq pkg-dir (package-admin-get-install-dir pkg-dir))
    (let ((buf (get-buffer-create package-admin-temp-buffer)))
!     (funcall package-admin-install-function
! 	     file pkg-dir buf)))
  
  (provide 'package-admin)
  
Index: lisp/package-get.el
===================================================================
RCS file: /users/darrylo/sources/.repository/xemacs-21.0/lisp/package-get.el,v
retrieving revision 1.1.1.8
diff -c -r1.1.1.8 package-get.el
*** package-get.el	1998/08/05 03:02:44	1.1.1.8
--- package-get.el	1998/08/06 16:05:44
***************
*** 155,166 ****
      ("ftp.xemacs.org" "/pub/xemacs/package"))
    "*List of remote sites to contact for downloading packages.
  List format is '(site-name directory-on-site).  Each site is tried in
! order until the package is found.")
  
  (defvar package-get-remove-copy nil
    "*After copying and installing a package, if this is T, then remove the
  copy.  Otherwise, keep it around.")
  
  ;;;###autoload
  (defun package-get-update-all ()
    "Fetch and install the latest versions of all currently installed packages."
--- 155,339 ----
      ("ftp.xemacs.org" "/pub/xemacs/package"))
    "*List of remote sites to contact for downloading packages.
  List format is '(site-name directory-on-site).  Each site is tried in
! order until the package is found.  As a special case, `site-name' can be
! `nil', in which case `directory-on-site' is treated as a local directory.")
  
  (defvar package-get-remove-copy nil
    "*After copying and installing a package, if this is T, then remove the
  copy.  Otherwise, keep it around.")
  
+ (defvar package-get-info-buffer "*Packages*"
+   "Buffer to use for displaying package information.")
+ 
+ (defvar package-get-display-keymap
+   (let ((m (make-sparse-keymap)))
+     (set-keymap-name m 'package-get-display-keymap)
+ ;    (define-key m 'button2 'glimpse-mh-show-message-event)
+ ;    (define-key m 'button3 'glimpse-mh-show-message-event)
+ ;    (define-key m [return] 'glimpse-mh-show-message-key)
+     m)
+   "Keymap to use over package names/descriptions.")
+ 
+ (defvar package-get-selected-packages nil
+   "The list of user-selected packages to install.")
+ 
+ (defvar package-get-selected-package-face (get-face 'bold)
+   "The face to use for selected packages.")
+ 
+ (defun package-get-package-symbol-char (pkg-sym version)
+   (progn
+     (if (package-get-info-find-package packages-package-list pkg-sym)
+ 	(if (package-get-installedp pkg-sym version)
+ 	    " "
+ 	  "*")
+       "-")
+     ))
+ 
+ (defun package-get-update-package-display (extent &optional pkg-sym version)
+   ""
+   (let (buffer-read-only sym-char)
+     (if (not pkg-sym)
+ 	(setq pkg-sym (extent-property extent 'package-get-package)))
+     (if (not version)
+ 	(setq version (extent-property extent 'package-get-package-version)))
+     (if (member pkg-sym package-get-selected-packages)
+ 	(progn
+ 	  (set-extent-face extent (get-face package-get-selected-package-face))
+ 	  (setq sym-char "+")
+ 	  )
+       (progn
+ 	(set-extent-face extent (get-face 'default))
+ 	(setq sym-char (package-get-package-symbol-char pkg-sym version))
+ 	))
+     (save-excursion
+       (goto-char (extent-start-position extent))
+       (delete-char 1)
+       (insert sym-char)
+       (set-buffer-modified-p nil)
+       )
+     ))
+ 
+ (defun package-get-toggle-package ()
+   ""
+   (interactive)
+   (let (extent pkg-sym version)
+     (if (setq extent (extent-at (point) (current-buffer) 'package-get))
+ 	(progn
+ 	  (setq pkg-sym (extent-property extent 'package-get-package)
+ 		version (extent-property extent 'package-get-package-version))
+ 	  (if (member pkg-sym package-get-selected-packages)
+ 	      (setq package-get-selected-packages
+ 		    (delete pkg-sym package-get-selected-packages))
+ 	    (setq package-get-selected-packages
+ 		  (cons pkg-sym package-get-selected-packages)))
+ 	  (package-get-update-package-display extent pkg-sym)
+ 	  (forward-line 1)
+ 	  )
+       (error "No package under cursor!"))
+     ))
+ 
+ (defun package-get-install-selected-packages ()
+   ""
+   (interactive)
+   (let ( (tmpbuf "*Packages-To-Install*") )
+     (if package-get-selected-packages
+ 	(save-window-excursion
+ 	  (with-output-to-temp-buffer tmpbuf
+ 	    (display-completion-list (sort
+ 				      (mapcar '(lambda (pkg)
+ 						 (format "%s" pkg)
+ 						 )
+ 					      package-get-selected-packages)
+ 				      'string<)
+ 				     :activate-callback nil
+ 				     :help-string "Packages selected for installation:\n\n"
+ 				     ))
+ 	  (setq tmpbuf (get-buffer-create tmpbuf))
+ 	  (display-buffer tmpbuf)
+ 	  (if (y-or-n-p "Install these packages? ")
+ 	      (progn
+ 		(message "Installing selected packages ...") (sit-for 0)
+ 		(mapcar (lambda (pkg)
+ 			  (package-get-all pkg nil))
+ 			package-get-selected-packages)
+ 		(message "Installing selected packages ... done")
+ 		(package-get-list-packages)
+ 		))
+ 	  (kill-buffer tmpbuf)
+ 	  )
+       (error "No packages have been selected!"))
+     ))
+ 
+ (defun package-get-list-packages ()
+   ""
+   (interactive)
+   (let ( (outbuf (get-buffer-create package-get-info-buffer)) )
+     (message "Creating package list ...") (sit-for 0)
+     (set-buffer outbuf)
+     (setq buffer-read-only nil)
+     (buffer-disable-undo outbuf)
+     (erase-buffer outbuf)
+     (insert "                 Latest
+   Package name   Vers.  Description
+ ===============================================================================
+ ")
+     (mapcar '(lambda (pkg)
+ 	       (let (pkg-sym info version desc
+ 			     folder msgnum b e extent)
+ 		 (setq pkg-sym (car pkg)
+ 		       info (package-get-info-version (cdr pkg) nil))
+ 		 (setq version (package-get-info-prop info 'version)
+ 		       desc (package-get-info-prop info 'description))
+ 		 
+ 		 (insert (format "%s %-15s %-5s %s\n"
+ 				 (package-get-package-symbol-char pkg-sym
+ 								  version)
+ 				 pkg-sym version desc))
+ 		 
+ 		 (save-excursion
+ 		   (setq b (progn 
+ 			     (forward-line -1)
+ 			     (beginning-of-line)
+ 			     (point)))
+ 		   (setq e (progn (end-of-line) (point)))
+ 		   )
+ 		 (setq extent (make-extent b e))
+ 		 (set-extent-face extent 'default)
+ 		 (set-extent-property extent 'highlight t)
+ 		 (set-extent-property extent 'package-get t)
+ 		 (set-extent-property extent 'package-get-package pkg-sym)
+ 		 (set-extent-property extent
+ 				      'package-get-package-version version)
+ 		 (set-extent-property extent 'keymap
+ 				      package-get-display-keymap)
+ 		 )) (sort (copy-sequence package-get-base)
+ 			  '(lambda (a b)
+ 			     (let (name-a name-b)
+ 			       (setq name-a (format "%s" a)
+ 				     name-b (format "%s" b))
+ 			       (string< name-a name-b)
+ 			       ))))
+     (insert "===============================================================================
+ Legend for symbols in the leftmost column:
+ 
+   -     The package has not been installed.
+   *     The currently installed package is old, and a newer version is
+         available.
+ ")
+     (set-buffer-modified-p nil)
+     (setq buffer-read-only t)
+     (pop-to-buffer outbuf)
+ ;    (goto-char (point-min))
+     (goto-line 4)
+     (setq package-get-selected-packages nil)	; Reset list
+     (local-set-key "g" 'package-get-list-packages)
+     (local-set-key " " 'package-get-toggle-package)
+     (local-set-key [return] 'package-get-toggle-package)
+     (local-set-key "I" 'package-get-install-selected-packages)
+     (local-set-key "x" 'package-get-install-selected-packages)
+     (message "Creating package list ... done")
+     ))
+ 
  ;;;###autoload
  (defun package-get-update-all ()
    "Fetch and install the latest versions of all currently installed packages."
***************
*** 170,175 ****
--- 343,383 ----
  	    (package-get (car pkg) nil 'never))
            packages-package-list))
  
+ (defun package-get-interactive-package-query (get-version package-symbol)
+   "Perform interactive querying for package and optional version.
+ Query for a version if GET-VERSION is non-nil.  Return package name as
+ a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
+ The return value is suitable for direct passing to `interactive'."
+   (let ( (table (mapcar '(lambda (item)
+ 			   (let ( (name (format "%s" (car item))) )
+ 			     (cons name name)
+ 			     ))
+ 			package-get-base)) 
+ 	 package package-symbol default-version)
+     (save-window-excursion
+       (setq package (completing-read "Package: " table nil t))
+       (setq package-symbol (intern package))
+       (if get-version
+ 	  (progn
+ 	    (setq default-version 
+ 		  (package-get-info-prop 
+ 		   (package-get-info-version
+ 		    (package-get-info-find-package package-get-base
+ 						   package-symbol) nil)
+ 		   'version))
+ 	    (while (string=
+ 		    (setq version (read-string "Version: " default-version))
+ 		    "")
+ 	      )
+ 	    (if package-symbol
+ 		(list package-symbol version)
+ 	      (list package version))
+ 	    )
+ 	(if package-symbol
+ 	    (list package-symbol)
+ 	  (list package)))
+       )))
+ 
  ;;;###autoload
  (defun package-get-all (package version &optional fetched-packages)
    "Fetch PACKAGE with VERSION and all other required packages.
***************
*** 177,183 ****
  package provides that functionality.  If VERSION is nil, retrieves
  latest version.  Optional argument FETCHED-PACKAGES is used to keep
  track of packages already fetched."
!   (interactive "sPackage: \nsVersion: ")
    (let* ((the-package (package-get-info-find-package package-get-base
  						     package))
  	 (this-package (package-get-info-version
--- 385,391 ----
  package provides that functionality.  If VERSION is nil, retrieves
  latest version.  Optional argument FETCHED-PACKAGES is used to keep
  track of packages already fetched."
!   (interactive (package-get-interactive-package-query t nil))
    (let* ((the-package (package-get-info-find-package package-get-base
  						     package))
  	 (this-package (package-get-info-version
***************
*** 229,242 ****
  Once the package is retrieved, its md5 checksum is computed.  If that
  sum does not match that stored in `package-get-base' for this version
  of the package, an error is signalled."
!   (interactive "xPackage List: ")
    (let* ((this-package
  	  (package-get-info-version
  	   (package-get-info-find-package package-get-base
  					  package) version))
  	 (found nil)
  	 (search-dirs package-get-remote)
! 	 (filename (package-get-info-prop this-package 'filename)))
      (if (null this-package)
  	(error "Couldn't find package %s with version %s"
  	       package version))
--- 437,451 ----
  Once the package is retrieved, its md5 checksum is computed.  If that
  sum does not match that stored in `package-get-base' for this version
  of the package, an error is signalled."
!   (interactive (package-get-interactive-package-query nil t))
    (let* ((this-package
  	  (package-get-info-version
  	   (package-get-info-find-package package-get-base
  					  package) version))
  	 (found nil)
  	 (search-dirs package-get-remote)
! 	 (filename (package-get-info-prop this-package 'filename))
! 	 full-package-filename)
      (if (null this-package)
  	(error "Couldn't find package %s with version %s"
  	       package version))
***************
*** 250,287 ****
        ;; and copy it into the staging directory.  Then validate
        ;; the checksum.  Finally, install the package.
        (while (and search-dirs
! 		  (not (file-exists-p (package-get-staging-dir filename))))
! 	(if (file-exists-p (package-get-remote-filename
! 			    (car search-dirs) filename))
! 	    (copy-file (package-get-remote-filename (car search-dirs) filename)
! 		       (package-get-staging-dir filename))
! 	  (setq search-dirs (cdr search-dirs))
! 	  ))
!       (if (not (file-exists-p (package-get-staging-dir filename)))
  	  (error "Unable to find file %s" filename))
        ;; Validate the md5 checksum
        ;; Doing it with XEmacs removes the need for an external md5 program
        (with-temp-buffer
  	;; What ever happened to i-f-c-literally
  	(let (file-name-handler-alist)
! 	  (insert-file-contents-internal (package-get-staging-dir filename)))
  	(if (not (string= (md5 (current-buffer))
  			  (package-get-info-prop this-package
  						 'md5sum)))
  	    (error "Package %s does not match md5 checksum" filename)))
        (message "Retrieved package %s" filename) (sit-for 0)
        (let ((status
! 	     (package-admin-add-binary-package
! 	      (package-get-staging-dir filename)
!               install-dir)))
! 	(when (not (= status 0))
! 	  (message "Package failed.")
  	  (switch-to-buffer package-admin-temp-buffer)))
        (sit-for 0)
        (message "Added package") (sit-for 0)
        (setq found t))
      (if (and found package-get-remove-copy)
! 	(delete-file (package-get-staging-dir filename)))
      ))
  
  (defun package-get-info-find-package (which name)
--- 459,527 ----
        ;; and copy it into the staging directory.  Then validate
        ;; the checksum.  Finally, install the package.
        (while (and search-dirs
! 		  (or (not full-package-filename)
! 		      (not (file-exists-p full-package-filename))))
! 	(if (null (car (car search-dirs)))
! 	    (progn
! 	      (setq full-package-filename
! 		    (expand-file-name
! 		     (substitute-in-file-name
! 		      (concat (file-name-as-directory
! 			       (car (cdr (car search-dirs))))
! 			      filename))))
! 	      )
! 	  (if (file-exists-p (package-get-remote-filename
! 			      (car search-dirs) filename))
! 	      (progn
! 		(setq full-package-filename (package-get-staging-dir filename))
! 		(copy-file (package-get-remote-filename (car search-dirs)
! 							filename)
! 			   full-package-filename)
! 		)))
! 	(setq search-dirs (cdr search-dirs))
! 	)
!       (if (or (not full-package-filename)
! 	      (not (file-exists-p full-package-filename)))
  	  (error "Unable to find file %s" filename))
        ;; Validate the md5 checksum
        ;; Doing it with XEmacs removes the need for an external md5 program
        (with-temp-buffer
  	;; What ever happened to i-f-c-literally
  	(let (file-name-handler-alist)
! 	  (insert-file-contents-internal full-package-filename))
  	(if (not (string= (md5 (current-buffer))
  			  (package-get-info-prop this-package
  						 'md5sum)))
  	    (error "Package %s does not match md5 checksum" filename)))
        (message "Retrieved package %s" filename) (sit-for 0)
        (let ((status
! 	     (package-admin-add-binary-package full-package-filename
! 					       install-dir))
! 	    pathname file)
! 	(if (= status 0)
! 	    (save-excursion
! 	      (set-buffer package-admin-temp-buffer)
! 	      (goto-char (point-min))
! 	      (while (re-search-forward "[ \t]\\([^ \t]*/_pkg.el\\)" nil t)
! 		(setq file (buffer-substring (match-beginning 1)
! 					     (match-end 1)))
! 		(setq pathname (concat (file-name-as-directory
! 					(package-admin-get-install-dir
! 					 install-dir))
! 				       file))
! 		(condition-case err
! 		    (load pathname t)
! 		  (t
! 		   (message "Error loading package file \"%s\"!" pathname)))
! 		)
! 	      )
! 	  (message "Add of package %s failed." filename)
  	  (switch-to-buffer package-admin-temp-buffer)))
        (sit-for 0)
        (message "Added package") (sit-for 0)
        (setq found t))
      (if (and found package-get-remove-copy)
! 	(delete-file full-package-filename))
      ))
  
  (defun package-get-info-find-package (which name)
***************
*** 306,312 ****
    `package-get-info-find-package'.  If VERSION is nil, then return the 
    first (aka most recent) version.  Use `package-get-info-find-prop'
    to retrieve a particular property from the value returned by this."
!   (interactive "xPackage Info: \nsVersion: ")
    (while (and version package (not (string= (plist-get (car package) 'version) version)))
      (setq package (cdr package)))
    (if package (car package)))
--- 546,552 ----
    `package-get-info-find-package'.  If VERSION is nil, then return the 
    first (aka most recent) version.  Use `package-get-info-find-prop'
    to retrieve a particular property from the value returned by this."
!   (interactive (package-get-interactive-package-query t t))
    (while (and version package (not (string= (plist-get (car package) 'version) version)))
      (setq package (cdr package)))
    (if package (car package)))