Skip to content
Snippets Groups Projects
Commit 71c19754 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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.
parent 1f2e0edf
No related branches found
No related tags found
No related merge requests found
;;; -*- 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
......
......@@ -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)))
......
......@@ -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))))))
......
......@@ -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)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment