[asdf-install-devel] Revised patch for tar handling

[Dan Muller]

This is a revised patch for more flexibility in configuring tar
extraction. It supercedes the one that I offered a week ago. Unlike
that one, this patch makes no changes to external behavior unless you
do something like this prior to using ASDF-INSTALL:

(pushnew
 'asdf-install:extract-using-tar
  asdf-install:*tar-extractors*)


Summary of changes, relative to the version of ASDF-INSTALL publically
available as a tar ball:

- Added exported variables *TAR-PROGRAM*, *TAR-OPTIONS*.

- Renamed internal EXTRACT-USING-TAR to
  EXTRACT-USING-GNU-TAR. *TAR-EXTRACTORS* is initialized to a list
  containing this symbol.

- Provided a new, exported EXTRACT-USING-TAR which uses *TAR-PROGRAM*
  and *TAR-OPTIONS*.

- Changed internal *SHELL-SEARCH-PATHS* to a list of pathnames. On
  Windows, this is now initialized from the user's PATH.

- Modified internal find-shell-command to match changes to
  *SHELL-SEARCH-PATHS*.

- Fixed a problem in internal method DIRECTORIFY. (I think -- haven't
  tested on UNIX yet.)

- Added missing load of variables.lisp to load-asdf-install.lisp.

  -- Dan Muller

Patch starts here:
Index: asdf-install/asdf-install/defpackage.lisp
===================================================================
--- asdf-install/asdf-install/defpackage.lisp	(revision 141)
+++ asdf-install/asdf-install/defpackage.lisp	(working copy)
@@ -14,6 +14,8 @@
    #:asdf-install-dirs
    #:private-asdf-install-dirs
    #:*tar-extractors*
+   #:*tar-program*
+   #:*tar-options*
 
    #:*shell-search-paths*
    #:*verify-gpg-signatures*
@@ -28,6 +30,7 @@
    #:uninstall
    #:install
    #:asdf-install-version
+   #:extract-using-tar
 
    #+(and asdf (or :win32 :mswindows))
    #:sysdef-source-dir-search   
Index: asdf-install/asdf-install/installer.lisp
===================================================================
--- asdf-install/asdf-install/installer.lisp	(revision 141)
+++ asdf-install/asdf-install/installer.lisp	(working copy)
@@ -276,8 +276,7 @@
 
 (defun find-shell-command (command)
   (loop for directory in *shell-search-paths* do
-       (let ((target (make-pathname :name command :type nil
-				    :directory directory)))
+       (let ((target (merge-pathnames (pathname command) directory)))
 	 (when (probe-file target)
 	   (return-from find-shell-command (namestring target)))))
   (values nil))
@@ -302,13 +301,28 @@
   (list "-C" (ext:unix-namestring (truename source))
 	"-xzvf" (ext:unix-namestring (truename packagename))))
 
-(defun extract-using-tar (to-dir tarball)
+;;; This is the original method of extracting tar files. It is kept
+;;; for backwards compatibility.
+(defun extract-using-gnu-tar (to-dir tarball)
   (let ((tar-command (tar-command)))
     (if (and tar-command (probe-file tar-command))
 	(return-output-from-program tar-command
 				    (tar-arguments to-dir tarball))
 	(warn "Cannot find tar command ~S." tar-command))))
 
+;;; This is a newer method for extracting tarballs. Should work for
+;;; most people on any system using Gnu tar, including Cygwin,
+;;; provided the program is in the path. Simply push this on
+;;; ASDF-INSTALL:*TAR-EXTRACTOR* in order to use it.
+(defun extract-using-tar (to-dir tarball)
+  (let ((tar-command (find-shell-command *tar-program*)))
+    (when (and tar-command (probe-file tar-command))
+	(return-output-from-program
+         tar-command
+         (substitute (namestring (truename to-dir)) :OUTPUT
+                     (substitute (namestring (truename tarball)) :INPUT
+				 *tar-options*))))))
+
 (defun extract (to-dir tarball)
   (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
             *tar-extractors*)
Index: asdf-install/asdf-install/variables.lisp
===================================================================
--- asdf-install/asdf-install/variables.lisp	(revision 141)
+++ asdf-install/asdf-install/variables.lisp	(working copy)
@@ -6,9 +6,8 @@
   (let ((path (pathname name)))
     (if (pathname-name path)
 	(merge-pathnames
-	 (make-pathname :directory `(:relative ,(pathname-name path))
-			:name "")
-	 path)
+	 (make-pathname :directory `(:relative ,(pathname-name path)))
+	 (make-pathname :host (pathname-host path) :device (pathname-device path) :directory (pathname-directory path)))
 	path)))
 
 #+:digitool
@@ -46,16 +45,43 @@
 (defvar *cygwin-bash-program*
   "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe")
 
+(defvar *shell-search-paths*
+
+  #-(or :win32 :mswindows)
 ;; bin first
-(defvar *shell-search-paths* '((:absolute "bin")
-                               (:absolute "usr" "bin"))
-  "A list of places to look for shell commands.")
+  (list (make-pathname :directory '(:absolute "bin"))
+        (make-pathname :directory '(:absolute "usr" "bin")))
 
+  ;; On Windows, there's no notion of standard paths containing other
+  ;; than OS components. Simply use the same path that the user does.
+  #+(or :win32 :mswindows)
+  (loop
+     for path = (get-env-var "PATH")
+     then (subseq path (1+ (or (position #\; path) (1- (length path)))))
+     for elem = (subseq path 0 (position #\; path))
+     while (plusp (length elem))
+     collect (directorify elem))
+  "A list of places to look for shell commands, as pathnames.")
+
 (defvar *gnu-tar-program*
   #-(or :netbsd :freebsd :solaris) "tar"
   #+(or :netbsd :freebsd :solaris) "gtar"
   "Path to the GNU tar program")
 
+(defvar *tar-program*
+  #-(or :netbsd :freebsd :solaris :win32 :mswindows) "tar"
+  #+(or :netbsd :freebsd :solaris) "gtar"
+  #+(or :win32 :mswindows) "tar.exe"
+  "File name of the tar program; defaults to Gnu tar on some systems.
+ Used by extract-using-tar, which is not the default tar extraction method.")
+
+(defvar *tar-options*
+  '("--force-local" "-xzv" "-C" :OUTPUT "-f" :INPUT)
+  "Options for the tar program, as a list. The symbols :INPUT and :OUTPUT
+ will be replaced by the input file name and the output directory,
+ respectively. Used by extract-using-tar, which is not the default tar
+ extraction method.")
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defparameter *supported-defsystems*
     (list :mk-defsystem
@@ -104,7 +130,7 @@
      "Personal installation")))
 
 (defvar *tar-extractors*
-  '(extract-using-tar))
+  '(extract-using-gnu-tar))
 
 (defvar *systems-installed-this-time* nil
   "Used during installation propagation \(see *propagate-installation*\) to keep track off which systems have been installed during the current call to install.")
Index: asdf-install/asdf-install/load-asdf-install.lisp
===================================================================
--- asdf-install/asdf-install/load-asdf-install.lisp	(revision 145)
+++ asdf-install/asdf-install/load-asdf-install.lisp	(working copy)
@@ -69,6 +69,7 @@
       (unless (find-package '#:split-sequence)
         (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp"))
 
+      (load-and-or-compile "ASDF-INSTALL-LIBRARY:variables.lisp")
       (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
 
       ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp")