Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Jan Moringen
asdf
Commits
40a89c19
Commit
40a89c19
authored
Nov 25, 2016
by
Robert Goldman
Browse files
Merge branch 'run-program-windows' into 'master'
Run program windows Various fixes for Windows. See merge request !52
parents
58968bce
ea467d96
Changes
10
Hide whitespace changes
Inline
Side-by-side
README.md
View file @
40a89c19
...
...
@@ -109,7 +109,7 @@ as in for instance:
Or you can make that your local default (assuming GNU make) using:
ln -s
Makefile-lisp-scripting GNUmakefile
echo "include
Makefile-lisp-scripting
" >
GNUmakefile
These Lisp tools by default use Clozure Common Lisp (CCL) to build and run a binary
`build/asdf-tools`
that will orchestrate the tests.
...
...
backward-interface.lisp
View file @
40a89c19
...
...
@@ -155,6 +155,7 @@ output to *VERBOSE-OUT*. Returns the shell's exit code.
PLEASE DO NOT USE.
Deprecated function, for backward-compatibility only.
Please use UIOP:RUN-PROGRAM instead."
#-
(
and
ecl
os-windows
)
(
let
((
command
(
apply
'format
nil
control-string
args
)))
(
asdf-message
"; $ ~A~%"
command
)
(
let
((
exit-code
...
...
@@ -163,7 +164,10 @@ Please use UIOP:RUN-PROGRAM instead."
:output
*verbose-out*
)))))
(
typecase
exit-code
((
integer
0
255
)
exit-code
)
(
t
255
))))))
(
t
255
))))
#+
(
and
ecl
os-windows
)
(
not-implemented-error
"run-shell-command"
"for ECL on Windows."
)
))
(
with-upgradability
()
...
...
make-asdf.bat
View file @
40a89c19
...
...
@@ -8,7 +8,7 @@ set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp +
set
defsystem_lisp
=
upgrade
.lisp
+
cache
.lisp
+
component
.lisp
+
system
.lisp
+
find
-system
.lisp
+
find
-component
.lisp
+
operation
.lisp
+
action
.lisp
+
lisp
-action
.lisp
+
plan
.lisp
+
operate
.lisp
+
parse
-defsystem
.lisp
+
bundle
.lisp
+
concatenate
-source
.lisp
+
output
-translations
.lisp
+
source
-registry
.lisp
+
package
-inferred-system
.lisp
+
backward
-interface
.lisp
+
backward
-internals
.lisp
+
interface
.lisp
+
user
.lisp
+
footer
.lisp
%~d0
cd
%~p0
cd
"
%~p0
"
if
"
%
~1"
==
""
goto
all
if
"
%
~1"
==
"all"
goto
all
...
...
@@ -19,8 +19,8 @@ if "%~1"=="noext" goto noext
if
"
%
~1"
==
"driver_files"
goto
driver_files
if
"
%
~1"
==
"defsystem_files"
goto
defsystem_files
call
%
0
build_asdf_tools
%here%
\build\asdf
-tools
.exe
env
%
*
call
"
%
0
"
build_asdf_tools
"
%here%
\build\asdf-tools.exe
"
env
%
*
goto
end
...
...
@@ -40,9 +40,9 @@ goto end
:build
_asdf_tools
:: Building a binary for asdf-tools
if
exist
s
build
\asdf
-tools
.exe
goto
end
call
%
0
build_asdf
%here%
\tools\asdf
-tools
.bat
build
-asdf-tools
if
exist
build
\asdf
-tools
.exe
goto
end
call
"
%
0
"
build_asdf
"
%here%
\tools\asdf-tools.bat
"
build
-asdf-tools
goto
end
:clobber
...
...
test/asdf-pathname-test.script
View file @
40a89c19
;;; -*- Lisp -*-
(in-package :asdf-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or xcl gcl) (push :asdf-test-logical-pathname *features*)
...
...
@@ -469,9 +470,9 @@
(test-pathname-parsing)
;;; test for CMUCL issue with search lists versus pathnames
(DBG "Checking CMUCL user-homedir-pathname issue.")
(
assert
(
multiple-value-bind (value error
)
(ignore-errors
(
pathname-match-p (uiop::user-homedir-pathname) (uiop:getenv "HOME"))
)
(
null error
)))
#+os-unix
(
progn
(
DBG "Checking CMUCL user-homedir-pathname issue."
)
(assert-pathname-equal
(
uiop/common-lisp:user-homedir-pathname
)
(
getenv-pathname "HOME" :want-directory t
)))
test/test-run-program.script
View file @
40a89c19
...
...
@@ -3,66 +3,99 @@
;; On Windows, normalize away CRLF into jut the unixy LF.
(defun dewindowize (x)
(block ()
(setf x (remove (code-char 13) x))
;; Some buggy implementations output extra space on Windows;
;; Implementations that rely on shell redirection on Windows also do, as a limitation.
(when (eql #\space (last-char x))
(return (subseq x 0 (1- (length x)))))
x))
(DBG "Testing echo ok 1 via run-program as a list")
;; Some buggy implementations output extra space on Windows;
;; Implementations that rely on shell redirection on Windows also do, as a limitation.
(string-trim " " (remove (code-char 13) x)))
(os-cond
((os-unix-p)
(DBG "Testing echo ok 1 via run-program as a list")
(assert-equal "ok 1"
(run-program '("echo" "ok" "1") :output '(:string :stripped t))))
((os-windows-p)
(DBG "Testing ipconfig /all via run-progam as a string")
;;; FIXME: known breakage
#+(and ecl os-windows)
(errors parameter-error
(run-program "ipconfig /all"))
#-(and ecl os-windows)
(run-program "ipconfig /all")
(DBG "Testing ipconfig /all via run-progam as a list")
(run-program '("ipconfig" "/all"))))
(DBG "Testing echo ok 1 via run-program as a string")
#-(and ecl os-windows)
(assert-equal "ok 1"
(dewindowize (run-program '("echo" "ok" "1") :output '(:string :stripped t))))
#+(and sbcl os-windows)
(leave-test "SBCL won't let us pass unquoted arguments to cmd.exe" 0)
#-(and sbcl os-windows)
(progn
(DBG "Testing echo ok 1 via run-program as a string")
(assert-equal "ok 1"
(dewindowize (run-program "echo ok 1" :output '(:string :stripped t)))))
(dewindowize (run-program "echo ok 1" :output '(:string :stripped t))))
#+(and ecl os-windows)
(errors parameter-error
(dewindowize (run-program "echo ok 1" :output '(:string :stripped t))))
;;; test asdf run-shell-command function
#-(and ecl os-windows)
(progn
(setf *verbose-out* nil)
(DBG "Testing true via run-shell-command")
(assert-equal 0 (run-shell-command "
true
"))
(assert-equal 0 (run-shell-command "
exit 0
"))
(DBG "Testing false via run-shell-command")
(assert-equal 1 (run-shell-command "
false
"))
(assert-equal 1 (run-shell-command "
exit 1
"))
(DBG "Testing bad shell command via run-shell-command")
(unless (< 0 (run-shell-command "./bad-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
(error "Failed to capture exit status indicating shell command failure.")))
#+(and ecl os-windows)
(errors not-implemented-error
(eql 0 (run-shell-command "exit 0")))
(chdir *test-directory*)
#+os-unix
(progn
(chdir *test-directory*)
(DBG "Testing good shell command in current directory via run-shell-command")
(assert-equal 0 (run-shell-command "./good-shell-command"))
;; this test checks for a problem there was in allegro -- :output :interactive
;; would try to open T as a stream for INPUT.
(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell t :output :interactive)))
(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell nil :output :interactive)))
(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell t :output :interactive :ignore-error-status t)))
(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell nil :output :interactive :ignore-error-status t)))
(assert-equal
'("foo" "bar baz" 42)
(multiple-value-list
(run-program "cat ; echo bar baz >&2 ; exit 42"
:input '("foo") :output :string :error-output '(:string :stripped t)
:ignore-error-status t)))
(assert-equal
'(("foo" "bar" "baz" "quux") nil 0)
(multiple-value-list
(run-program "echo foo ; echo bar >&2 ; echo baz ; echo quux >& 2"
:output :lines :error-output :output))))
#-(and sbcl os-windows)
(assert-equal 0 (run-shell-command "./good-shell-command")))
(DBG "Testing exit status with :output :interactive")
;; This test checks for a problem there was in allegro -- :output :interactive
;; would try to open T as a stream for INPUT.
#-(and ecl os-windows)
(loop
:for (program . exit-code) :in
#+os-unix '(("true" . 0) ("false" . 1))
#+os-windows '(("cmd /c exit 0" . 0) ("cmd /c exit 1" . 1))
:do (loop
:for force-shell :in '(t nil)
:do (assert-equal `(nil nil ,exit-code)
(multiple-value-list
(run-program program
:ignore-error-status t
:force-shell force-shell
:output :interactive)))))
#+(and ecl os-windows)
(DBG "Test skipped on ECL + Windows")
#-(and ecl os-windows)
(assert-equal
'("foo" "bar baz" 42)
(multiple-value-bind (o e c)
(run-program #+os-unix "cat ; echo bar baz >&2 ; exit 42"
#+os-windows "findstr \"^\" & echo bar baz >&2 & exit 42"
;; On some versions of windows, findstr hangs indefinitely
;; when passed input without a trailing newline
:input '("foo" :terpri t)
:output '(:string :stripped t) :error-output '(:string :stripped t)
:ignore-error-status t)
(DBG "aaa" o e c)
(list (dewindowize o) (dewindowize e) c)))
#-(and ecl os-windows)
(assert-equal
'(("foo" "bar" "baz" "quux") nil 0)
(multiple-value-bind (o e c)
(run-program #+os-unix "echo foo ; echo bar >&2 ; echo baz ; echo quux >& 2"
#+os-windows "echo foo & echo bar >&2 & echo baz & echo quux >& 2"
:output :lines :error-output :output)
(list (mapcar 'dewindowize o) e c)))
#-(and ecl os-windows)
(let ((ok1 (format nil "; $ echo ok 1~%ok 1")))
(untrace)
(DBG "Testing awkward legacy output capture via run-shell-command")
(assert-equal
(dewindowize
...
...
@@ -82,15 +115,13 @@
(error "Didn't get good exit status.")))))))
ok1))
#-(and ecl os-windows)
(assert-equal '(:ok 1) (run-program "echo :ok 1" :output :forms))
#-(and ecl os-windows)
(assert-equal "ok" (dewindowize (stripln
(with-output-to-string (*standard-output*)
(run-program "echo ok" :output t :error-output :output)))))
#|
Testing run-program
|#
;; We add a newline to the end of a string and return it.
;; We do it in this specific manner so that under unix, windows and macos,
;; format will choose the correct type of newline delimiters
...
...
@@ -241,9 +272,10 @@ Testing run-program
t)
(defun windows-only-test/run-program ()
(DBG "WINDOWS-ONLY-TEST/RUN-PROGRAM")
;; a basic smoke test
(assert-equal "ok" (dewindowize (run-program '("cmd" "/c" "echo" "ok") :output :line)))
#-(and ecl os-windows)
(assert-equal "ok 1" (dewindowize (run-program "echo ok 1" :output :line)))
;; clozure: beware http://trac.clozure.com/ccl/ticket/1118
...
...
tools/asdf-tools.asd
View file @
40a89c19
...
...
@@ -8,8 +8,7 @@
(
:version
"cl-scripting"
"0.2"
)
(
:feature
:sbcl
(
:require
"sb-introspect"
)))
:build-operation
program-op
:build-pathname
#.
(
format
nil
"../build/asdf-tools~@[.~A~]"
(
asdf/bundle:bundle-pathname-type
:program
))
:build-pathname
"../build/asdf-tools"
:entry-point
"asdf-tools::entry-point"
:components
((
:file
"package"
)
...
...
tools/asdf-tools.bat
View file @
40a89c19
@echo
off
::
@echo off
::: By default. We use CCL, because SBCL doesn't have a good enough run-program on Windows.
if
"
%LISP%
"
==
""
goto
ccl
...
...
@@ -9,22 +9,22 @@ if "%LISP%" == "sbcl" goto sbcl
:ccl
if
"
%CCL%
"
==
""
set
CCL
=
ccl
%CCL%
--no-init --load
%~dp0
asdf
-tools
--
%
*
"
%CCL%
"
--no-init --load
"
%~dp0
asdf-tools
"
--
%
*
goto
end
:sbcl
::: As of SBCL 1.2.13, SBCL's run-program fails to call CMD.EXE directly, so can't fully run asdf-tools
if
"
%SBCL%
"
==
""
set
SBCL
=
sbcl
%SBCL%
--noinform --no-userinit --no-sysinit --script
%~dp0
asdf
-tools
%
*
"
%SBCL%
"
--noinform --no-userinit --no-sysinit --script
"
%~dp0
asdf-tools
"
%
*
goto
end
:allegro
if
"
%ALLEGRO%
"
==
""
set
ALLEGRO
=
alisp
.exe
if
"
%
~1"
==
"get_allegro_dir"
goto
get_allegro_dir
call
%
0
get_allegro_dir
%ALLEGRO%
%ALLEGRO%
.exe
%ALLEGRODIR%
buildi
.exe
-I
%ALLEGRODIR%
alisp
.dxl
-qq -e
"(setf *load-verbose* nil)"
-L
%~dp0
asdf
-tools
.
--
%
*
call
%
0
get_allegro_dir
"
%ALLEGRO%
"
"
%ALLEGRO%
.exe
"
"
%ALLEGRODIR%
buildi.exe
"
-I
"
%ALLEGRODIR%
alisp.dxl
"
-qq -e
"(setf *load-verbose* nil)"
-L
"
%~dp0
asdf-tools.
"
--
%
*
goto
end
:get
_allegro_dir
if
not
"
%~dp
$PATH:2"
==
""
(
set
ALLEGRODIR
=
%~dp
$PATH:2
&
goto
end
)
...
...
tools/release.lisp
View file @
40a89c19
...
...
@@ -14,8 +14,12 @@
(
defun
system-source-files
(
system
&key
monolithic
)
(
let
((
system
(
find-system
system
)))
(
enough-namestrings
(
system-source-directory
system
)
(
input-files
'concatenate-source-op
system
))))
(
enough-namestrings
(
system-source-directory
system
)
(
input-files
(
if
monolithic
'monolithic-concatenate-source-op
'concatenate-source-op
)
system
))))
;;; Making release tarballs for asdf, asdf/defsystem, uiop.
...
...
uiop/run-program.lisp
View file @
40a89c19
...
...
@@ -338,15 +338,6 @@ Programmers are encouraged to define their own methods for this generic function
(
subprocess-error-command
condition
)
(
subprocess-error-code
condition
)))))
;;; find CMD.exe on windows
(
defun
%cmd-shell-pathname
()
(
os-cond
((
os-windows-p
)
(
strcat
(
native-namestring
(
getenv-absolute-directory
"WINDIR"
))
"System32\\cmd.exe"
))
(
t
(
error
"CMD.EXE is not the command shell for this OS."
))))
;;; Internal helpers for run-program
(
defun
%normalize-command
(
command
)
"Given a COMMAND as a list or string, transform it in a format suitable
...
...
@@ -356,18 +347,22 @@ for the implementation's underlying run-program function"
#+
os-unix
(
list
command
)
#+
os-windows
(
string
;; NB: We do NOT add cmd /c here. You might want to.
#+
(
or
allegro
clisp
)
command
;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
;; when the command contains spaces or special characters:
;; IIUC, the system will use space as a separator, but the argv-decoding libraries won't,
;; and you're supposed to use an extra argument to CreateProcess to bridge the gap,
;; but neither allegro nor clisp provide access to that argument.
#+
(
or
allegro
clisp
)
(
strcat
"cmd /c "
command
)
;; On ClozureCL for Windows, we assume you are using
;; r15398 or later in 1.9 or later,
;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
#+
clozure
(
cons
"cmd"
(
strcat
"/c "
command
))
#+
mkcl
(
list
"cmd"
"/c"
command
)
#+
sbcl
(
list
(
%cmd-shell-pathname
)
"/c"
command
)
;; On SBCL, we assume the patch from https://bugs.launchpad.net/sbcl/+bug/1503496
#+
(
or
clozure
sbcl
)
(
cons
"cmd"
(
strcat
"/c "
command
))
;; NB: On other Windows implementations, this is utterly bogus
;; except in the most trivial cases where no quoting is needed.
;; Use at your own risk.
#-
(
or
allegro
clisp
clozure
mkcl
sbcl
)
(
list
"cmd"
"/c"
command
))
#-
(
or
allegro
clisp
clozure
sbcl
)
(
parameter-error
"~S doesn't support string commands on Windows on this lisp: ~S"
'%normalize-command
command
))
#+
os-windows
(
list
#+
allegro
(
escape-windows-command
command
)
...
...
@@ -816,7 +811,9 @@ or :error-output."
(
when
stream
(
close
stream
))))
(
defun
%call-with-program-io
(
gf
tval
stream-easy-p
fun
direction
spec
activep
returner
&key
element-type
external-format
&allow-other-keys
)
&key
(
element-type
#-
clozure
*default-stream-element-type*
#+
clozure
'character
)
(
external-format
*utf-8-external-format*
)
&allow-other-keys
)
;; handle redirection for run-program and system
;; SPEC is the specification for the subprocess's input or output or error-output
;; TVAL is the value used if the spec is T
...
...
@@ -966,7 +963,7 @@ or :error-output."
(
os-cond
((
os-windows-p
)
#+
(
or
allegro
clisp
ecl
)
(
strcat
(
%
cmd
-shell-pathname
)
" /c "
command
)
(
strcat
"
cmd
"
" /c "
command
)
#-
(
or
allegro
clisp
ecl
)
command
)
(
t
command
)))
(
list
(
escape-shell-command
...
...
@@ -974,7 +971,7 @@ or :error-output."
((
os-unix-p
)
(
cons
"exec"
command
))
((
os-windows-p
)
#+
(
or
allegro
clisp
ecl
sbcl
)
(
cons
(
%cmd-shell-pathname
)
(
cons
"/c"
command
)
)
(
list*
"cmd"
"/c"
command
)
#-
(
or
allegro
clisp
ecl
sbcl
)
command
)
(
t
command
))))))
...
...
@@ -1007,9 +1004,9 @@ or :error-output."
((
os-windows-p
)
`
(
,@
chdir
,@
redirections
" "
,
normalized
)))))))
(
defun
%system
(
command
&rest
keys
&key
directory
input
if-input-does-not-exist
output
if-output-exists
error-output
if-error-output-exists
input
(
if-input-does-not-exist
:error
)
output
(
if-output-exists
:supersede
)
error-output
(
if-error-output-exists
:supersede
)
&allow-other-keys
)
"A portable abstraction of a low-level call to libc's system()."
(
declare
(
ignorable
keys
directory
input
if-input-does-not-exist
output
...
...
@@ -1077,7 +1074,7 @@ or :error-output."
error-output
(
if-error-output-exists
:supersede
)
(
element-type
#-
clozure
*default-stream-element-type*
#+
clozure
'character
)
(
external-format
*utf-8-external-format*
)
&allow-other-keys
)
&allow-other-keys
)
"Run program specified by COMMAND,
either a list of strings specifying a program and list of arguments,
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
...
...
@@ -1145,32 +1142,23 @@ RUN-PROGRAM returns 3 values:
1- the result of the ERROR-OUTPUT slurping if any, or NIL
2- either 0 if the subprocess exited with success status,
or an indication of failure via the EXIT-CODE of the process"
(
declare
(
ignorable
ignore-error-status
))
(
declare
(
ignorable
input
output
error-output
if-input-does-not-exist
if-output-exists
if-error-output-exists
element-type
external-format
ignore-error-status
))
#-
(
or
abcl
allegro
clasp
clisp
clozure
cmucl
cormanlisp
ecl
gcl
lispworks
mcl
mkcl
sbcl
scl
xcl
)
(
not-implemented-error
'run-program
)
;; Per doc string, set FORCE-SHELL to T if we get command as a string.
;; But don't override user's specified preference. [2015/06/29:rpg]
(
when
(
stringp
command
)
(
unless
force-shell-suppliedp
#-
(
and
sbcl
os-windows
)
;; force-shell t isn't working properly on windows as of sbcl 1.2.16
(
setf
force-shell
t
)))
(
apply
(
if
(
or
force-shell
#+
(
or
clasp
clisp
)
t
;; Per doc string, set FORCE-SHELL to T if we get command as a string.
;; But don't override user's specified preference. [2015/06/29:rpg]
(
and
(
stringp
command
)
(
or
(
not
force-shell-suppliedp
)
#-
(
or
allegro
clisp
clozure
sbcl
)
(
os-cond
((
os-windows-p
)
t
))))
#+
(
or
clasp
clisp
cormanlisp
gcl
(
and
lispworks
os-windows
)
mcl
xcl
)
t
;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
#+
ecl
#.
(
if-let
(
ver
(
parse-version
(
lisp-implementation-version
)))
(
lexicographic<=
'<
ver
'
(
16
0
0
)))
#+
(
and
lispworks
os-unix
)
(
%interactivep
input
output
error-output
)
#+
(
or
cormanlisp
gcl
(
and
lispworks
os-windows
)
mcl
xcl
)
t
)
#+
(
and
lispworks
os-unix
)
(
%interactivep
input
output
error-output
))
'%use-system
'%use-launch-program
)
command
:input
input
:output
output
:error-output
error-output
:if-input-does-not-exist
if-input-does-not-exist
:if-output-exists
if-output-exists
:if-error-output-exists
if-error-output-exists
:element-type
element-type
:external-format
external-format
keys
))
command
keys
))
;; WARNING: For signals other than SIGTERM and SIGKILL this may not
;; do what you expect it to. Sending SIGSTOP to a process spawned
...
...
uiop/utility.lisp
View file @
40a89c19
...
...
@@ -82,7 +82,7 @@ to supersede any previous definition."
(
defvar
*uiop-debug-utility*
'
(
or
(
ignore-errors
(
symbol-call
:asdf
:system-relative-pathname
:uiop
"contrib/debug.lisp"
))
(
symbol-call
:uiop/pathname
:subpathname
(
user-homedir-pathname
)
"c
l
/asdf/uiop/contrib/debug.lisp"
))
(
symbol-call
:uiop/pathname
:subpathname
(
user-homedir-pathname
)
"c
ommon-lisp
/asdf/uiop/contrib/debug.lisp"
))
"form that evaluates to the pathname to your favorite debugging utilities"
)
(
defmacro
uiop-debug
(
&rest
keys
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment