X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fpackage-admin.el;h=925f6de7bfc9a06be2c2492443c83483ca571d1c;hb=98f23e5a6e8247313a9c72ad8600235a9bafaa5b;hp=7099173a54dddead5de3dc19ae0b456e39e8393c;hpb=72a705551741d6f85a40eea486c222bac482d8dc;p=chise%2Fxemacs-chise.git diff --git a/lisp/package-admin.el b/lisp/package-admin.el index 7099173..925f6de 100644 --- a/lisp/package-admin.el +++ b/lisp/package-admin.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1997 by Free Software Foundation, Inc. -;; Author: SL Baur +;; Author: SL Baur ;; Keywords: internal ;; This file is part of XEmacs. @@ -38,11 +38,13 @@ (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" @@ -102,6 +104,16 @@ is already implicit, as `looking-at' is used. Filenames can, 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. @@ -121,39 +133,65 @@ The optional `pkg-dir' can be used to override the default 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. @@ -266,7 +304,7 @@ is the top-level directory under which the package was installed." ;; 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 @@ -299,11 +337,12 @@ is the top-level directory under which the package was installed." (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))) @@ -334,37 +373,29 @@ is the top-level directory under which the package was installed." (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) @@ -379,87 +410,100 @@ This is a feeble attempt at making a portable rmdir." "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) @@ -467,10 +511,8 @@ PACKAGE is a symbol, not a string." (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)