X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fpackage-admin.el;h=0dd306639da687eeb274021b674b0b9c0c48c928;hp=d13a853b12297f4c4329e8296e0cbd9aeb62866e;hb=4217f715cf3120a5591ce18f6ad90be7d6df465d;hpb=14144012929ab5944f367d5d1b323ab8268abb05 diff --git a/lisp/package-admin.el b/lisp/package-admin.el index d13a853..0dd3066 100644 --- a/lisp/package-admin.el +++ b/lisp/package-admin.el @@ -1,6 +1,7 @@ ;;; package-admin.el --- Installation and Maintenance of XEmacs packages ;; Copyright (C) 1997 by Free Software Foundation, Inc. +;; Copyright (C) 2003, Steve Youngs. ;; Author: SL Baur ;; Keywords: internal @@ -104,24 +105,15 @@ 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. -The optional `pkg-dir' can be used to override the default package hierarchy -\(car \(last late-packages))." - (interactive "fLisp File: \nsDestination: ") - (when (null pkg-dir) - (setq pkg-dir (car (last late-packages)))) - (let ((destination (concat pkg-dir "/lisp/" destdir)) - (buf (get-buffer-create package-admin-temp-buffer))) - (call-process "add-little-package.sh" - nil - buf - t - ;; rest of command line follows - package-admin-xemacs file destination))) +(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.") (defun package-admin-install-function-mswindows (file pkg-dir buffer) "Install function for mswindows." @@ -142,80 +134,197 @@ to BUFFER." ;; Don't assume GNU tar. (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer) 0 - 1) - )) - -; (call-process "add-big-package.sh" -; nil -; buffer -; t -; ;; rest of command line follows -; package-admin-xemacs file 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 + 1))) + +;; A few things needed by the following 2 functions. +(eval-when-compile + (require 'packages) + (autoload 'package-get-info "package-get") + (autoload 'paths-decode-directory-path "find-paths") + (defvar package-get-install-to-user-init-directory)) + +(defun package-admin-find-top-directory (type &optional user-dir) + "Return the top level directory for a package. + +Argument TYPE is a symbol that determines the type of package we're +trying to find a directory for. + +Optional Argument USER-DIR if non-nil use directories off +`user-init-directory'. This overrides everything except +\"EMACSPACKAGEPATH\". + +This function honours the environment variable \"EMACSPACKAGEPATH\" +and returns directories found there as a priority. If that variable +doesn't exist and USER-DIR is nil, check in the normal places. + +If we still can't find a suitable directory, return nil. + +Possible values for TYPE are: + + std == For \"standard\" packages that go in '/xemacs-packages/' + mule == For \"mule\" packages that go in '/mule-packages/' + site == For \"unsupported\" packages that go in '/site-packages/' + +Note: Type \"site\" is not yet fully supported." + (let* ((env-value (getenv "EMACSPACKAGEPATH")) + top-dir) + ;; First, check the environment var. + (if env-value + (let ((path-list (paths-decode-directory-path env-value 'drop-empties))) + (cond ((eq type 'std) + (while path-list + (if (equal (file-name-nondirectory + (directory-file-name (car path-list))) + "xemacs-packages") + (setq top-dir (car path-list))) + (setq path-list (cdr path-list)))) + ((eq type 'mule) + (while path-list + (if (equal (file-name-nondirectory + (directory-file-name (car path-list))) + "mule-packages") + (setq top-dir (car path-list))) + (setq path-list (cdr path-list))))))) + ;; Wasn't in the environment, try `user-init-directory' if + ;; USER-DIR is non-nil. + (if (and user-dir + (not top-dir)) + (cond ((eq type 'std) + (setq top-dir (file-name-as-directory + (expand-file-name "xemacs-packages" user-init-directory)))) + ((eq type 'mule) + (setq top-dir (file-name-as-directory + (expand-file-name "mule-packages" user-init-directory)))))) + ;; Finally check the normal places + (if (not top-dir) + (let ((path-list (nth 1 (packages-find-packages + emacs-roots + (packages-compute-package-locations user-init-directory))))) + (cond ((eq type 'std) + (while path-list + (if (equal (file-name-nondirectory + (directory-file-name (car path-list))) + "xemacs-packages") + (setq top-dir (car path-list))) + (setq path-list (cdr path-list)))) + ((eq type 'mule) + (while path-list + (if (equal (file-name-nondirectory + (directory-file-name (car path-list))) + "mule-packages") + (setq top-dir (car path-list))) + (setq path-list (cdr path-list))))))) + ;; Now return either the directory or nil. + top-dir)) + +(defun package-admin-get-install-dir (package &optional pkg-dir) + "Find a suitable installation directory for a package. + +Argument PACKAGE is the package to find a installation directory for. +Optional Argument PKG-DIR, if non-nil is a directory to use for +installation. + +If PKG-DIR is non-nil and writable, return that. Otherwise check to +see if the PACKAGE is already installed and return that location, if +it is writable. Finally, fall back to the `user-init-directory' if +all else fails. As a side effect of installing packages under +`user-init-directory' these packages become part of `early-packages'." + ;; If pkg-dir specified, return that if writable. + (if (and pkg-dir + (file-writable-p (directory-file-name 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))))))) - - + ;; If the user want her packages under ~/.xemacs/, do so. + (let ((type (package-get-info package 'category))) + (if package-get-install-to-user-init-directory + (progn + (cond ((equal type "standard") + (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir))) + ((equal type "mule") + (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))) + pkg-dir) + ;; Maybe the package has been installed before, if so, return + ;; that directory. + (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 (and pkg-dir + (file-writable-p (directory-file-name pkg-dir))) + pkg-dir + ;; OK, the package hasn't been previously installed so we need + ;; to guess where it should go. + (cond ((equal type "standard") + (setq pkg-dir (package-admin-find-top-directory 'std))) + ((equal type "mule") + (setq pkg-dir (package-admin-find-top-directory 'mule))) + (t + (error 'invalid-operation + "Invalid package type"))) + (if (and pkg-dir + (file-writable-p (directory-file-name pkg-dir))) + pkg-dir + ;; Oh no! Either we still haven't found a suitable + ;; directory, or we can't write to the one we did find. + ;; Drop back to the `user-init-directory'. + (if (y-or-n-p (format "Directory isn't writable, use %s instead? " + user-init-directory)) + (progn + (cond ((equal type "standard") + (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir))) + ((equal type "mule") + (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir))) + (t + (error 'invalid-operation + "Invalid package type"))) + ;; Turn on `package-get-install-to-user-init-directory' + ;; so we don't get asked for each package we try to + ;; install in this session. + (setq package-get-install-to-user-init-directory t) + pkg-dir) + ;; If we get to here XEmacs can't make up its mind and + ;; neither can the user, nothing left to do except barf. :-( + (error 'search-failed + (format + "Can't find suitable installation directory for package: %s" + package)))))))))) (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) - )) + (let ((dir (file-name-as-directory + (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. 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) + (let ((manifest-buf " *pkg-manifest*") + (old-case-fold-search case-fold-search) + regexp package-name pathname regexps) (unwind-protect (save-excursion ;; Probably redundant. - (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the - ;; current buffer. + (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\\...*") + (setq regexp (concat "\\bpkginfo" + (char-to-string directory-sep-char) + "MANIFEST\\...*")) ;; Look for the manifest. (if (not (re-search-forward regexp nil t)) @@ -224,22 +333,18 @@ is the top-level directory under which the package was installed." ;; 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". + ;; "lisp", or "man". ;; 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) + (let ((dirs '("lisp" "man")) + rexp) (while dirs (setq rexp (concat "\\b" (car dirs) "[\\/]\\([^\\/]+\\)[\//]")) (if (re-search-forward rexp nil t) (throw 'done t)) - (setq dirs (cdr dirs)) - ))) + (setq dirs (cdr dirs))))) (progn (setq package-name (buffer-substring (match-beginning 1) (match-end 1))) @@ -267,22 +372,16 @@ is the top-level directory under which the package was installed." (buffer-substring (match-beginning 1) (match-end 1))) - (throw 'found-path t) - )) - (setq regexps (cdr regexps)) - ) - ) + (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) - ) + (insert pathname "\n")))) + (forward-line 1)) ;; Processed all lines. ;; Now, create the file, pkginfo/MANIFEST. @@ -300,24 +399,18 @@ is the top-level directory under which the package was installed." (save-excursion (set-buffer manifest-buf) ;; Put the files in sorted order - (sort-lines nil (point-min) (point-max)) + (if (fboundp 'sort-lines) + (sort-lines nil (point-min) (point-max)) + (warn "`xemacs-base' not installed, MANIFEST.%s not sorted" + package-name)) ;; 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. - )) - )) - ) + (write-region (point-min) (point-max) pathname)) + (kill-buffer manifest-buf)))))) ;; Restore old case-fold-search status - (setq case-fold-search old-case-fold-search)) - )) + (setq case-fold-search old-case-fold-search)))) ;;;###autoload (defun package-admin-add-binary-package (file &optional pkg-dir) @@ -325,8 +418,7 @@ is the top-level directory under which the package was installed." (interactive "fPackage tarball: ") (let ((buf (get-buffer-create package-admin-temp-buffer)) (status 1) - start err-list - ) + start err-list) (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir)) ;; Ensure that the current directory doesn't change (save-excursion @@ -348,17 +440,11 @@ is the top-level directory under which the package was installed." (if (re-search-forward (car err-list) nil t) (progn (setq status 1) - (throw 'done nil) - )) - (setq err-list (cdr err-list)) - ) - ) + (throw 'done nil))) + (setq err-list (cdr err-list)))) ;; Make sure that the MANIFEST file exists - (package-admin-check-manifest buf pkg-dir) - )) - ) - status - )) + (package-admin-check-manifest buf pkg-dir)))) + status)) (defun package-admin-rmtree (directory) "Delete a directory and all of its contents, recursively. @@ -393,22 +479,21 @@ This is a feeble attempt at making a portable rmdir." (setq package-lispdir (expand-file-name (symbol-name package) package-lispdir)) (file-accessible-directory-p package-lispdir)) - 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) + (let (manifest-file package-lispdir dirs file) (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)) - (with-current-buffer tmpbuf + (with-temp-buffer (buffer-disable-undo) (erase-buffer) (insert-file-contents manifest-file) @@ -428,7 +513,7 @@ PACKAGE is a symbol, not a string." ;; Make sure that the file is writable. ;; (This is important under MS Windows.) ;; I do not know why it important under MS Windows but - ;; 1. It bombs out out when the file does not exist. This can be condition-cased + ;; 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 @@ -440,66 +525,31 @@ PACKAGE is a symbol, not a string." ;; Delete empty directories. (if dirs - (let ( (orig-default-directory default-directory) - ;; 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)) -; ) - ;; 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) + (progn + (mapc + (lambda (dir) + (condition-case () + (delete-directory dir))) + dirs))) ;; Delete the MANIFEST file ;; (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. - (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir - package)) - (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) - )) + (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. + (setq package-lispdir (package-admin-get-lispdir pkg-topdir package)) + (when package-lispdir + (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)))