--- a/lisp/package-admin.el	Mon Aug 13 10:44:47 2007 +0200
+++ b/lisp/package-admin.el	Mon Aug 13 10:45:36 2007 +0200
@@ -77,6 +77,31 @@
 This is awful, but it exists because error return codes aren't reliable
 under MS Windows.")
 
+(defvar package-admin-tar-filename-regexps
+  '(
+    ;; GNU tar:
+    ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname
+    "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)"
+    ;; HP-UX & SunOS tar:
+    ;; rwxrwxr-x 501/501    123 Feb 18 15:46 1997 pathname
+    ;; Solaris tar (phooey!):
+    ;; rwxrwxr-x501/501    123 Feb 18 15:46 1997 pathname
+    ;; AIX tar:
+    ;; -rw-r--r-- 147 1019   32919 Mar 26 12:00:09 1992 pathname
+    "\\S-+\\s-*[-a-z0-9_]+[/ ][-a-z0-9_]+\\s-+[0-9]+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
+
+    ;; djtar:
+    ;; drwx Aug 31 02:01:41 1998       123 pathname
+    "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
+
+    )
+  "List of regexps to use to search for tar filenames.
+Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as
+match #1).  Don't put \"^\" to match the beginning of the line; this
+is already implicit, as `looking-at' is used.  Filenames can,
+unfortunately, contain spaces, so be careful in constructing any
+regexps.")
+
 ;;;###autoload
 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
   "Install a single file Lisp package into XEmacs package hierarchy.
@@ -108,6 +133,7 @@
 to buffer BUF."
   (let (filename)
     (setq filename (expand-file-name file pkg-dir))
+    ;; Don't assume GNU tar.
     (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buf)
 	0
       1)
@@ -129,15 +155,151 @@
   pkg-dir
   )
 
+(defun package-admin-get-manifest-file (pkg-topdir package)
+  "Return the name of the MANIFEST file for package PACKAGE.
+Note that PACKAGE is a symbol, and not a string."
+  (let (dir)
+    (setq dir (expand-file-name "pkginfo" pkg-topdir))
+    (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)
+    ))
+
+(defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
+  "Check for a MANIFEST.<package> file in the package distribution.
+If it doesn't exist, create and write one.
+PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
+is the top-level directory under which the package was installed."
+  (let ( (manifest-buf " *pkg-manifest*")
+	 old-case-fold-search regexp package-name pathname regexps)
+    ;; Save and restore the case-fold-search status.
+    ;; We do this in case we have to screw with it (as it the case of
+    ;; case-insensitive filesystems such as MS Windows).
+    (setq old-case-fold-search case-fold-search)
+    (unwind-protect
+	(save-excursion				;; Probably redundant.
+	  (set-buffer (get-buffer pkg-outbuf))	;; Probably already the
+						;; current buffer.
+	  (goto-char (point-min))
+
+	  ;; Make filenames case-insensitive, if necessary
+	  (if (eq system-type 'windows-nt)
+	      (setq case-fold-search t))
+
+	  ;; We really should compute the regexp.
+	  ;; However, directory-sep-char is currently broken, but we need
+	  ;; functional code *NOW*.
+	  (setq regexp "\\bpkginfo[\\/]MANIFEST\\...*")
+
+	  ;; Look for the manifest.
+	  (if (not (re-search-forward regexp nil t))
+	      (progn
+		;; We didn't find a manifest.  Make one.
+
+		;; Yuk.  We weren't passed the package name, and so we have
+		;; to dig for it.  Look for it as the subdirectory name below
+		;; "lisp", "man", "info", or "etc".
+		;; Here, we don't use a single regexp because we want to search
+		;; the directories for a package name in a particular order.
+		;; The problem is that packages could have directories like
+		;; "etc/sounds/" or "etc/photos/" and we don't want to get
+		;; these confused with the actual package name (although, in
+		;; the case of "etc/sounds/", it's probably correct).
+		(if (catch 'done
+		      (let ( (dirs '("lisp" "info" "man" "etc")) rexp)
+			(while dirs
+			  (setq rexp (concat "\\b" (car dirs)
+					     "[\\/]\\([^\\/]+\\)[\//]"))
+			  (if (re-search-forward rexp nil t)
+			      (throw 'done t))
+			  (setq dirs (cdr dirs))
+			  )))
+		    (progn
+		      (setq package-name (buffer-substring (match-beginning 1)
+							   (match-end 1)))
+
+		      ;; Get and erase the manifest buffer
+		      (setq manifest-buf (get-buffer-create manifest-buf))
+		      (buffer-disable-undo manifest-buf)
+		      (erase-buffer manifest-buf)
+
+		      ;; Now, scan through the output buffer, looking for
+		      ;; file and directory names.
+		      (goto-char (point-min))
+		      ;; for each line ...
+		      (while (< (point) (point-max))
+			(beginning-of-line)
+			(setq pathname nil)
+
+			;; scan through the regexps, looking for a pathname
+			(if (catch 'found-path
+			      (setq regexps package-admin-tar-filename-regexps)
+			      (while regexps
+				(if (looking-at (car regexps))
+				    (progn
+				      (setq pathname
+					    (buffer-substring
+					     (match-beginning 1)
+					     (match-end 1)))
+				      (throw 'found-path t)
+				      ))
+				(setq regexps (cdr regexps))
+				)
+			      )
+			    (progn
+			      ;; found a pathname -- add it to the manifest
+			      ;; buffer
+			      (save-excursion
+				(set-buffer manifest-buf)
+				(goto-char (point-max))
+				(insert pathname "\n")
+				)
+			      ))
+			(forward-line 1)
+			)
+
+		      ;; Processed all lines.
+		      ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
+
+		      ;; We use `expand-file-name' instead of `concat',
+		      ;; for portability.
+		      (setq pathname (expand-file-name "pkginfo"
+						       pkg-topdir))
+		      ;; Create pkginfo, if necessary
+		      (if (not (file-directory-p pathname))
+			  (make-directory pathname))
+		      (setq pathname (expand-file-name 
+				      (concat "MANIFEST." package-name)
+				      pathname))
+		      (save-excursion
+			(set-buffer manifest-buf)
+			;; Put the files in sorted order
+			(sort-lines nil (point-min) (point-max))
+			;; Write the file.
+			;; Note that using `write-region' *BYPASSES* any check
+			;; to see if XEmacs is currently editing/visiting the
+			;; file.
+			(write-region (point-min) (point-max) pathname)
+			)
+		      (kill-buffer manifest-buf)
+		      )
+		  (progn
+		    ;; We can't determine the package name from an extracted
+		    ;; file in the tar output buffer.
+		    ))
+		))
+	  )
+      ;; Restore old case-fold-search status
+      (setq case-fold-search old-case-fold-search))
+    ))
+
 ;;;###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))
 	(status 1)
 	start err-list
 	)
+    (setq pkg-dir (package-admin-get-install-dir pkg-dir))
     ;; Insure that the current directory doesn't change
     (save-excursion
       (set-buffer buf)
@@ -147,22 +309,169 @@
       (goto-char (setq start (point-max)))
       (if (= 0 (setq status (funcall package-admin-install-function
 				     file pkg-dir buf)))
-	  (catch 'done
-	    (goto-char start)
-	    (setq err-list package-admin-error-messages)
-	    (while err-list
-	      (if (re-search-forward (car err-list) nil t)
-		  (progn
-		    (setq status 1)
-		    (throw 'done nil)
-		    ))
-	      (setq err-list (cdr err-list))
+	  (progn
+	    ;; First, check for errors.
+	    ;; We can't necessarily rely upon process error codes.
+	    (catch 'done
+	      (goto-char start)
+	      (setq err-list package-admin-error-messages)
+	      (while err-list
+		(if (re-search-forward (car err-list) nil t)
+		    (progn
+		      (setq status 1)
+		      (throw 'done nil)
+		      ))
+		(setq err-list (cdr err-list))
+		)
 	      )
+	    ;; Make sure that the MANIFEST file exists
+	    (package-admin-check-manifest buf pkg-dir)
 	    ))
       )
     status
     ))
 
+(defun package-admin-rmtree (directory)
+  "Delete a directory and all of its contents, recursively.
+This is a feeble attempt at making a portable rmdir."
+  (let ( (orig-default-directory default-directory) files dirs dir)
+    (unwind-protect
+	(progn
+	  (setq directory (file-name-as-directory directory))
+	  (setq files (directory-files directory nil nil nil t))
+	  (setq dirs (directory-files directory nil nil nil 'dirs))
+	  (while dirs
+	    (setq dir (car dirs))
+	    (if (file-symlink-p dir)	;; just in case, handle symlinks
+		(delete-file dir)
+	      (if (not (or (string-equal dir ".") (string-equal dir "..")))
+		  (package-admin-rmtree (expand-file-name dir directory))))
+	    (setq dirs (cdr dirs))
+	    )
+	  (setq default-directory directory)
+	  (condition-case err
+	      (progn
+		(while files
+		  (delete-file (car files))
+		  (setq files (cdr files))
+		  )
+		(delete-directory directory)
+		)
+	    (file-error
+	     (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))
+	    )
+	  )
+      (progn
+	(setq default-directory orig-default-directory)
+	))
+    ))
+
+(defun package-admin-get-lispdir  (pkg-topdir package)
+  (let (package-lispdir)
+    (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
+	     (setq package-lispdir (expand-file-name (symbol-name package)
+						     package-lispdir))
+	     (file-accessible-directory-p package-lispdir))
+	package-lispdir)
+    ))
+
+(defun package-admin-delete-binary-package (package pkg-topdir)
+  "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
+PACKAGE is a symbol, not a string."
+  (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file)
+    (if (not pkg-topdir)
+	(setq pkg-topdir (package-admin-get-install-dir nil)))
+    (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
+    (if (file-exists-p manifest-file)
+	(progn
+	  ;; The manifest file exists!  Use it to delete the old distribution.
+	  (message "Removing old files for package \"%s\" ..." package)
+	  (sit-for 0)
+	  (setq tmpbuf (get-buffer-create tmpbuf))
+	  (save-excursion
+	    (set-buffer tmpbuf)
+	    (buffer-disable-undo tmpbuf)
+	    (erase-buffer tmpbuf)
+	    (insert-file-contents manifest-file)
+	    (goto-char (point-min))
+	    ;; For each entry in the MANIFEST ...
+	    (while (< (point) (point-max))
+	      (beginning-of-line)
+	      (setq file (expand-file-name (buffer-substring
+					    (point)
+					    (save-excursion (end-of-line)
+							    (point)))
+					   pkg-topdir))
+	      (if (file-directory-p file)
+		  ;; Keep a record of each directory
+		  (setq dirs (cons file dirs))
+		(progn
+		  ;; Delete each file.
+		  ;; Make sure that the file is writable.
+		  ;; (This is important under MS Windows.)
+		  (set-file-modes file 438) ;; 438 -> #o666
+		  (delete-file file)
+		  ))
+	      (forward-line 1)
+	      )
+	    ;; Delete empty directories.
+	    (if dirs
+		(let ( (orig-default-directory default-directory)
+		       directory files file )
+		  ;; Make sure we preserve the existing `default-directory'.
+		  (unwind-protect
+		      (progn
+			;; Warning: destructive sort!
+			(setq dirs (nreverse (sort dirs 'string<)))
+			;; For each directory ...
+			(while dirs
+			  (setq directory (file-name-as-directory (car dirs)))
+			  (setq files (directory-files directory))
+			  ;; Delete the directory if it's empty.
+			  (if (catch 'done
+				(while files
+				  (setq file (car files))
+				  (if (and (not (string= file "."))
+					   (not (string= file "..")))
+				      (throw 'done nil))
+				  (setq files (cdr files))
+				  )
+				t)
+			      (delete-directory directory))
+			  (setq dirs (cdr dirs))
+			  )
+			)
+		    (setq default-directory orig-default-directory)
+		    )))
+	    )
+	  (kill-buffer tmpbuf)
+	  ;; Delete the MANIFEST file
+	  (set-file-modes manifest-file 438) ;; 438 -> #o666
+	  (delete-file manifest-file)
+	  (message "Removing old files for package \"%s\" ... done" package)
+	  )
+      (progn
+	;; The manifest file doesn't exist.  Fallback to just deleting the
+	;; package-specific lisp directory, if it exists.
+	;;
+	;; Delete old lisp directory, if any
+	;; Gads, this is ugly.  However, we're not supposed to use `concat'
+	;; in the name of portability.
+	(if (setq package-lispdir (package-admin-get-lispdir pkg-topdir
+							     package))
+	    (progn
+	      (message "Removing old lisp directory \"%s\" ..."
+		       package-lispdir)
+	      (sit-for 0)
+	      (package-admin-rmtree package-lispdir)
+	      (message "Removing old lisp directory \"%s\" ... done"
+		       package-lispdir)
+	      ))
+	))
+    ;; Delete the package from the database of installed packages.
+    (package-delete-name package)
+    ))
+
 (provide 'package-admin)
 
 ;;; package-admin.el ends here