diff lisp/package-get.el @ 318:afd57c14dfc8 r21-0b57

Import from CVS: tag r21-0b57
author cvs
date Mon, 13 Aug 2007 10:45:36 +0200
parents 512e409c26a2
children 19dcec799385
line wrap: on
line diff
--- a/lisp/package-get.el	Mon Aug 13 10:44:47 2007 +0200
+++ b/lisp/package-get.el	Mon Aug 13 10:45:36 2007 +0200
@@ -149,10 +149,7 @@
   "*Where to store temporary files for staging.")
 
 (defvar package-get-remote
-  '(
-    ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/binary-packages")
-    ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/single-file-packages")
-    ("ftp.xemacs.org" "/pub/xemacs/package"))
+  '(("ftp.xemacs.org" "/pub/xemacs/packages"))
   "*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
@@ -162,53 +159,6 @@
   "*After copying and installing a package, if this is T, then remove the
 copy.  Otherwise, keep it around.")
 
-(defun package-get-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-get-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)
-	))
-    ))
-
-;;;###autoload
-(defun package-get-update-all ()
-  "Fetch and install the latest versions of all currently installed packages."
-  (interactive)
-  ;; Load a fresh copy
-  (catch 'exit
-    (mapcar (lambda (pkg)
-	      (if (not (package-get (car pkg) nil 'never))
-		  (throw 'exit nil)		;; Bail out if error detected
-		  ))
-	    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
@@ -245,6 +195,26 @@
       )))
 
 ;;;###autoload
+(defun package-get-delete-package (package &optional pkg-topdir)
+  "Delete an installation of PACKAGE below directory PKG-TOPDIR.
+PACKAGE is a symbol, not a string.
+This is just an interactive wrapper for `package-admin-delete-binary-package'."
+  (interactive (package-get-interactive-package-query nil t))
+  (package-admin-delete-binary-package package pkg-topdir))
+
+;;;###autoload
+(defun package-get-update-all ()
+  "Fetch and install the latest versions of all currently installed packages."
+  (interactive)
+  ;; Load a fresh copy
+  (catch 'exit
+    (mapcar (lambda (pkg)
+	      (if (not (package-get (car pkg) nil 'never))
+		  (throw 'exit nil)		;; Bail out if error detected
+		  ))
+	    packages-package-list)))
+
+;;;###autoload
 (defun package-get-all (package version &optional fetched-packages)
   "Fetch PACKAGE with VERSION and all other required packages.
 Uses `package-get-base' to determine just what is required and what
@@ -366,7 +336,7 @@
 	 (search-dirs package-get-remote)
 	 (base-filename (package-get-info-prop this-package 'filename))
 	 (package-status t)
-	 filenames full-package-filename package-lispdir)
+	 filenames full-package-filename)
     (if (null this-package)
 	(error "Couldn't find package %s with version %s"
 	       package version))
@@ -466,19 +436,7 @@
 						 'md5sum)))
 	    (error "Package %s does not match md5 checksum" base-filename)))
 
-      ;; Now delete old lisp directory, if any
-      ;;
-      ;; Gads, this is ugly.  However, we're not supposed to use `concat'
-      ;; in the name of portability.
-      (if (and (setq package-lispdir (expand-file-name "lisp" install-dir))
-	       (setq package-lispdir (expand-file-name (symbol-name package)
-						       package-lispdir))
-	       (file-accessible-directory-p package-lispdir))
-	  (progn
-	    (message "Removing old lisp directory \"%s\" ..." package-lispdir)
-	    (sit-for 0)
-	    (package-get-rmtree package-lispdir)
-	    ))
+      (package-admin-delete-binary-package package install-dir)
 
       (message "Installing package `%s' ..." package) (sit-for 0)
       (let ((status
@@ -489,7 +447,8 @@
 	      ;; clear messages so that only messages from
 	      ;; package-get-init-package are seen, below.
 	      (clear-message)
-	      (if (package-get-init-package package-lispdir)
+	      (if (package-get-init-package (package-admin-get-lispdir
+					     install-dir package))
 		  (progn
 		    (message "Added package `%s'" package)
 		    (sit-for 0)
@@ -581,9 +540,10 @@
   (if (not (file-exists-p package-get-dir))
       (make-directory package-get-dir))
   (expand-file-name
-   (file-name-nondirectory (or (nth 2 (efs-ftp-path filename)) filename))
+   (file-name-nondirectory (or (and (fboundp 'efs-ftp-path)
+				    (nth 2 (efs-ftp-path filename)))
+			       filename))
    (file-name-as-directory package-get-dir)))
-       
 
 (defun package-get-remote-filename (search filename)
   "Return FILENAME as a remote filename.