;; Copyright (C) 1997 by Free Software Foundation, Inc.
-;; Author: SL Baur <steve@altair.xemacs.org>
+;; Author: SL Baur <steve@xemacs.org>
;; Keywords: internal
;; This file is part of XEmacs.
(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
+(defvar package-admin-install-function (if (eq system-type 'windows-nt)
+ 'package-admin-install-function-mswindows
+ 'package-admin-default-install-function)
"The function to call to install a package.
-Three args are passed: FILENAME PKG-DIR BUF
+Three args are passed: FILENAME PKG-DIR BUFFER
Install package FILENAME into directory PKG-DIR, with any messages output
-to buffer BUF.")
+to buffer BUFFER.")
(defvar package-admin-error-messages '(
"No space left on device"
unfortunately, contain spaces, so be careful in constructing any
regexps.")
+(defvar package-install-hook nil
+ "*List of hook functions to be called when a new package is successfully
+installed. The hook function is passed two arguments: the package name, and
+the install directory.")
+
+(defvar package-delete-hook nil
+ "*List of hook functions to be called when a package is deleted. The
+hook is called *before* the package is deleted. The hook function is passed
+two arguments: the package name, and the install directory.")
+
;;;###autoload
(defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
"Install a single file Lisp package into XEmacs package hierarchy.
;; 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-install-function-mswindows (file pkg-dir buffer)
+ "Install function for mswindows."
+ (let ((default-directory (file-name-as-directory pkg-dir)))
+ (unless (file-directory-p default-directory)
+ (make-directory default-directory t))
+ (call-process "minitar" nil buffer t file)))
-(defun package-admin-default-install-function (file pkg-dir buf)
+(defun package-admin-default-install-function (filename pkg-dir buffer)
"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))
+to BUFFER."
+ (let* ((pkg-dir (file-name-as-directory pkg-dir))
+ (default-directory pkg-dir)
+ (filename (expand-file-name filename)))
+ (unless (file-directory-p pkg-dir)
+ (make-directory pkg-dir t))
;; Don't assume GNU tar.
- (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buf)
+ (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
0
1)
))
; (call-process "add-big-package.sh"
; nil
-; buf
+; buffer
; 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
- )
+(defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
+ "If PKG-DIR is non-nil return that,
+else return the current location of the package if it is already installed
+or return a location appropriate for the package otherwise."
+ (if pkg-dir
+ pkg-dir
+ (let ((package-feature (intern-soft (concat
+ (symbol-name package) "-autoloads")))
+ autoload-dir)
+ (when (and (not (eq package 'unknown))
+ (featurep package-feature)
+ (setq autoload-dir (feature-file package-feature))
+ (setq autoload-dir (file-name-directory autoload-dir))
+ (member autoload-dir (append early-package-load-path late-package-load-path)))
+ ;; Find the corresponding entry in late-package
+ (setq pkg-dir
+ (car-safe (member-if (lambda (h)
+ (string-match (concat "^" (regexp-quote h))
+ autoload-dir))
+ (append (cdr early-packages) late-packages)))))
+ (if pkg-dir
+ pkg-dir
+ ;; Ok we need to guess
+ (if mule-related
+ (package-admin-get-install-dir 'mule-base nil nil)
+ (if (eq package 'xemacs-base)
+ (car (last late-packages))
+ (package-admin-get-install-dir 'xemacs-base nil nil)))))))
+
+
(defun package-admin-get-manifest-file (pkg-topdir package)
"Return the name of the MANIFEST file for package PACKAGE.
;; Create pkginfo, if necessary
(if (not (file-directory-p pathname))
(make-directory pathname))
- (setq pathname (expand-file-name
+ (setq pathname (expand-file-name
(concat "MANIFEST." package-name)
pathname))
(save-excursion
(status 1)
start err-list
)
- (setq pkg-dir (package-admin-get-install-dir pkg-dir))
- ;; Insure that the current directory doesn't change
+ (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
+ ;; Ensure that the current directory doesn't change
(save-excursion
(set-buffer buf)
- (setq default-directory pkg-dir)
+ ;; This is not really needed
+ (setq default-directory (file-name-as-directory pkg-dir))
(setq case-fold-search t)
(buffer-disable-undo)
(goto-char (setq start (point-max)))
(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)
- ))
- ))
+ (setq directory (file-name-as-directory directory))
+ (let ((files (directory-files directory nil nil nil t))
+ (dirs (directory-files directory nil nil nil 'dirs)))
+ (while dirs
+ (if (not (member (car dirs) '("." "..")))
+ (let ((dir (expand-file-name (car dirs) directory)))
+ (condition-case err
+ (if (file-symlink-p dir) ;; just in case, handle symlinks
+ (delete-file dir)
+ (package-admin-rmtree dir))
+ (file-error
+ (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
+ (setq dirs (cdr dirs))))
+ (while files
+ (condition-case err
+ (delete-file (expand-file-name (car files) directory))
+ (file-error
+ (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
+ (setq files (cdr files)))
+ (condition-case err
+ (delete-directory directory)
+ (file-error
+ (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
(defun package-admin-get-lispdir (pkg-topdir package)
(let (package-lispdir)
"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 pkg-topdir (package-admin-get-install-dir package pkg-topdir))
(setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
+ (run-hook-with-args 'package-delete-hook package pkg-topdir)
(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)
+ (with-current-buffer tmpbuf
+ (buffer-disable-undo)
+ (erase-buffer)
(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)))
+ (point-at-eol))
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)
- )
+ ;; I do not know why it important under MS Windows but
+ ;; 1. It bombs out when the file does not exist. This can be condition-cased
+ ;; 2. If I removed the write permissions, I do not want XEmacs to just ignore them.
+ ;; If it wants to, XEmacs may ask, but that is about all
+ ;; (set-file-modes file 438) ;; 438 -> #o666
+ ;; Note, user might have removed the file!
+ (condition-case ()
+ (delete-file file)
+ (error nil))) ;; We may want to turn the error into a Warning?
+ (forward-line 1))
+
;; Delete empty directories.
(if dirs
(let ( (orig-default-directory default-directory)
- directory files file )
+ ;; directory files file
+ )
;; Make sure we preserve the existing `default-directory'.
+ ;; JV, why does this change the default directory? Does it indeed?
(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))
- )
- )
+; ;; 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))
+; )
+ ;; JV, On all OS's that I know of delete-directory fails on
+ ;; on non-empty dirs anyway
+ (mapc
+ (lambda (dir)
+ (condition-case ()
+ (delete-directory dir)))
+ 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
+ ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
+ ;; Note. Packages can have MANIFEST in MANIFEST.
+ (condition-case ()
+ (delete-file manifest-file)
+ (error nil)) ;; Do warning?
+ (message "Removing old files for package \"%s\" ... done" package))
;; 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
+ (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir
package))
- (progn
(message "Removing old lisp directory \"%s\" ..."
package-lispdir)
(sit-for 0)
(message "Removing old lisp directory \"%s\" ... done"
package-lispdir)
))
- ))
;; Delete the package from the database of installed packages.
- (package-delete-name package)
- ))
+ (package-delete-name package)))
(provide 'package-admin)
projects / chise / xemacs-chise.git.1 / blobdiff