;;; 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 <steve@xemacs.org>
;; Keywords: internal
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.
-`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)))
-
(defun package-admin-install-function-mswindows (file pkg-dir buffer)
"Install function for mswindows."
(let ((default-directory (file-name-as-directory pkg-dir)))
;; 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 (substring (car path-list) -16)
+ (concat "xemacs-packages" (char-to-string directory-sep-char)))
+ (setq top-dir (car path-list)))
+ (setq path-list (cdr path-list))))
+ ((eq type 'mule)
+ (while path-list
+ (if (equal (substring (car path-list) -14)
+ (concat "mule-packages" (char-to-string directory-sep-char)))
+ (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 (substring (car path-list) -16)
+ (concat "xemacs-packages" (char-to-string directory-sep-char)))
+ (setq top-dir (car path-list)))
+ (setq path-list (cdr path-list))))
+ ((eq type 'mule)
+ (while path-list
+ (if (equal (substring (car path-list) -14)
+ (concat "mule-packages" (char-to-string directory-sep-char)))
+ (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.<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)
+ (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))
;; 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)))
(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.<pkgname>
(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)
(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
(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.
(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)
;; 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)
;; 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)))
projects / chise / xemacs-chise.git.1 / blobdiff