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