xemacs-beta: lisp/package-admin.el comparison

comparison lisp/package-admin.el @ 318:afd57c14dfc8 r21-0b57

Import from CVS: tag r21-0b57

author	cvs
date	Mon, 13 Aug 2007 10:45:36 +0200
parents	341dac730539
children	19dcec799385

comparison

equal deleted inserted replaced

-:a2fc9afbef65
+:afd57c14dfc8
 found.
 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.
 `file' should be the full path to the lisp file to install.
 `destdir' should be a simple directory name.
 "Default function to install a package.
 Install package FILENAME into directory PKG-DIR, with any messages output
 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)
 ))
 (error "No package path"))
 (setq pkg-dir (car (last late-packages))))
 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)
 (setq default-directory pkg-dir)
 (setq case-fold-search t)
 (buffer-disable-undo)
 (goto-char (setq start (point-max)))
 (if (= 0 (setq status (funcall package-admin-install-function
 				     file pkg-dir buf)))
-	  (catch 'done
+	  (progn
-	    (goto-char start)
+	    ;; First, check for errors.
-	    (setq err-list package-admin-error-messages)
+	    ;; We can't necessarily rely upon process error codes.
-	    (while err-list
+	    (catch 'done
-	      (if (re-search-forward (car err-list) nil t)
+	      (goto-char start)
-		  (progn
+	      (setq err-list package-admin-error-messages)
-		    (setq status 1)
+	      (while err-list
-		    (throw 'done nil)
+		(if (re-search-forward (car err-list) nil t)
-		    ))
+		    (progn
-	      (setq err-list (cdr err-list))
+		      (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

Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 318:afd57c14dfc8 r21-0b57