From 71c19754075e300cb1a7ee65afff45f3c984e17c Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 7 May 2015 02:18:54 -0400
Subject: [PATCH] Fix chdir, getcwd, run-program on ABCL, add tests.

The JVM doesn't give access to native chdir without some extensions that
aren't available with ABCL. There's a user.dir system property whereby
some Java programs kind of fake it, but ABCL doesn't play nice with it.
Therefore, use *default-pathname-defaults* as our "current directory",
and be sure to chdir to it before to run commands with run-program.
Try to make the run-program chdir feature work on Windows.
---
 test/test-utilities.script | 12 ++++++++++++
 uiop/os.lisp               |  8 ++------
 uiop/pathname.lisp         | 11 +++++++----
 uiop/run-program.lisp      | 26 ++++++++++++--------------
 4 files changed, 33 insertions(+), 24 deletions(-)

diff --git a/test/test-utilities.script b/test/test-utilities.script
index e030fab62..b7260a55f 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -1,9 +1,21 @@
 ;;; -*- Lisp -*-
 
+(defun getcwd-from-run-program ()
+  (uiop:parse-native-namestring
+   (run-program
+    (os-cond ((os-unix-p) "pwd") ((os-windows-p) "echo %cd%"))
+    :output '(:string :stripped t))
+   :ensure-directory t))
+
 (chdir *asdf-directory*)
 (assert (pathname-equal *asdf-directory* (getcwd)))
+(assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
+(assert (probe-file* "asdf.asd"))
+
 (chdir *test-directory*)
 (assert (pathname-equal *test-directory* (getcwd)))
+(assert (pathname-equal *test-directory* (getcwd-from-run-program)))
+(assert (probe-file* "test-utilities.script"))
 
 (assert
  (every #'directory-pathname-p
diff --git a/uiop/os.lisp b/uiop/os.lisp
index 173f61cfe..66d6fc6f0 100644
--- a/uiop/os.lisp
+++ b/uiop/os.lisp
@@ -271,9 +271,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
 
   (defun getcwd ()
     "Get the current working directory as per POSIX getcwd(3), as a pathname object"
-    (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
-                          (java:jstatic "getProperty" "java.lang.System" "user.dir")
-                          :ensure-directory t))
+    (or #+(or abcl genera) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
         #+allegro (excl::current-directory)
         #+clisp (ext:default-directory)
         #+clozure (ccl:current-directory)
@@ -282,7 +280,6 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
         #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
         #+(or clasp ecl) (ext:getcwd)
         #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
-        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
         #+lispworks (hcl:get-working-directory)
         #+mkcl (mk-ext:getcwd)
         #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
@@ -292,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
   (defun chdir (x)
     "Change current directory, as per POSIX chdir(2), to a given pathname object"
     (if-let (x (pathname x))
-      #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
+      #+(or abcl genera) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
       #+allegro (excl:chdir x)
       #+clisp (ext:cd x)
       #+clozure (setf (ccl:current-directory) x)
@@ -301,7 +298,6 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
                      (error "Could not set current directory to ~A" x))
       #+(or clasp ecl) (ext:chdir x)
       #+gcl (system:chdir x)
-      #+genera (setf *default-pathname-defaults* x)
       #+lispworks (hcl:change-directory x)
       #+mkcl (mk-ext:chdir x)
       #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index f56a4ea62..debc5c69e 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -203,9 +203,12 @@ when merging, making or parsing pathnames"
 when merging, making or parsing pathnames")
 
   (defmacro with-pathname-defaults ((&optional defaults) &body body)
-    "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible
-when merging, making or parsing pathnames"
-    `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
+    "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
+where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except on ABCL and Genera,
+where it remains unchanged for it doubles as current-directory."
+    `(let ((*default-pathname-defaults*
+             ,(or defaults #-(or abcl genera) '*nil-pathname* #+(or abcl genera) '*default-pathname-defaults*)))
+       ,@body)))
 
 
 ;;; Some pathname predicates
@@ -572,7 +575,7 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
          (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
          (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
          (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
-         (with-pathname-defaults ()
+         (with-pathname-defaults (*nil-pathname*)
            (let ((enough (enough-namestring maybe-subpath base-pathname)))
              (and (relative-pathname-p enough) (pathname enough))))))
 
diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp
index 3bf5222a3..fa4d39613 100644
--- a/uiop/run-program.lisp
+++ b/uiop/run-program.lisp
@@ -756,19 +756,18 @@ It returns a process-info plist with possible keys:
                (when pathname
                  (list operator " "
                        (escape-shell-token (native-namestring pathname)))))))
-      (multiple-value-bind (before after)
-          (let ((normalized (%normalize-system-command command)))
-            (os-cond
-             ((os-unix-p) (values '("exec") (list " ; " normalized)))
-             (t (values (list normalized) ()))))
+      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
+             (normalized (%normalize-system-command command))
+             (directory (or directory #+abcl (getcwd)))
+             (chdir (when directory
+                      (let ((dir-arg (escape-shell-token (native-namestring directory))))
+                        (os-cond
+                         ((os-unix-p) `("cd " ,dir-arg " ; "))
+                         ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
         (reduce/strcat
-         (append
-          before (redirect in " <") (redirect out " >") (redirect err " 2>")
-          (os-cond
-           ((os-unix-p)
-            (when directory ;; NB: unless on Unix, %system uses with-current-directory
-              `(" ; cd " ,(escape-shell-token (native-namestring directory))))))
-          after)))))
+         (os-cond
+          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
+          ((os-windows-p) `(,@chdir @redirections ,normalized)))))))
 
   (defun %system (command &rest keys
                   &key input output error-output directory &allow-other-keys)
@@ -881,8 +880,7 @@ or an indication of failure via the EXIT-CODE of the process"
     (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
       (apply (if (or force-shell
                      #+(or clasp clisp ecl) (or (not ignore-error-status) t)
-                     #+clisp (eq error-output :interactive)
-                     #+(or abcl clisp) (eq :error-output :output)
+                     #+clisp (member error-output '(:interactive :output))
                      #+(and lispworks os-unix) (%interactivep input output error-output)
                      #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
                  '%use-system '%use-run-program)
-- 
GitLab