Commit 40a89c19 authored by Robert Goldman's avatar Robert Goldman

Merge branch 'run-program-windows' into 'master'

Run program windows

Various fixes for Windows.

See merge request !52
parents 58968bce ea467d96
......@@ -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.
......
......@@ -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 ()
......
......@@ -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 exists 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
......
;;; -*- 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)))
......@@ -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
......
......@@ -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")
......
@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 %~dp0asdf-tools -- %*
"%CCL%" --no-init --load "%~dp0asdf-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 %~dp0asdf-tools %*
"%SBCL%" --noinform --no-userinit --no-sysinit --script "%~dp0asdf-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 %~dp0asdf-tools. -- %*
call %0 get_allegro_dir "%ALLEGRO%" "%ALLEGRO%.exe"
"%ALLEGRODIR%buildi.exe" -I "%ALLEGRODIR%alisp.dxl" -qq -e "(setf *load-verbose* nil)" -L "%~dp0asdf-tools." -- %*
goto end
:get_allegro_dir
if not "%~dp$PATH:2" == "" ( set ALLEGRODIR=%~dp$PATH:2& goto end )
......
......@@ -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.
......
......@@ -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
......
......@@ -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) "cl/asdf/uiop/contrib/debug.lisp"))
(symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))
"form that evaluates to the pathname to your favorite debugging utilities")
(defmacro uiop-debug (&rest keys)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment