Index: lisp/packages.el =================================================================== RCS file: /users/darrylo/sources/.repository/xemacs-21.0/lisp/packages.el,v retrieving revision 1.6 retrieving revision 1.7 diff -c -r1.6 -r1.7 *** packages.el 1998/08/28 02:35:10 1.6 --- packages.el 1998/09/20 23:05:16 1.7 *************** *** 136,141 **** --- 136,153 ---- version name (cdr pkg))) (t t)))) + (defun package-delete-name (name) + (let (pkg) + ;; Delete ALL versions of package. + ;; This is pretty memory-intensive, as we use copy-alist when deleting + ;; package entries, to prevent side-effects in functions that call this + ;; one. + (while (setq pkg (assq name packages-package-list)) + (setq packages-package-list (delete pkg (copy-alist + packages-package-list))) + ) + )) + ;;; Build time stuff (defvar autoload-file-name "auto-autoloads.el" *************** *** 330,336 **** (and version-directory (list version-directory)) (and site-directory (list site-directory))))) ! (defvar packages-special-base-regexp "^\\(etc\\|info\\|lisp\\|lib-src\\|bin\\)$" "Special subdirectories of packages.") (defvar packages-no-package-hierarchy-regexp --- 342,348 ---- (and version-directory (list version-directory)) (and site-directory (list site-directory))))) ! (defvar packages-special-base-regexp "^\\(etc\\|info\\|lisp\\|lib-src\\|bin\\|pkginfo\\)$" "Special subdirectories of packages.") (defvar packages-no-package-hierarchy-regexp Index: lisp/package-admin.el =================================================================== RCS file: /users/darrylo/sources/.repository/xemacs-21.0/lisp/package-admin.el,v retrieving revision 1.7 retrieving revision 1.8 diff -c -r1.7 -r1.8 *** package-admin.el 1998/09/05 17:38:58 1.7 --- package-admin.el 1998/09/20 23:05:15 1.8 *************** *** 77,82 **** --- 77,107 ---- 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.") + ;;;###autoload (defun package-admin-add-single-file-package (file destdir &optional pkg-dir) "Install a single file Lisp package into XEmacs package hierarchy. *************** *** 108,113 **** --- 133,139 ---- to buffer BUF." (let (filename) (setq filename (expand-file-name file pkg-dir)) + ;; Don't assume GNU tar. (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buf) 0 1) *************** *** 122,136 **** pkg-dir ) ;;;###autoload (defun package-admin-add-binary-package (file &optional pkg-dir) "Install a pre-bytecompiled XEmacs package into package hierarchy." (interactive "fPackage tarball: ") - (setq pkg-dir (package-admin-get-install-dir pkg-dir)) (let ((buf (get-buffer-create package-admin-temp-buffer)) (status 1) start err-list ) ;; Insure that the current directory doesn't change (save-excursion (set-buffer buf) --- 148,298 ---- pkg-dir ) + (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) + )) + + (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) + (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)) + + ;; We really should compute the regexp. + ;; However, directory-sep-char is currently broken, but we need + ;; functional code *NOW*. + (setq regexp "\\bpkginfo[\\/]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", "man", "info", or "etc". + ;; 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) + (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. + + ;; 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 + (sort-lines nil (point-min) (point-max)) + ;; 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. + )) + )) + ) + ;; Restore old case-fold-search status + (setq case-fold-search old-case-fold-search)) + )) + ;;;###autoload (defun package-admin-add-binary-package (file &optional pkg-dir) "Install a pre-bytecompiled XEmacs package into package hierarchy." (interactive "fPackage tarball: ") (let ((buf (get-buffer-create package-admin-temp-buffer)) (status 1) start err-list ) + (setq pkg-dir (package-admin-get-install-dir pkg-dir)) ;; Insure that the current directory doesn't change (save-excursion (set-buffer buf) *************** *** 140,159 **** (goto-char (setq start (point-max))) (if (= 0 (setq status (funcall package-admin-install-function file pkg-dir buf))) ! (catch 'done ! (goto-char start) ! (setq err-list package-admin-error-messages) ! (while err-list ! (if (re-search-forward (car err-list) nil t) ! (progn ! (setq status 1) ! (throw 'done nil) ! )) ! (setq err-list (cdr err-list)) ) )) ) status )) (provide 'package-admin) --- 302,468 ---- (goto-char (setq start (point-max))) (if (= 0 (setq status (funcall package-admin-install-function file pkg-dir buf))) ! (progn ! ;; First, check for errors. ! ;; We can't necessarily rely upon process error codes. ! (catch 'done ! (goto-char start) ! (setq err-list package-admin-error-messages) ! (while err-list ! (if (re-search-forward (car err-list) nil t) ! (progn ! (setq status 1) ! (throw 'done nil) ! )) ! (setq err-list (cdr err-list)) ! ) ) + ;; Make sure that the MANIFEST file exists + (package-admin-check-manifest buf pkg-dir) )) ) status + )) + + (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) + )) + )) + + (defun package-admin-get-lispdir (pkg-topdir package) + (let (package-lispdir) + (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir)) + (setq package-lispdir (expand-file-name (symbol-name package) + package-lispdir)) + (file-accessible-directory-p 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) + (if (not pkg-topdir) + (setq pkg-topdir (package-admin-get-install-dir nil))) + (setq manifest-file (package-admin-get-manifest-file pkg-topdir package)) + (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) + (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))) + 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) + ) + ;; Delete empty directories. + (if dirs + (let ( (orig-default-directory default-directory) + directory files file ) + ;; Make sure we preserve the existing `default-directory'. + (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)) + ) + ) + (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 + ;; 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 + package)) + (progn + (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) )) (provide 'package-admin) Index: lisp/package-get.el =================================================================== RCS file: /users/darrylo/sources/.repository/xemacs-21.0/lisp/package-get.el,v retrieving revision 1.19 retrieving revision 1.20 diff -c -r1.19 -r1.20 *** package-get.el 1998/09/05 17:38:58 1.19 --- package-get.el 1998/09/20 23:05:15 1.20 *************** *** 162,214 **** "*After copying and installing a package, if this is T, then remove the copy. Otherwise, keep it around.") - (defun package-get-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-get-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) - )) - )) - - ;;;###autoload - (defun package-get-update-all () - "Fetch and install the latest versions of all currently installed packages." - (interactive) - ;; Load a fresh copy - (catch 'exit - (mapcar (lambda (pkg) - (if (not (package-get (car pkg) nil 'never)) - (throw 'exit nil) ;; Bail out if error detected - )) - packages-package-list))) - (defun package-get-interactive-package-query (get-version package-symbol) "Perform interactive querying for package and optional version. Query for a version if GET-VERSION is non-nil. Return package name as --- 162,167 ---- *************** *** 245,250 **** --- 198,223 ---- ))) ;;;###autoload + (defun package-get-delete-package (package &optional pkg-topdir) + "Delete an installation of PACKAGE below directory PKG-TOPDIR. + PACKAGE is a symbol, not a string. + This is just an interactive wrapper for `package-admin-delete-binary-package'." + (interactive (package-get-interactive-package-query nil t)) + (package-admin-delete-binary-package package pkg-topdir)) + + ;;;###autoload + (defun package-get-update-all () + "Fetch and install the latest versions of all currently installed packages." + (interactive) + ;; Load a fresh copy + (catch 'exit + (mapcar (lambda (pkg) + (if (not (package-get (car pkg) nil 'never)) + (throw 'exit nil) ;; Bail out if error detected + )) + packages-package-list))) + + ;;;###autoload (defun package-get-all (package version &optional fetched-packages) "Fetch PACKAGE with VERSION and all other required packages. Uses `package-get-base' to determine just what is required and what *************** *** 366,372 **** (search-dirs package-get-remote) (base-filename (package-get-info-prop this-package 'filename)) (package-status t) ! filenames full-package-filename package-lispdir) (if (null this-package) (error "Couldn't find package %s with version %s" package version)) --- 339,345 ---- (search-dirs package-get-remote) (base-filename (package-get-info-prop this-package 'filename)) (package-status t) ! filenames full-package-filename) (if (null this-package) (error "Couldn't find package %s with version %s" package version)) *************** *** 466,484 **** 'md5sum))) (error "Package %s does not match md5 checksum" base-filename))) ! ;; Now delete old lisp directory, if any ! ;; ! ;; Gads, this is ugly. However, we're not supposed to use `concat' ! ;; in the name of portability. ! (if (and (setq package-lispdir (expand-file-name "lisp" install-dir)) ! (setq package-lispdir (expand-file-name (symbol-name package) ! package-lispdir)) ! (file-accessible-directory-p package-lispdir)) ! (progn ! (message "Removing old lisp directory \"%s\" ..." package-lispdir) ! (sit-for 0) ! (package-get-rmtree package-lispdir) ! )) (message "Installing package `%s' ..." package) (sit-for 0) (let ((status --- 439,445 ---- 'md5sum))) (error "Package %s does not match md5 checksum" base-filename))) ! (package-admin-delete-binary-package package install-dir) (message "Installing package `%s' ..." package) (sit-for 0) (let ((status *************** *** 489,495 **** ;; clear messages so that only messages from ;; package-get-init-package are seen, below. (clear-message) ! (if (package-get-init-package package-lispdir) (progn (message "Added package `%s'" package) (sit-for 0) --- 450,457 ---- ;; clear messages so that only messages from ;; package-get-init-package are seen, below. (clear-message) ! (if (package-get-init-package (package-admin-get-lispdir ! install-dir package)) (progn (message "Added package `%s'" package) (sit-for 0) *************** *** 581,589 **** (if (not (file-exists-p package-get-dir)) (make-directory package-get-dir)) (expand-file-name ! (file-name-nondirectory (or (nth 2 (efs-ftp-path filename)) filename)) (file-name-as-directory package-get-dir))) - (defun package-get-remote-filename (search filename) "Return FILENAME as a remote filename. --- 543,552 ---- (if (not (file-exists-p package-get-dir)) (make-directory package-get-dir)) (expand-file-name ! (file-name-nondirectory (or (and (fboundp 'efs-ftp-path) ! (nth 2 (efs-ftp-path filename))) ! filename)) (file-name-as-directory package-get-dir))) (defun package-get-remote-filename (search filename) "Return FILENAME as a remote filename.