+(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 BUFFER
+Install package FILENAME into directory PKG-DIR, with any messages output
+to buffer BUFFER.")
+
+(defvar package-admin-error-messages '(
+ "No space left on device"
+ "No such file or directory"
+ "Filename too long"
+ "Read-only file system"
+ "File too large"
+ "Too many open files"
+ "Not enough space"
+ "Permission denied"
+ "Input/output error"
+ "Out of memory"
+ "Unable to create directory"
+ "Directory checksum error"
+ "Cannot exclusively open file"
+ "corrupted file"
+ "incomplete .* tree"
+ "Bad table"
+ "corrupt input"
+ "invalid compressed data"
+ "too many leaves in Huffman tree"
+ "not a valid zip file"
+ "first entry not deflated or stored"
+ "encrypted file --"
+ "unexpected end of file"
+ )
+ "Regular expressions of possible error messages.
+After each package extraction, the `package-admin-temp-buffer' buffer is
+scanned for these messages. An error code is returned if one of these are
+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.")
+
+(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."
+ (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 (filename pkg-dir buffer)
+ "Default function to install a package.
+Install package FILENAME into directory PKG-DIR, with any messages output
+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 -") buffer)
+ 0
+ 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
+ ;; 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 (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 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.
+ (goto-char (point-min))
+
+ ;; Make filenames case-insensitive, if necessary
+ (if (eq system-type 'windows-nt)
+ (setq case-fold-search t))
+
+ (setq regexp (concat "\\bpkginfo"
+ (char-to-string directory-sep-char)
+ "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", 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.
+ (if (catch 'done
+ (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)))))
+ (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
+ (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))))))
+ ;; Restore old case-fold-search status
+ (setq case-fold-search old-case-fold-search))))