Merge branch 'refactor-run-program' into develop
This commit is contained in:
Daniel Kochmański
commit
226dd35775
27 changed files with 938 additions and 546 deletions
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -17,6 +17,7 @@ cov-int
|
|||
*.manifest
|
||||
*.obj
|
||||
*.pdb
|
||||
*.fasl
|
||||
|
||||
|
||||
msvc/help.doc
|
||||
|
|
@ -96,3 +97,4 @@ regressions/eformat-tests/*.txt
|
|||
/msvc/rt.asd
|
||||
/msvc/sb-bsd-sockets.asd
|
||||
/msvc/sockets.asd
|
||||
doc/tmp/
|
||||
|
|
|
|||
10
CHANGELOG
10
CHANGELOG
|
|
@ -29,6 +29,10 @@
|
|||
|
||||
* Pending changes since 16.1.3
|
||||
** Enhancements
|
||||
- ext:run-program has been rewritten (almost) from scratch
|
||||
- improved documentation of operating system interface (newdoc)
|
||||
- example of parsing arguments in standalone executable (newdoc)
|
||||
- example of using shared libraries from C world (newdoc)
|
||||
- reduced =format= directive tables size
|
||||
- simplified =atan2= implementation by using c99 equivalent ::
|
||||
Now we produce correct output for signed zeros, infinities and nans.
|
||||
|
|
@ -36,8 +40,14 @@
|
|||
=--with-libgc-incdir= and =--with-libgc-libdir= (these flags work the
|
||||
same as flags for =libffi= and =libgmp=)
|
||||
** Issues fixed
|
||||
- interactive input stream in ext:run-program on Windows
|
||||
- removed race condition between waitpid and sigchld handler on UNIX
|
||||
- buildsystem parallel builds work (i.e make -j999)
|
||||
- ECL builds on consoles with unusual encodings on Windows (i.e cp936)
|
||||
** API changes
|
||||
- No more explicit option in =main.d= to trap SIGCHLD asynchronously.
|
||||
- Zombie processes are cleaned in external-process finalizer. If process is
|
||||
referenced in the memory, it's programmer duty to call wait on it.
|
||||
* 16.1.3 changes since 16.1.2
|
||||
** Announcement
|
||||
Dear Community,
|
||||
|
|
|
|||
|
|
@ -2,44 +2,18 @@ top_srcdir=..\..
|
|||
ECLDIR=../package/
|
||||
ECL=..\package\ecl.exe
|
||||
|
||||
all: show-fails
|
||||
.PHONY: all
|
||||
|
||||
.PHONY: do-regressions cleanup clean-sources update
|
||||
all: check
|
||||
|
||||
check: config.lsp
|
||||
set ECLDIR=$(ECLDIR)
|
||||
$(ECL) -norc \
|
||||
-load config.lsp \
|
||||
-eval "(ecl-tests::run-tests '($(TESTS)))" \
|
||||
-eval "(ext:quit)"
|
||||
|
||||
config.lsp: $(top_srcdir)\src\tests\config.lsp.in ..\c\cut.exe Makefile
|
||||
..\c\cut.exe "@builddir@" "./" \
|
||||
"@top_srcdir@" "../.." \
|
||||
"@true_srcdir@" "../src" \
|
||||
< $(top_srcdir)\src\tests\config.lsp.in > config.lsp
|
||||
|
||||
output.ecl\regressions.log: config.lsp
|
||||
$(MAKE) do-regressions
|
||||
|
||||
do-regressions: regressions config.lsp
|
||||
set ECLDIR=$(ECLDIR)
|
||||
$(ECL) -norc -load config.lsp -eval "(ecl-tests::run-regressions-tests)" -eval "(ext:quit)"
|
||||
|
||||
show-fails: regressions.log
|
||||
type regressions.log
|
||||
|
||||
#
|
||||
# Create directories
|
||||
#
|
||||
regressions.log: config.lsp
|
||||
$(MAKE) do-regressions
|
||||
|
||||
#
|
||||
# Cleanup
|
||||
#
|
||||
clean:
|
||||
rm -rf output*
|
||||
|
||||
clean-sources:
|
||||
test -f config.lsp.in || rm -rf bugs
|
||||
rm -rf ansi-tests quicklisp
|
||||
|
||||
distclean: clean-sources clean
|
||||
rm -rf cache
|
||||
|
||||
update: clean-sources
|
||||
$(MAKE) regressions
|
||||
|
||||
|
|
|
|||
|
|
@ -821,7 +821,7 @@ put_return(void)
|
|||
}
|
||||
put_tabs(t);
|
||||
fprintf(out, "the_env->nvalues = %d;\n", nres);
|
||||
for (i = nres-1; i > 0; i--) {
|
||||
for (i = nres-1; i >= 0; i--) {
|
||||
put_tabs(t);
|
||||
fprintf(out, "the_env->values[%d] = __value%d;\n", i, i);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -71,6 +71,7 @@ const char *ecl_self;
|
|||
|
||||
static int ARGC;
|
||||
static char **ARGV;
|
||||
/* INV: see ecl_option enum in external.h */
|
||||
cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = {
|
||||
#ifdef GBC_BOEHM_GENGC
|
||||
1, /* ECL_OPT_INCREMENTAL_GC */
|
||||
|
|
@ -83,7 +84,6 @@ cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = {
|
|||
1, /* ECL_OPT_TRAP_SIGILL */
|
||||
1, /* ECL_OPT_TRAP_SIGBUS */
|
||||
1, /* ECL_OPT_TRAP_SIGPIPE */
|
||||
1, /* ECL_OPT_TRAP_SIGCHLD */
|
||||
1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */
|
||||
1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */
|
||||
16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */
|
||||
|
|
@ -431,8 +431,6 @@ struct cl_core_struct cl_core = {
|
|||
(cl_object)&default_rehash_size_data, /* rehash_size */
|
||||
(cl_object)&default_rehash_threshold_data, /* rehash_threshold */
|
||||
|
||||
ECL_NIL, /* external_processes */
|
||||
ECL_NIL, /* external_processes_lock */
|
||||
ECL_NIL /* known_signals */
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -1232,10 +1232,6 @@ cl_symbols[] = {
|
|||
{SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2, OBJNULL},
|
||||
{SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL},
|
||||
{SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL},
|
||||
{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL},
|
||||
{SYS_ "RUN-PROGRAM-INTERNAL", SI_ORDINARY, si_run_program_internal, 8, OBJNULL},
|
||||
{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL},
|
||||
{SYS_ "WAIT-FOR-ALL-PROCESSES", SI_ORDINARY, si_wait_for_all_processes, -1, OBJNULL},
|
||||
{EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL},
|
||||
{SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL},
|
||||
{SYS_ "SCHAR-SET", SI_ORDINARY, si_char_set, 3, OBJNULL},
|
||||
|
|
@ -1268,7 +1264,7 @@ cl_symbols[] = {
|
|||
{SYS_ "STRUCTUREP", SI_ORDINARY, si_structurep, 1, OBJNULL},
|
||||
{SYS_ "SVSET", SI_ORDINARY, si_svset, 3, OBJNULL},
|
||||
{SYS_ "SYMBOL-MACRO", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "SYSTEM", EXT_ORDINARY, ECL_NAME(si_system), 1, OBJNULL},
|
||||
{EXT_ "SYSTEM", EXT_ORDINARY, si_system, 1, OBJNULL},
|
||||
{SYS_ "TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "TOP-LEVEL", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
|
|
@ -1975,6 +1971,9 @@ cl_symbols[] = {
|
|||
|
||||
{KEY_ "ENVIRON", KEYWORD, NULL, -1, OBJNULL},
|
||||
|
||||
/* external-process extension */
|
||||
{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL},
|
||||
|
||||
{EXT_ "MAKE-EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-PID", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
|
|
@ -1982,19 +1981,31 @@ cl_symbols[] = {
|
|||
{EXT_ "EXTERNAL-PROCESS-OUTPUT", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-ERROR-STREAM", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-STATUS", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, NULL, -1, OBJNULL},
|
||||
{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, ECL_NAME(si_terminate_process), -1, OBJNULL},
|
||||
|
||||
{KEY_ "RUNNING", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "EXITED", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "SIGNALED", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "STOPPED", KEYWORD, NULL, -1, OBJNULL},
|
||||
{KEY_ "RESUMED", KEYWORD, NULL, -1, OBJNULL},
|
||||
/* ~ external-process extension */
|
||||
|
||||
{EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, si_external_process_wait, -1, OBJNULL},
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
|
||||
/* unixsys.d */
|
||||
{SYS_ "WAITPID", SI_ORDINARY, si_waitpid, 2, OBJNULL},
|
||||
#if !defined(ECL_MS_WINDOWS_HOST)
|
||||
{SYS_ "KILLPID", SI_ORDINARY, si_killpid, 2, OBJNULL},
|
||||
#else
|
||||
{SYS_ "KILLPID", SI_ORDINARY, NULL, 2, OBJNULL},
|
||||
#endif
|
||||
{SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL},
|
||||
{SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL},
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
{SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, si_close_windows_handle, 1, OBJNULL},
|
||||
#else
|
||||
{SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
#endif
|
||||
/* ~ */
|
||||
|
||||
{EXT_ "*INVOKE-DEBUGGER-HOOK*", EXT_SPECIAL, NULL, -1, ECL_NIL},
|
||||
|
||||
|
|
|
|||
|
|
@ -1232,10 +1232,6 @@ cl_symbols[] = {
|
|||
{SYS_ "REM-SYSPROP","si_rem_sysprop"},
|
||||
{SYS_ "REPLACE-ARRAY","si_replace_array"},
|
||||
{SYS_ "ROW-MAJOR-ASET","si_row_major_aset"},
|
||||
{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"},
|
||||
{SYS_ "RUN-PROGRAM-INTERNAL","si_run_program_internal"},
|
||||
{EXT_ "TERMINATE-PROCESS","si_terminate_process"},
|
||||
{SYS_ "WAIT-FOR-ALL-PROCESSES","si_wait_for_all_processes"},
|
||||
{EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"},
|
||||
{SYS_ "SCH-FRS-BASE","si_sch_frs_base"},
|
||||
{SYS_ "SCHAR-SET","si_char_set"},
|
||||
|
|
@ -1268,7 +1264,7 @@ cl_symbols[] = {
|
|||
{SYS_ "STRUCTUREP","si_structurep"},
|
||||
{SYS_ "SVSET","si_svset"},
|
||||
{SYS_ "SYMBOL-MACRO",NULL},
|
||||
{EXT_ "SYSTEM","ECL_NAME(si_system)"},
|
||||
{EXT_ "SYSTEM","si_system"},
|
||||
{SYS_ "TERMINAL-INTERRUPT",NULL},
|
||||
{SYS_ "TOP-LEVEL",NULL},
|
||||
{SYS_ "UNIVERSAL-ERROR-HANDLER",NULL},
|
||||
|
|
@ -1975,6 +1971,9 @@ cl_symbols[] = {
|
|||
|
||||
{KEY_ "ENVIRON",NULL},
|
||||
|
||||
/* external-process extension */
|
||||
{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"},
|
||||
|
||||
{EXT_ "MAKE-EXTERNAL-PROCESS",NULL},
|
||||
{EXT_ "EXTERNAL-PROCESS",NULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-PID",NULL},
|
||||
|
|
@ -1982,19 +1981,31 @@ cl_symbols[] = {
|
|||
{EXT_ "EXTERNAL-PROCESS-OUTPUT",NULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-ERROR-STREAM",NULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-STATUS",NULL},
|
||||
{EXT_ "EXTERNAL-PROCESS-WAIT",NULL},
|
||||
{EXT_ "TERMINATE-PROCESS","ECL_NAME(si_terminate_process)"},
|
||||
|
||||
{KEY_ "RUNNING",NULL},
|
||||
{KEY_ "EXITED",NULL},
|
||||
{KEY_ "SIGNALED",NULL},
|
||||
{KEY_ "STOPPED",NULL},
|
||||
{KEY_ "RESUMED",NULL},
|
||||
/* ~ external-process extension */
|
||||
|
||||
{EXT_ "EXTERNAL-PROCESS-WAIT","si_external_process_wait"},
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
|
||||
/* unixsys.d */
|
||||
{SYS_ "WAITPID","si_waitpid"},
|
||||
#if !defined(ECL_MS_WINDOWS_HOST)
|
||||
{SYS_ "KILLPID","si_killpid"},
|
||||
#else
|
||||
{SYS_ "KILLPID",NULL},
|
||||
#endif
|
||||
{SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"},
|
||||
{SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"},
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
{SYS_ "CLOSE-WINDOWS-HANDLE","si_close_windows_handle"},
|
||||
#else
|
||||
{SYS_ "CLOSE-WINDOWS-HANDLE",NULL},
|
||||
#endif
|
||||
/* ~ */
|
||||
|
||||
{EXT_ "*INVOKE-DEBUGGER-HOOK*",NULL},
|
||||
|
||||
|
|
|
|||
|
|
@ -161,7 +161,7 @@ static struct {
|
|||
{ SIGCONT, "+SIGCONT+", ECL_NIL},
|
||||
#endif
|
||||
#ifdef SIGCHLD
|
||||
{ SIGCHLD, "+SIGCHLD+", @'si::wait-for-all-processes'},
|
||||
{ SIGCHLD, "+SIGCHLD+", ECL_NIL},
|
||||
#endif
|
||||
#ifdef SIGTTIN
|
||||
{ SIGTTIN, "+SIGTTIN+", ECL_NIL},
|
||||
|
|
@ -568,12 +568,6 @@ asynchronous_signal_servicing_thread()
|
|||
signal_thread_msg.process == the_env->own_process) {
|
||||
break;
|
||||
}
|
||||
#ifdef SIGCHLD
|
||||
if (signal_thread_msg.signo == SIGCHLD) {
|
||||
si_wait_for_all_processes(0);
|
||||
continue;
|
||||
}
|
||||
#endif
|
||||
signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo),
|
||||
cl_core.known_signals,
|
||||
ECL_NIL);
|
||||
|
|
@ -857,14 +851,6 @@ do_catch_signal(int code, cl_object action, cl_object process)
|
|||
else if (code == SIGILL) {
|
||||
mysignal(SIGILL, evil_signal_handler);
|
||||
}
|
||||
#endif
|
||||
#if defined(SIGCHLD) && defined(ECL_THREADS)
|
||||
else if (code == SIGCHLD &&
|
||||
ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD])
|
||||
{
|
||||
/* Do nothing. This is taken care of in
|
||||
* the asynchronous signal handler. */
|
||||
}
|
||||
#endif
|
||||
else {
|
||||
mysignal(code, non_evil_signal_handler);
|
||||
|
|
@ -1241,14 +1227,6 @@ install_asynchronous_signal_handlers()
|
|||
async_handler(SIGINT, non_evil_signal_handler, sigmask);
|
||||
}
|
||||
#endif
|
||||
#ifdef SIGCHLD
|
||||
if (ecl_option_values[ECL_OPT_TRAP_SIGCHLD]) {
|
||||
/* We have to set the process signal handler explicitly,
|
||||
* because on many platforms the default is SIG_IGN. */
|
||||
mysignal(SIGCHLD, non_evil_signal_handler);
|
||||
async_handler(SIGCHLD, non_evil_signal_handler, sigmask);
|
||||
}
|
||||
#endif
|
||||
#ifdef HAVE_SIGPROCMASK
|
||||
# if defined(ECL_THREADS)
|
||||
pthread_sigmask(SIG_SETMASK, sigmask, NULL);
|
||||
|
|
|
|||
427
src/c/unixsys.d
427
src/c/unixsys.d
|
|
@ -23,10 +23,7 @@
|
|||
#endif
|
||||
#include <ecl/ecl.h>
|
||||
#include <ecl/internal.h>
|
||||
#ifdef cygwin
|
||||
# include <sys/cygwin.h> /* For cygwin_attach_handle_to_fd() */
|
||||
#endif
|
||||
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
# include <windows.h>
|
||||
#endif
|
||||
#ifdef HAVE_SYS_WAIT_H
|
||||
|
|
@ -39,6 +36,14 @@
|
|||
# undef environ
|
||||
#endif
|
||||
|
||||
cl_object
|
||||
si_system(cl_object cmd_string)
|
||||
{
|
||||
cl_object cmd = si_copy_to_simple_base_string(cmd_string);
|
||||
int code = system((const char *)(cmd->base_string.self));
|
||||
return ecl_make_fixnum(code);
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_getpid(void)
|
||||
{
|
||||
|
|
@ -100,15 +105,6 @@ from_list_to_execve_argument(cl_object l, char ***environp)
|
|||
char **environ;
|
||||
for (p = l; !Null(p); p = ECL_CONS_CDR(p)) {
|
||||
cl_object s;
|
||||
if (!CONSP(p)) {
|
||||
FEerror("In EXT:RUN-PROGRAM, environment "
|
||||
"is not a list of strings", 0);
|
||||
}
|
||||
s = ECL_CONS_CAR(p);
|
||||
if (!ECL_BASE_STRING_P(s)) {
|
||||
FEerror("In EXT:RUN-PROGRAM, environment "
|
||||
"is not a list of base strings", 0);
|
||||
}
|
||||
total_size += s->base_string.fillp + 1;
|
||||
nstrings++;
|
||||
}
|
||||
|
|
@ -119,11 +115,7 @@ from_list_to_execve_argument(cl_object l, char ***environp)
|
|||
for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) {
|
||||
cl_object s = ECL_CONS_CAR(p);
|
||||
cl_index l = s->base_string.fillp;
|
||||
if (i + l + 1 >= total_size) {
|
||||
FEerror("In EXT:RUN-PROGRAM, environment list"
|
||||
" changed during execution.", 0);
|
||||
break;
|
||||
}
|
||||
|
||||
environ[j++] = (char*)(buffer->base_string.self + i);
|
||||
memcpy(buffer->base_string.self + i,
|
||||
s->base_string.self,
|
||||
|
|
@ -137,113 +129,12 @@ from_list_to_execve_argument(cl_object l, char ***environp)
|
|||
return buffer;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
make_external_process()
|
||||
{
|
||||
return _ecl_funcall1(@'ext::make-external-process');
|
||||
}
|
||||
|
||||
static cl_object
|
||||
external_process_pid(cl_object p)
|
||||
{
|
||||
return ecl_structure_ref(p, @'ext::external-process', 0);
|
||||
}
|
||||
|
||||
static cl_object
|
||||
external_process_status(cl_object p)
|
||||
{
|
||||
return ecl_structure_ref(p, @'ext::external-process', 4);
|
||||
}
|
||||
|
||||
static cl_object
|
||||
external_process_code(cl_object p)
|
||||
{
|
||||
return ecl_structure_ref(p, @'ext::external-process', 5);
|
||||
}
|
||||
|
||||
static void
|
||||
set_external_process_pid(cl_object process, cl_object pid)
|
||||
{
|
||||
ecl_structure_set(process, @'ext::external-process', 0, pid);
|
||||
}
|
||||
|
||||
static void
|
||||
set_external_process_streams(cl_object process, cl_object input,
|
||||
cl_object output, cl_object error)
|
||||
{
|
||||
ecl_structure_set(process, @'ext::external-process', 1, input);
|
||||
ecl_structure_set(process, @'ext::external-process', 2, output);
|
||||
ecl_structure_set(process, @'ext::external-process', 3, error);
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
update_process_status(cl_object process, cl_object status, cl_object code)
|
||||
{
|
||||
ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL);
|
||||
ecl_structure_set(process, @'ext::external-process', 4, status);
|
||||
ecl_structure_set(process, @'ext::external-process', 5, code);
|
||||
}
|
||||
|
||||
#if defined(SIGCHLD) && !defined(ECL_MS_WINDOWS_HOST)
|
||||
static void
|
||||
add_external_process(cl_env_ptr env, cl_object process)
|
||||
{
|
||||
cl_object l = ecl_list1(process);
|
||||
ecl_disable_interrupts_env(env);
|
||||
ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock);
|
||||
{
|
||||
ECL_RPLACD(l, cl_core.external_processes);
|
||||
cl_core.external_processes = l;
|
||||
}
|
||||
ECL_WITH_SPINLOCK_END;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
|
||||
static void
|
||||
remove_external_process(cl_env_ptr env, cl_object process)
|
||||
{
|
||||
ecl_disable_interrupts_env(env);
|
||||
ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock);
|
||||
{
|
||||
cl_core.external_processes =
|
||||
ecl_delete_eq(process, cl_core.external_processes);
|
||||
}
|
||||
ECL_WITH_SPINLOCK_END;
|
||||
ecl_enable_interrupts_env(env);
|
||||
}
|
||||
|
||||
static cl_object
|
||||
find_external_process(cl_env_ptr env, cl_object pid)
|
||||
{
|
||||
cl_object output = ECL_NIL;
|
||||
ecl_disable_interrupts_env(env);
|
||||
ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock);
|
||||
{
|
||||
cl_object p;
|
||||
for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) {
|
||||
cl_object process = ECL_CONS_CAR(p);
|
||||
if (external_process_pid(process) == pid) {
|
||||
output = process;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock);
|
||||
ecl_enable_interrupts_env(env);
|
||||
return output;
|
||||
}
|
||||
#else
|
||||
#define add_external_process(env,p)
|
||||
#define remove_external_process(env,p)
|
||||
#endif
|
||||
|
||||
static cl_object
|
||||
ecl_waitpid(cl_object pid, cl_object wait)
|
||||
cl_object
|
||||
si_waitpid(cl_object pid, cl_object wait)
|
||||
{
|
||||
cl_object status, code;
|
||||
#if defined(NACL)
|
||||
FElibc_error("ecl_waitpid not implemented",1);
|
||||
FElibc_error("si_waitpid not implemented",1);
|
||||
@(return ECL_NIL);
|
||||
#elif defined(ECL_MS_WINDOWS_HOST)
|
||||
cl_env_ptr the_env = ecl_process_env();
|
||||
|
|
@ -268,7 +159,12 @@ ecl_waitpid(cl_object pid, cl_object wait)
|
|||
ecl_enable_interrupts_env(the_env);
|
||||
#else
|
||||
int code_int, error;
|
||||
error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0);
|
||||
|
||||
if (Null(wait))
|
||||
error = waitpid(ecl_to_fix(pid), &code_int, WNOHANG | WUNTRACED | WCONTINUED);
|
||||
else
|
||||
error = waitpid(ecl_to_fix(pid), &code_int, 0);
|
||||
|
||||
if (error < 0) {
|
||||
if (errno == EINTR) {
|
||||
status = @':abort';
|
||||
|
|
@ -292,6 +188,9 @@ ecl_waitpid(cl_object pid, cl_object wait)
|
|||
} else if (WIFSTOPPED(code_int)) {
|
||||
status = @':stopped';
|
||||
code = ecl_make_fixnum(WSTOPSIG(code_int));
|
||||
} else if (WIFCONTINUED(code_int)) {
|
||||
status = @':resumed';
|
||||
code = ecl_make_fixnum(SIGCONT);
|
||||
} else {
|
||||
status = @':running';
|
||||
code = ECL_NIL;
|
||||
|
|
@ -301,64 +200,15 @@ ecl_waitpid(cl_object pid, cl_object wait)
|
|||
@(return status code pid);
|
||||
}
|
||||
|
||||
@(defun ext::terminate-process (process &optional (force ECL_NIL))
|
||||
@
|
||||
{
|
||||
cl_env_ptr env = ecl_process_env();
|
||||
bool error_encountered = FALSE;
|
||||
ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock);
|
||||
{
|
||||
cl_object pid = external_process_pid(process);
|
||||
if (!Null(pid)) {
|
||||
int ret;
|
||||
#if !defined(ECL_MS_WINDOWS_HOST)
|
||||
cl_object
|
||||
si_killpid(cl_object pid, cl_object signal) {
|
||||
int ret = kill(ecl_fixnum(pid), ecl_fixnum(signal));
|
||||
return ecl_make_fixnum(ret);
|
||||
}
|
||||
#endif
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(pid);
|
||||
ret = TerminateProcess(*ph, -1);
|
||||
error_encountered = (ret == 0);
|
||||
#else
|
||||
ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL);
|
||||
error_encountered = (ret != 0);
|
||||
#endif
|
||||
}
|
||||
}
|
||||
ECL_WITH_SPINLOCK_END;
|
||||
if (error_encountered)
|
||||
FEerror("Cannot terminate the process ~A", 1, process);
|
||||
return ECL_NIL;
|
||||
}
|
||||
@)
|
||||
|
||||
|
||||
@(defun si::wait-for-all-processes (&key (process ECL_NIL))
|
||||
@
|
||||
{
|
||||
const cl_env_ptr env = ecl_process_env();
|
||||
#if defined(SIGCHLD) && !defined(ECL_WINDOWS_HOST)
|
||||
do {
|
||||
cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL);
|
||||
cl_object code = env->values[1];
|
||||
cl_object pid = env->values[2];
|
||||
if (Null(pid)) {
|
||||
if (status != @':abort')
|
||||
break;
|
||||
} else {
|
||||
cl_object p = find_external_process(env, pid);
|
||||
if (!Null(p)) {
|
||||
set_external_process_pid(p, ECL_NIL);
|
||||
update_process_status(p, status, code);
|
||||
}
|
||||
if (status != @':running') {
|
||||
remove_external_process(env, p);
|
||||
ecl_delete_eq(p, cl_core.external_processes);
|
||||
}
|
||||
}
|
||||
} while (1);
|
||||
#endif
|
||||
ecl_return0(env);
|
||||
}
|
||||
@)
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
|
||||
cl_object
|
||||
si_close_windows_handle(cl_object h)
|
||||
{
|
||||
|
|
@ -380,41 +230,6 @@ make_windows_handle(HANDLE h)
|
|||
}
|
||||
#endif
|
||||
|
||||
@(defun ext::external-process-wait (process &optional (wait ECL_NIL))
|
||||
@ {
|
||||
cl_object status, code, pid;
|
||||
AGAIN:
|
||||
pid = external_process_pid(process);
|
||||
if (Null(pid)) {
|
||||
/* If PID is NIL, it may be because the process failed,
|
||||
* or because it is being updated by a separate thread,
|
||||
* which is why we have to spin here. Note also the order
|
||||
* here: status is updated _after_ code, and hence we
|
||||
* check it _before_ code. */
|
||||
do {
|
||||
ecl_musleep(0.0, 1);
|
||||
status = external_process_status(process);
|
||||
} while (status == @':running');
|
||||
code = external_process_code(process);
|
||||
} else {
|
||||
status = ecl_waitpid(pid, wait);
|
||||
code = ecl_nth_value(the_env, 1);
|
||||
pid = ecl_nth_value(the_env, 2);
|
||||
/* A SIGCHLD interrupt may abort waitpid. If this
|
||||
* is the case, the signal handler may have consumed
|
||||
* the process status and we have to start over again */
|
||||
if (Null(pid)) {
|
||||
if (!Null(wait)) goto AGAIN;
|
||||
status = external_process_status(process);
|
||||
code = external_process_code(process);
|
||||
} else {
|
||||
update_process_status(process, status, code);
|
||||
remove_external_process(the_env, process);
|
||||
}
|
||||
}
|
||||
@(return status code);
|
||||
} @)
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
HANDLE
|
||||
ecl_stream_to_HANDLE(cl_object s, bool output)
|
||||
|
|
@ -427,9 +242,7 @@ ecl_stream_to_HANDLE(cl_object s, bool output)
|
|||
case ecl_smm_output_wsock:
|
||||
case ecl_smm_io_wsock:
|
||||
#endif
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
case ecl_smm_io_wcon:
|
||||
#endif
|
||||
return (HANDLE)IO_FILE_DESCRIPTOR(s);
|
||||
default: {
|
||||
int stream_descriptor = ecl_stream_to_handle(s, output);
|
||||
|
|
@ -452,44 +265,36 @@ create_descriptor(cl_object stream, cl_object direction,
|
|||
attr.bInheritHandle = TRUE;
|
||||
|
||||
if (stream == @':stream') {
|
||||
/* Creates a pipe that we can write to and the
|
||||
child reads from. We duplicate one extreme of the
|
||||
pipe so that the child does not inherit it. */
|
||||
/* Creates a pipe that we can write to and the child reads
|
||||
from. We duplicate one extreme of the pipe so that the child
|
||||
does not inherit it. */
|
||||
HANDLE tmp;
|
||||
if (CreatePipe(&tmp, child, &attr, 0) == 0)
|
||||
if (direction == @':input') {
|
||||
if (CreatePipe(child, &tmp, &attr, 0) == 0)
|
||||
return;
|
||||
|
||||
if (DuplicateHandle(current, tmp, current,
|
||||
&tmp, 0, FALSE,
|
||||
DUPLICATE_CLOSE_SOURCE |
|
||||
DUPLICATE_SAME_ACCESS) == 0)
|
||||
return;
|
||||
|
||||
if (direction == @':input') {
|
||||
#ifdef cygwin
|
||||
*parent = cygwin_attach_handle_to_fd
|
||||
(0, -1, tmp, S_IRWXU, GENERIC_WRITE);
|
||||
#else
|
||||
*parent = _open_osfhandle
|
||||
((intptr_t)tmp, _O_WRONLY);
|
||||
#endif
|
||||
*parent = _open_osfhandle((intptr_t)tmp, _O_WRONLY);
|
||||
}
|
||||
else {
|
||||
#ifdef cygwin
|
||||
*parent = cygwin_attach_handle_to_fd
|
||||
(0, -1, tmp, S_IRWXU, GENERIC_READ);
|
||||
#else
|
||||
*parent = _open_osfhandle
|
||||
((intptr_t)tmp, _O_RDONLY);
|
||||
#endif
|
||||
else /* if (direction == @':output') */ {
|
||||
if (CreatePipe(&tmp, child, &attr, 0) == 0)
|
||||
return;
|
||||
if (DuplicateHandle(current, tmp, current,
|
||||
&tmp, 0, FALSE,
|
||||
DUPLICATE_CLOSE_SOURCE |
|
||||
DUPLICATE_SAME_ACCESS) == 0)
|
||||
return;
|
||||
|
||||
*parent = _open_osfhandle((intptr_t)tmp, _O_RDONLY);
|
||||
}
|
||||
|
||||
if (*parent < 0)
|
||||
printf("open_osfhandle failed\n");
|
||||
}
|
||||
else if (Null(stream)) {
|
||||
*child = NULL;
|
||||
}
|
||||
else if (!Null(cl_streamp(stream))) {
|
||||
HANDLE stream_handle = ecl_stream_to_HANDLE
|
||||
(stream, direction != @':input');
|
||||
|
|
@ -523,12 +328,6 @@ create_descriptor(cl_object stream, cl_object direction,
|
|||
*child = fd[1];
|
||||
}
|
||||
}
|
||||
else if (Null(stream)) {
|
||||
if (direction == @':input')
|
||||
*child = open("/dev/null", O_RDONLY);
|
||||
else
|
||||
*child = open("/dev/null", O_WRONLY);
|
||||
}
|
||||
else if (!Null(cl_streamp(stream))) {
|
||||
*child = ecl_stream_to_handle
|
||||
(stream, direction != @':input');
|
||||
|
|
@ -549,20 +348,52 @@ create_descriptor(cl_object stream, cl_object direction,
|
|||
#endif
|
||||
|
||||
cl_object
|
||||
si_run_program_internal(cl_object command, cl_object argv,
|
||||
cl_object input, cl_object output, cl_object error,
|
||||
cl_object wait, cl_object environ, cl_object external_format) {
|
||||
|
||||
si_run_program_inner(cl_object command, cl_object argv, cl_object environ) {
|
||||
cl_env_ptr the_env = ecl_process_env();
|
||||
int parent_write = 0, parent_read = 0;
|
||||
cl_object pid, stream_write, stream_read, exit_status;
|
||||
|
||||
command = si_copy_to_simple_base_string(command);
|
||||
environ = cl_mapcar(2, @'si::copy-to-simple-base-string', environ);
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
argv = cl_format(4, ECL_NIL,
|
||||
make_simple_base_string("~A~{ ~A~}"),
|
||||
command, argv);
|
||||
argv = si_copy_to_simple_base_string(argv);
|
||||
#else
|
||||
argv = CONS(command, cl_mapcar(2, @'si::copy-to-simple-base-string', argv));
|
||||
#endif
|
||||
|
||||
pid = si_spawn_subprocess(command, argv, environ, @':stream', @':stream', @':output');
|
||||
parent_write = ecl_fixnum(ecl_nth_value(the_env, 1));
|
||||
parent_read = ecl_fixnum(ecl_nth_value(the_env, 2));
|
||||
|
||||
stream_write = ecl_make_stream_from_fd(command, parent_write,
|
||||
ecl_smm_output, 8,
|
||||
ECL_STREAM_DEFAULT_FORMAT,
|
||||
@':default');
|
||||
|
||||
stream_read = ecl_make_stream_from_fd(command, parent_read,
|
||||
ecl_smm_input, 8,
|
||||
ECL_STREAM_DEFAULT_FORMAT,
|
||||
@':default');
|
||||
|
||||
si_waitpid(pid, ECL_T);
|
||||
exit_status = ecl_nth_value(the_env, 1);
|
||||
@(return cl_make_two_way_stream(stream_read, stream_write) exit_status)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ,
|
||||
cl_object input, cl_object output, cl_object error) {
|
||||
|
||||
int parent_write = 0, parent_read = 0, parent_error = 0;
|
||||
int child_pid;
|
||||
cl_object pid, process;
|
||||
cl_object stream_write;
|
||||
cl_object stream_read;
|
||||
cl_object stream_error;
|
||||
cl_object exit_status = ECL_NIL;
|
||||
@
|
||||
process = make_external_process();
|
||||
cl_object pid;
|
||||
|
||||
/* command = ecl_null_terminated_base_string(command); */
|
||||
|
||||
#if defined(ECL_MS_WINDOWS_HOST)
|
||||
{
|
||||
BOOL ok;
|
||||
|
|
@ -570,7 +401,6 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
PROCESS_INFORMATION pr_info;
|
||||
HANDLE child_stdout, child_stdin, child_stderr;
|
||||
HANDLE current = GetCurrentProcess();
|
||||
HANDLE saved_stdout, saved_stdin, saved_stderr;
|
||||
cl_object env_buffer;
|
||||
char *env = NULL;
|
||||
|
||||
|
|
@ -580,17 +410,19 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
}
|
||||
create_descriptor(input, @':input', &child_stdin, &parent_write);
|
||||
create_descriptor(output, @':output', &child_stdout, &parent_read);
|
||||
if (error == @':output')
|
||||
/* The child inherits a duplicate of its own output
|
||||
handle.*/
|
||||
if (error == @':output') {
|
||||
/* The child inherits a duplicate of its own output handle. */
|
||||
DuplicateHandle(current, child_stdout, current,
|
||||
&child_stderr, 0, TRUE,
|
||||
DUPLICATE_SAME_ACCESS);
|
||||
/* Same for the parent_read and parent_error. */
|
||||
/* DuplicateHandle(current, parent_read, current, */
|
||||
/* &parent_error, 0, TRUE, */
|
||||
/* DUPLICATE_SAME_ACCESS); */
|
||||
}
|
||||
else
|
||||
create_descriptor(error, @':output', &child_stderr, &parent_error);
|
||||
|
||||
add_external_process(the_env, process);
|
||||
|
||||
ZeroMemory(&st_info, sizeof(STARTUPINFO));
|
||||
st_info.cb = sizeof(STARTUPINFO);
|
||||
st_info.lpTitle = NULL; /* No window title, just exec name */
|
||||
|
|
@ -600,11 +432,11 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
st_info.hStdOutput = child_stdout;
|
||||
st_info.hStdError = child_stderr;
|
||||
ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION));
|
||||
|
||||
/* Command is passed as is from argv. It is responsibility of
|
||||
higher level interface to decide, whenever arguments should be
|
||||
quoted or left as-is. */
|
||||
argv = si_copy_to_simple_base_string(argv);
|
||||
argv = ecl_null_terminated_base_string(argv);
|
||||
/* ecl_null_terminated_base_string(argv); */
|
||||
ok = CreateProcess(NULL, argv->base_string.self,
|
||||
NULL, NULL, /* lpProcess/ThreadAttributes */
|
||||
TRUE, /* Inherit handles (for files) */
|
||||
|
|
@ -629,7 +461,6 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
LocalFree(message);
|
||||
pid = ECL_NIL;
|
||||
}
|
||||
set_external_process_pid(process, pid);
|
||||
if (child_stdin) CloseHandle(child_stdin);
|
||||
if (child_stdout) CloseHandle(child_stdout);
|
||||
if (child_stderr) CloseHandle(child_stderr);
|
||||
|
|
@ -643,12 +474,13 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
|
||||
create_descriptor(input, @':input', &child_stdin, &parent_write);
|
||||
create_descriptor(output, @':output', &child_stdout, &parent_read);
|
||||
if (error == @':output')
|
||||
if (error == @':output') {
|
||||
child_stderr = child_stdout;
|
||||
parent_error = dup(parent_read);
|
||||
}
|
||||
else
|
||||
create_descriptor(error, @':output', &child_stderr, &parent_error);
|
||||
|
||||
add_external_process(the_env, process);
|
||||
pipe(pipe_fd);
|
||||
child_pid = fork();
|
||||
if (child_pid == 0) {
|
||||
|
|
@ -681,7 +513,7 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
}
|
||||
if (!Null(environ)) {
|
||||
char **pstrings;
|
||||
cl_object buffer = from_list_to_execve_argument(environ, &pstrings);
|
||||
from_list_to_execve_argument(environ, &pstrings);
|
||||
execve((char*)command->base_string.self, (char **)argv_ptr, pstrings);
|
||||
} else {
|
||||
execvp((char*)command->base_string.self, (char **)argv_ptr);
|
||||
|
|
@ -695,13 +527,9 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
} else {
|
||||
pid = ecl_make_fixnum(child_pid);
|
||||
}
|
||||
set_external_process_pid(process, pid);
|
||||
{
|
||||
/* This guarantees that the child process does not exit
|
||||
* before we have created the process structure. If we do not
|
||||
* do this, the SIGPIPE signal may arrive before
|
||||
* set_external_process_pid() and our call to external-process-wait
|
||||
* down there may block indefinitely. */
|
||||
/* This guarantees that the child process does not exit before
|
||||
* we have created the process structure. */
|
||||
char sync[1];
|
||||
close(pipe_fd[0]);
|
||||
while (write(pipe_fd[1], sync, 1) < 1) {
|
||||
|
|
@ -716,10 +544,11 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
}
|
||||
#else /* NACL */
|
||||
{
|
||||
FElibc_error("ext::run-program not implemented",1);
|
||||
FElibc_error("ext::run-program-inner not implemented",1);
|
||||
@(return ECL_NIL);
|
||||
}
|
||||
#endif
|
||||
|
||||
if (Null(pid)) {
|
||||
if (parent_write) close(parent_write);
|
||||
if (parent_read) close(parent_read);
|
||||
|
|
@ -727,45 +556,11 @@ si_run_program_internal(cl_object command, cl_object argv,
|
|||
parent_write = 0;
|
||||
parent_read = 0;
|
||||
parent_error = 0;
|
||||
remove_external_process(the_env, process);
|
||||
FEerror("Could not spawn subprocess to run ~S.", 1, command);
|
||||
}
|
||||
if (parent_write > 0) {
|
||||
stream_write = ecl_make_stream_from_fd(command, parent_write,
|
||||
ecl_smm_output, 8,
|
||||
ECL_STREAM_DEFAULT_FORMAT,
|
||||
external_format);
|
||||
} else {
|
||||
parent_write = 0;
|
||||
stream_write = cl_core.null_stream;
|
||||
}
|
||||
if (parent_read > 0) {
|
||||
stream_read = ecl_make_stream_from_fd(command, parent_read,
|
||||
ecl_smm_input, 8,
|
||||
ECL_STREAM_DEFAULT_FORMAT,
|
||||
external_format);
|
||||
} else {
|
||||
parent_read = 0;
|
||||
stream_read = cl_core.null_stream;
|
||||
}
|
||||
if (parent_error > 0) {
|
||||
stream_error = ecl_make_stream_from_fd(command, parent_error,
|
||||
ecl_smm_input, 8,
|
||||
ECL_STREAM_DEFAULT_FORMAT,
|
||||
external_format);
|
||||
} else {
|
||||
parent_error = 0;
|
||||
stream_error = cl_core.null_stream;
|
||||
}
|
||||
set_external_process_streams(process, stream_write, stream_read,
|
||||
stream_error);
|
||||
if (!Null(wait)) {
|
||||
exit_status = si_external_process_wait(2, process, ECL_T);
|
||||
exit_status = ecl_nth_value(the_env, 1);
|
||||
}
|
||||
@(return ((parent_read || parent_write)?
|
||||
cl_make_two_way_stream(stream_read, stream_write) :
|
||||
ECL_NIL)
|
||||
exit_status
|
||||
process);
|
||||
|
||||
@(return pid
|
||||
ecl_make_fixnum(parent_write)
|
||||
ecl_make_fixnum(parent_read)
|
||||
ecl_make_fixnum(parent_error))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -21,16 +21,14 @@
|
|||
while line
|
||||
collect line)))
|
||||
(handler-case
|
||||
(multiple-value-bind (stream process)
|
||||
(ext:run-program command args :input nil :output :stream :error :output)
|
||||
(let ((lines (collect-lines stream)))
|
||||
(let ((lines (collect-lines (si:run-program-inner command args nil))))
|
||||
(cond ((null file)
|
||||
lines)
|
||||
((probe-file file)
|
||||
(with-open-file (s file :direction :input)
|
||||
(collect-lines s)))
|
||||
(t
|
||||
(warn "Unable to find file ~A" file)))))
|
||||
(warn "Unable to find file ~A" file))))
|
||||
(error (c)
|
||||
(format t "~&;;; Unable to execute program ~S~&;;; Condition~&;;; ~A"
|
||||
command c)))))
|
||||
|
|
|
|||
|
|
@ -18,15 +18,6 @@
|
|||
#+(and cygwin (not ecl-min))
|
||||
(ffi:clines "#include <stdlib.h>")
|
||||
|
||||
(defun safe-system (string)
|
||||
(cmpnote "Invoking external command:~% ~A~%" string)
|
||||
(let ((result (ext:system string)))
|
||||
(unless (zerop result)
|
||||
(cerror "Continues anyway."
|
||||
"(SYSTEM ~S) returned non-zero value ~D"
|
||||
string result))
|
||||
result))
|
||||
|
||||
(defun save-directory (forms)
|
||||
(let ((directory
|
||||
(probe-file (make-pathname :name nil :type nil
|
||||
|
|
@ -42,35 +33,24 @@
|
|||
(defmacro with-current-directory (&body forms)
|
||||
`(save-directory #'(lambda () ,@forms)))
|
||||
|
||||
#+(and cygwin (not ecl-min))
|
||||
(defun old-crappy-system (program args)
|
||||
(let* ((command (format nil "~S~{ ~S~}" program args))
|
||||
(base-string-command (si:copy-to-simple-base-string command))
|
||||
(code (ffi:c-inline (base-string-command) (:object) :int
|
||||
"system((const char*)(#0->base_string.self))":one-liner t)))
|
||||
(values nil code nil)))
|
||||
|
||||
(defun safe-run-program (program args)
|
||||
(cmpnote "Invoking external command:~% ~A ~{~A ~}" program args)
|
||||
(multiple-value-bind (stream result process)
|
||||
(let ((result
|
||||
(let* ((*standard-output* ext:+process-standard-output+)
|
||||
(*error-output* ext:+process-error-output+)
|
||||
(program (split-program-options program))
|
||||
(args `(,@(cdr program) ,@args))
|
||||
(program (car program)))
|
||||
(with-current-directory
|
||||
#-(and cygwin (not ecl-min))
|
||||
(ext:run-program program args :input nil :output t :error t :wait t)
|
||||
#+(and cygwin (not ecl-min))
|
||||
(old-crappy-system program args)
|
||||
))
|
||||
#-windows (nth-value 1 (si:run-program-inner program args nil))
|
||||
#+windows (si:system (format nil "~A~{ ~A~}" program args))))))
|
||||
(cond ((null result)
|
||||
(cerror "Continues anyway."
|
||||
"Unable to execute:~%(RUN-PROGRAM ~S ~S)"
|
||||
"Unable to execute:~%(SI:RUN-PROGRAM-INNER ~S ~S NIL)"
|
||||
program args result))
|
||||
((not (zerop result))
|
||||
(cerror "Continues anyway."
|
||||
"Error code ~D when executing~%(RUN-PROGRAM ~S ~S)"
|
||||
"Error code ~D when executing~%(SI:RUN-PROGRAM-INNER ~S ~S NIL)"
|
||||
result program args)))
|
||||
result))
|
||||
|
||||
|
|
|
|||
|
|
@ -1329,6 +1329,15 @@
|
|||
(values (or null two-way-stream)
|
||||
(or null integer)
|
||||
ext:external-process))
|
||||
(proclamation si:waitpid (fixnum gen-bool) (values
|
||||
(or null keyword)
|
||||
(or null fixnum)
|
||||
(or null fixnum)))
|
||||
(proclamation si:killpid (fixnum fixnum) fixnum)
|
||||
(proclamation si:run-program-inner (string (or list string) list)
|
||||
(values two-way-stream integer))
|
||||
(proclamation si:spawn-subprocess (string (or list string) list t t t)
|
||||
(values (or null integer) fixnum fixnum fixnum))
|
||||
(proclamation ext:terminate-process (t &optional gen-bool) null)
|
||||
|
||||
(proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects)
|
||||
|
|
|
|||
|
|
@ -938,8 +938,8 @@
|
|||
;; setf.lsp
|
||||
si::do-defsetf si::do-define-setf-method
|
||||
;; process.lsp
|
||||
ext:system
|
||||
ext:run-program
|
||||
ext:terminate-process
|
||||
;; pprint.lsp
|
||||
pprint-fill copy-pprint-dispatch pprint-dispatch
|
||||
pprint-linear pprint-newline pprint-tab pprint-tabular
|
||||
|
|
|
|||
|
|
@ -340,10 +340,8 @@
|
|||
:if-does-not-exist :create)
|
||||
(write-line "id ICON \"ecl.ico\"" s))
|
||||
(ext:copy-file #p"src:util;ecl.ico" "ecl.ico")
|
||||
#+msvc
|
||||
(ext:run-program "rc" '("/r" "ecl.rc"))
|
||||
#-msvc
|
||||
(ext:run-program "windres" '("ecl.rc" "-O" "coff" "ecl.res")))
|
||||
#+msvc (ext:system "rc /r ecl.rc")
|
||||
#-msvc (ext:system "windres ecl.rc -O coff ecl.res"))
|
||||
|
||||
(si::pathname-translations "SYS" '(("**;*.*.*" "@true_builddir@/**/*.*")))
|
||||
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@
|
|||
* CDR Extensions::
|
||||
@end menu
|
||||
|
||||
@ System building
|
||||
@c System building
|
||||
@include extensions/building.txi
|
||||
|
||||
@node Operating System Interface
|
||||
@section Operating System Interface
|
||||
@c Operating System Interface
|
||||
@include extensions/osi.txi
|
||||
|
||||
@c Foreign function interface
|
||||
@include extensions/ffi.txi
|
||||
|
|
@ -41,8 +41,8 @@
|
|||
@node Signals and Interrupts
|
||||
@section Signals and Interrupts
|
||||
|
||||
@node Memory Management
|
||||
@section Memory Management
|
||||
@c Memory Management
|
||||
@include extensions/memory.txi
|
||||
|
||||
@node Meta-Object Protocol (MOP)
|
||||
@section Meta-Object Protocol (MOP)
|
||||
|
|
|
|||
18
src/doc/new-doc/extensions/memory.txi
Normal file
18
src/doc/new-doc/extensions/memory.txi
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
@node Memory Management
|
||||
@section Memory Management
|
||||
|
||||
@menu
|
||||
* Memory Managament Introduction::
|
||||
* Boehm-Weiser garbage collector::
|
||||
* Memory limits::
|
||||
* Memory conditions::
|
||||
* Finalization::
|
||||
* Memory Managament Reference::
|
||||
@end menu
|
||||
|
||||
@node Memory Managament Introduction
|
||||
@node Boehm-Weiser garbage collector
|
||||
@node Memory limits
|
||||
@node Memory conditions
|
||||
@node Finalization
|
||||
@node Memory Managament Reference
|
||||
354
src/doc/new-doc/extensions/osi.txi
Normal file
354
src/doc/new-doc/extensions/osi.txi
Normal file
|
|
@ -0,0 +1,354 @@
|
|||
@node Operating System Interface
|
||||
@section Operating System Interface
|
||||
|
||||
@menu
|
||||
* Command line arguments::
|
||||
* External processes::
|
||||
@c * Signals and interrupts::
|
||||
* Operating System Interface Reference::
|
||||
@end menu
|
||||
|
||||
@cindex Command line processing
|
||||
@node Command line arguments
|
||||
@subsection Command line arguments
|
||||
@deftypevar string ext:*help-message*
|
||||
Command line help message. Initial value is ECL help message. This
|
||||
variable contains the help message which is output when ECL is invoked
|
||||
with the @code{--help}.
|
||||
@end deftypevar
|
||||
|
||||
@deftypevar list-of-pathname-designators ext:*lisp-init-file-list*
|
||||
ECL initialization files. Initial value is @code{'("~/.ecl"
|
||||
"~/.eclrc")}. This variable contains the names of initialization files
|
||||
that are loaded by ECL or embedding programs. The loading of
|
||||
initialization files happens automatically in ECL unless invoked with
|
||||
the option @code{--norc}. Whether initialization files are loaded or
|
||||
not is controlled by the command line options rules, as described in
|
||||
@code{ext:process-command-args}.
|
||||
@end deftypevar
|
||||
|
||||
@deftypevar list-of-lists ext:+default-command-arg-rules+
|
||||
ECL command line options. This constant contains a list of rules for
|
||||
parsing the command line arguments. This list is made of all the
|
||||
options which ECL accepts by default. It can be passed as first
|
||||
argument to @code{ext:process-command-args}, and you can use it as a
|
||||
starting point to extend ECL.
|
||||
@end deftypevar
|
||||
|
||||
@defun ext:command-args
|
||||
Original list of command line arguments. This function returns the
|
||||
list of command line arguments passed to either ECL or the program it
|
||||
was embedded in. The output is a list of strings and it corresponds to
|
||||
the argv vector in a C program. Typically, the first argument is the
|
||||
name of the program as it was invoked. You should not count on ths
|
||||
filename to be resolved.
|
||||
@end defun
|
||||
|
||||
@defun ext:process-command-args &key args rules
|
||||
|
||||
@defvr argument args
|
||||
A list of strings. Defaults to the output of @code{ext:command-args}.
|
||||
@end defvr
|
||||
@defvr argument rules
|
||||
A list of lists. Defaults to the value of
|
||||
@code{ext:+default-command-arg-rules+}.
|
||||
@end defvr
|
||||
|
||||
This function processes the command line arguments passed to either
|
||||
ECL or the program that embeds it. It uses the list of rules rules,
|
||||
which has the following syntax:
|
||||
|
||||
@code{(option-name nargs template [:stop | :noloadrc | :loadrc]*)}
|
||||
|
||||
@defvr opt option-name
|
||||
A string with the option prefix as typed by the user. For instance
|
||||
@code{--help}, @code{-?}, @code{--compile}, etc.
|
||||
@end defvr
|
||||
|
||||
@defvr opt nargs
|
||||
A non-negative integer denoting the number of arguments taken by this
|
||||
option.
|
||||
@end defvr
|
||||
|
||||
@defvr opt template
|
||||
A lisp form, not evaluated, where numbers from 0 to nargs will be
|
||||
replaced by the corresponding option argument.
|
||||
@end defvr
|
||||
|
||||
@defvr opt :STOP
|
||||
If present, parsing of arguments stops after this option is found and
|
||||
processed. The list of remaining arguments is passed to the
|
||||
rule. ECL's top-level uses this option with the @code{--} command line
|
||||
option to set @code{ext:*unprocessed-ecl-command-args*} to the list of
|
||||
remaining arguments.
|
||||
@end defvr
|
||||
|
||||
@defvr opt :NOLOADRC
|
||||
@defvrx opt :LOADRC
|
||||
Determine whether the lisp initalization file
|
||||
@code{(ext:*lisp-init-file-list*)} will be loaded before processing
|
||||
all forms.
|
||||
@end defvr
|
||||
|
||||
@code{ext:process-command-args} works as follows. First of all, it
|
||||
parses all the command line arguments, except for the first one, which
|
||||
is assumed to contain the program name. Each of these arguments is
|
||||
matched against the rules, sequentially, until one of the patterns
|
||||
succeeeds.
|
||||
|
||||
A special name @code{*DEFAULT*}, matches any unknown command line
|
||||
option. If there is no @code{*DEFAULT*} rule and no match is found, an
|
||||
error is signalled. For each rule that succeeds, the function
|
||||
constructs a lisp statement using the template.
|
||||
|
||||
After all arguments have been processed,
|
||||
@code{ext:process-command-args}, and there were no occurences of
|
||||
@code{:noloadrc}, one of the files listed in
|
||||
@code{ext:*lisp-init-file-list*} will be loaded. Finally, the list of
|
||||
lisp statements will be evaluated.
|
||||
@end defun
|
||||
|
||||
@cindex Parsing arguments in standalone executable
|
||||
@exindex LS implementation
|
||||
|
||||
The following piece of code implements the ls command using
|
||||
lisp. Instructions for building this program are found under
|
||||
@code{ecl/examples/cmdline/ls.lsp}.
|
||||
|
||||
@lisp
|
||||
@verbatim
|
||||
(setq ext:*help-message* "
|
||||
ls [--help | -?] filename*
|
||||
Lists the file that match the given patterns.
|
||||
")
|
||||
|
||||
(defun print-directory (pathnames)
|
||||
(format t "~{~A~%~}"
|
||||
(mapcar #'(lambda (x) (enough-namestring x (si::getcwd)))
|
||||
(mapcan #'directory (or pathnames '("*.*" "*/"))))))
|
||||
|
||||
(defconstant +ls-rules+
|
||||
'(("--help" 0 (progn (princ ext:*help-message* *standard-output*) (ext:quit 0)))
|
||||
("-?" 0 (progn (princ ext:*help-message* *standard-output*) (ext:quit 0)))
|
||||
("*DEFAULT*" 1 (print-directory 1) :stop)))
|
||||
|
||||
(let ((ext:*lisp-init-file-list* NIL)) ; No initialization files
|
||||
(handler-case (ext:process-command-args :rules +ls-rules+)
|
||||
(error (c)
|
||||
(princ ext:*help-message* *error-output*)
|
||||
(ext:quit 1))))
|
||||
(ext:quit 0)
|
||||
@end verbatim
|
||||
@end lisp
|
||||
|
||||
@cindex External processes
|
||||
@node External processes
|
||||
@subsection External processes
|
||||
|
||||
ECL provides several facilities for invoking and communicating with
|
||||
@code{ext:external-process}. If one just wishes to execute some
|
||||
program, without caring for its output, then probably
|
||||
@code{ext:system} is the best function. In all other cases it is
|
||||
preferable to use @code{ext:run-program}, which opens pipes to
|
||||
communicate with the program and manipulate it while it runs on the
|
||||
background.
|
||||
|
||||
External process is a structure created with @code{ext:run-program}
|
||||
(returned as third value). It is programmer responsibility, to call
|
||||
@code{ext:external-process-wait} on finished processes, however during
|
||||
garbage collection object will be finalized.
|
||||
|
||||
@defun ext:external-process-pid process
|
||||
Returns process PID or @code{nil} if already finished.
|
||||
@end defun
|
||||
|
||||
@defun ext:external-process-status process
|
||||
Updates process status. @code{ext:external-process-status} calls
|
||||
@code{ext:external-process-wait} if proces has not finished yet
|
||||
(non-blocking call). Returns two values:
|
||||
|
||||
@code{status} - member of @code{(:abort :error :exited :signalled
|
||||
:stopped :resumed :running)}
|
||||
|
||||
@code{code} - if process exited it is a returned value, if terminated
|
||||
it is a signal code. Otherwise NIL.
|
||||
@end defun
|
||||
|
||||
@defun ext:external-process-wait proces wait
|
||||
If the second argument is non-NIL, function blocks until external
|
||||
process is finished. Otherwise status is updated. Returns two values
|
||||
(see @code{ext:external-process-status}).
|
||||
@end defun
|
||||
|
||||
@defun ext:terminate-process process &optional force
|
||||
Terminates external process.
|
||||
@end defun
|
||||
|
||||
@defun ext:external-process-input process
|
||||
@defunx ext:external-process-output process
|
||||
@defunx ext:external-process-error-stream process
|
||||
Process stream accessors (read-only).
|
||||
@end defun
|
||||
|
||||
@lspindex ext:run-program
|
||||
@defun ext:run-program command argv @
|
||||
&key input output error wait environ @
|
||||
if-input-does-not-exist if-output-exists if-error-exists @
|
||||
external-format #+windows escape-arguments
|
||||
|
||||
@code{run-program} creates a new process specified by the
|
||||
@var{command} argument. @var{argv} are the standard arguments that can
|
||||
be passed to a program. For no arguments, use @code{nil} (which means
|
||||
that just the name of the program is passed as arg 0).
|
||||
|
||||
@code{run-program} will return three values - two-way stream for
|
||||
communication, return code or @code{nil} (if process is called
|
||||
asynchronously), and @code{ext:external-process} object holding
|
||||
process state.
|
||||
|
||||
It is programmer responsibility to call
|
||||
@code{ext:external-process-wait} on finished process, however ECL
|
||||
associates @ref{Finalization, finalizer} with the object calling it
|
||||
when the object is garbage collected. If process didn't finish but is
|
||||
not referenced, finalizer will be invoked once more during next
|
||||
garbage collection.
|
||||
|
||||
The @code{&key} arguments have the following meanings:
|
||||
|
||||
@defvr argument input
|
||||
Either @code{t}, @code{nil}, a pathname, a string, a stream or
|
||||
@code{:stream}. If @code{t} the standard input for the current process
|
||||
is inherited. If @code{nil}, @code{/dev/null} is used. If a pathname
|
||||
(or a string), the file so specified is used. If a stream, all the
|
||||
input is read from that stream and sent to the subprocess - stream
|
||||
must be ANSI stream (no in-memory virtual streams). If @code{:stream},
|
||||
the @code{external-process-input} slot is filled in with a stream that
|
||||
sends its output to the process. Defaults to @code{:stream}.
|
||||
@end defvr
|
||||
|
||||
@defvr argument if-input-does-not-exist
|
||||
can be one of: @code{:error} to generate an error @code{:create} to
|
||||
create an empty file @code{nil} (the default) to return nil from
|
||||
@code{run-program}
|
||||
@end defvr
|
||||
|
||||
@defvr argument output
|
||||
Either @code{t}, @code{nil}, a pathname, a string, a stream, or
|
||||
@code{:stream}. If @code{t}, the standard output for the current
|
||||
process is inherited. If @code{nil}, @code{/dev/null} is used. If a
|
||||
pathname (or as string), the file so specified is used. If a stream,
|
||||
all the output from the process is written to this stream - stream
|
||||
must be ANSI stream (no in-memory virtual streams). If @code{:stream},
|
||||
the @code{external-process-output} slot is filled in with a stream
|
||||
that can be read to get the output. Defaults to @code{stream}.
|
||||
@end defvr
|
||||
|
||||
@defvr argument if-output-exists
|
||||
@end defvr
|
||||
|
||||
@defvr argument error
|
||||
Same as @code{:output}, except that @code{:error} can also be
|
||||
specified as @code{:output} in which case all error output is routed
|
||||
to the same place as normal output. Defaults to @code{:output}.
|
||||
@end defvr
|
||||
|
||||
@defvr argument if-error-exists
|
||||
Same as @code{:if-output-exists}.
|
||||
@end defvr
|
||||
|
||||
@defvr argument wait
|
||||
If non-NIL (default), wait until the created process finishes. If
|
||||
@code{nil}, continue running Lisp until the program finishes.
|
||||
@end defvr
|
||||
|
||||
@defvr argument environ
|
||||
A list of STRINGs describing the new Unix environment (as in "man
|
||||
environ"). The default is to copy the environment of the current
|
||||
process. To extend existing environment (instead of replacing it),
|
||||
use @code{:environ (append *my-env* (ext:environ))}.
|
||||
|
||||
If non-NIL @code{environ} argument is supplied, then first argument to
|
||||
@code{ext:run-program} @code{command} must be full path to the file.
|
||||
@end defvr
|
||||
|
||||
@defvr argument external-format
|
||||
The external-format to use for @code{:input}, @code{:output}, and
|
||||
@code{:error} STREAMs.
|
||||
@end defvr
|
||||
|
||||
@emph{Windows specific options:}
|
||||
@defvr argument escape-arguments
|
||||
Controls escaping of the arguments passed to CreateProcess.
|
||||
@end defvr
|
||||
@end defun
|
||||
|
||||
@node Operating System Interface Reference
|
||||
@subsection Operating System Interface Reference
|
||||
|
||||
@c environment routines
|
||||
|
||||
@c Don't advertise argc and argv, we have command-args
|
||||
|
||||
@c @defun ext:argc
|
||||
@c @end defun
|
||||
|
||||
@c @defun ext:argv
|
||||
@c @end defun
|
||||
|
||||
@defun ext:system command
|
||||
Run shell command ignoring its output. Uses fork.
|
||||
@end defun
|
||||
|
||||
@defun ext:make-pipe
|
||||
Creates a pipe and wraps it in a two way stream.
|
||||
@end defun
|
||||
|
||||
|
||||
@defun ext:quit &optional exit-code kill-all-threads
|
||||
This function abruptly stops the execution of the program in which ECL
|
||||
is embedded. Depending on the platform, several other functions will
|
||||
be invoked to free resources, close loaded modules, etc.
|
||||
|
||||
The exit code is the code seen by the parent process that invoked this
|
||||
program. Normally a code other than zero denotes an error.
|
||||
|
||||
If @code{kill-all-threads} is non-NIL, tries to gently kill and join
|
||||
with running threads.
|
||||
@end defun
|
||||
|
||||
@defun ext:environ
|
||||
@defunx ext:getenv variable
|
||||
@defunx ext:setenv variable value
|
||||
Environment accessors.
|
||||
@end defun
|
||||
|
||||
|
||||
@c UNIX shell interface
|
||||
|
||||
@defun ext:getpid
|
||||
@defunx ext:getuid
|
||||
@defunx ext:getcwd
|
||||
@defunx ext:chdir
|
||||
@defunx ext:file-kind
|
||||
@defunx ext:copy-file
|
||||
@defunx ext:chmod
|
||||
Common operating system functions.
|
||||
@end defun
|
||||
|
||||
@c Internal UNIX shell interface
|
||||
|
||||
@c @defun si:mkdir
|
||||
@c @defunx si:rmdir
|
||||
@c @defunx si:mkstemp
|
||||
@c @defunx si:copy-file
|
||||
@c @end defun
|
||||
|
||||
@c @defun si:get-library-pathname
|
||||
@c @end defun
|
||||
|
||||
@c @defun si:waitpid pid wait
|
||||
@c @defunx si:kill pid signal
|
||||
@c @end defun
|
||||
|
||||
@c @defun si:run-program-inner command argv environ
|
||||
@c @end defun
|
||||
|
|
@ -251,9 +251,6 @@ struct cl_core_struct {
|
|||
cl_object rehash_size;
|
||||
cl_object rehash_threshold;
|
||||
|
||||
cl_object external_processes;
|
||||
cl_object external_processes_lock;
|
||||
|
||||
cl_object known_signals;
|
||||
};
|
||||
|
||||
|
|
@ -945,7 +942,6 @@ typedef enum {
|
|||
ECL_OPT_TRAP_SIGILL,
|
||||
ECL_OPT_TRAP_SIGBUS,
|
||||
ECL_OPT_TRAP_SIGPIPE,
|
||||
ECL_OPT_TRAP_SIGCHLD,
|
||||
ECL_OPT_TRAP_INTERRUPT_SIGNAL,
|
||||
ECL_OPT_SIGNAL_HANDLING_THREAD,
|
||||
ECL_OPT_SIGNAL_QUEUE_SIZE,
|
||||
|
|
@ -1888,9 +1884,18 @@ extern ECL_API void ecl_check_pending_interrupts(cl_env_ptr env);
|
|||
extern ECL_API cl_object si_system(cl_object cmd);
|
||||
extern ECL_API cl_object si_make_pipe();
|
||||
extern ECL_API cl_object si_run_program _ECL_ARGS((cl_narg narg, cl_object command, cl_object args, ...));
|
||||
extern ECL_API cl_object si_external_process_wait _ECL_ARGS((cl_narg narg, cl_object h, ...));
|
||||
extern ECL_API cl_object si_close_windows_handle(cl_object h);
|
||||
extern ECL_API cl_object si_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...));
|
||||
extern ECL_API cl_object si_waitpid(cl_object pid, cl_object wait);
|
||||
extern ECL_API cl_object si_killpid(cl_object pid, cl_object signal);
|
||||
|
||||
extern ECL_API cl_object si_run_program_inner
|
||||
(cl_object command, cl_object argv, cl_object environ);
|
||||
|
||||
extern ECL_API cl_object si_spawn_subprocess
|
||||
(cl_object command, cl_object argv, cl_object environ,
|
||||
cl_object input, cl_object output, cl_object error);
|
||||
|
||||
|
||||
/* unicode -- no particular file, but we group these changes here */
|
||||
|
||||
|
|
|
|||
|
|
@ -526,11 +526,6 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock);
|
|||
extern void ecl_interrupt_process(cl_object process, cl_object function);
|
||||
|
||||
/* unixsys.d */
|
||||
extern cl_object si_wait_for_all_processes _ECL_ARGS((cl_narg narg, ...));
|
||||
extern cl_object si_run_program_internal
|
||||
(cl_object command, cl_object argv,
|
||||
cl_object input, cl_object output, cl_object error,
|
||||
cl_object wait, cl_object environ, cl_object external_format);
|
||||
|
||||
/*
|
||||
* Fake several ISO C99 mathematical functions if not available
|
||||
|
|
|
|||
|
|
@ -1,39 +1,76 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
|
||||
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
||||
|
||||
;;;;
|
||||
;;;; PROCESS.LSP -- External processes
|
||||
;;;; process.lsp -- External processes.
|
||||
|
||||
;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll
|
||||
;;;; Copyright (c) 2017, Daniel Kochmański
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
;;;; See file 'LICENSE' for the copyright details.
|
||||
|
||||
(in-package "EXT")
|
||||
|
||||
(defmacro with-process-lock ((process) &body body)
|
||||
`(mp:with-lock ((external-process-%lock process))
|
||||
,@body))
|
||||
|
||||
(defstruct (external-process (:constructor make-external-process ()))
|
||||
pid
|
||||
input
|
||||
output
|
||||
error-stream
|
||||
(%status :running)
|
||||
(%code nil))
|
||||
(%code nil)
|
||||
(%lock (mp:make-lock)))
|
||||
|
||||
(defun external-process-status (external-process)
|
||||
(let ((status (external-process-%status external-process)))
|
||||
(if (eq status :running)
|
||||
(if (member status (:stopped :resumed :running))
|
||||
(ext:external-process-wait external-process nil)
|
||||
(values status (external-process-%code external-process)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; si:waitpid -> (values status code pid)
|
||||
;;; ---------------------------------------------------------------------
|
||||
;;; no change :: (values nil nil nil)
|
||||
;;; error :: (values (member :abort :error) nil nil)
|
||||
;;; finished :: (values (member :exited :signalled) code pid)
|
||||
;;; running :: (values (member :stopped :resumed :running) code pid)
|
||||
;;; ---------------------------------------------------------------------
|
||||
(defun external-process-wait (process &optional wait)
|
||||
(with-process-lock (process)
|
||||
(let ((pid (external-process-pid process)))
|
||||
(when pid
|
||||
(multiple-value-bind (status code pid) (si:waitpid pid wait)
|
||||
(ecase status
|
||||
((:exited :signaled :abort :error)
|
||||
(setf (external-process-pid process) nil
|
||||
(external-process-%status process) status
|
||||
(external-process-%code process) code))
|
||||
((:stopped :resumed :running)
|
||||
(setf (external-process-%status process) status
|
||||
(external-process-%code process) code))
|
||||
((nil) #| wait was nil and process didn't change |#))))))
|
||||
(values (external-process-%status process)
|
||||
(external-process-%code process)))
|
||||
|
||||
(defun terminate-process (process &optional force)
|
||||
(with-process-lock (process)
|
||||
(let ((pid (external-process-pid process)))
|
||||
(when pid
|
||||
#+windows
|
||||
(ffi:c-inline
|
||||
(process pid) (:object :object) :void
|
||||
"HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1);
|
||||
int ret = TerminateProcess(*ph, -1);
|
||||
if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);")
|
||||
#-windows
|
||||
(unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+)))
|
||||
(error "Cannot terminate the process ~A" process))))))
|
||||
|
||||
;;;
|
||||
;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system()
|
||||
;;; because we are consuming the process wait status using a SIGCHLD
|
||||
;;; handler -- this breaks some C libraries out there (OS X 32 bit).
|
||||
;;;
|
||||
#+ (or)
|
||||
(defun system (cmd-string)
|
||||
(let ((shell "/bin/sh")
|
||||
(option "-c"))
|
||||
|
|
@ -46,10 +83,16 @@
|
|||
:wait t :output nil :input nil :error nil
|
||||
#+windows :escape-arguments #+windows nil))))
|
||||
|
||||
;;; We don't handle `sigchld' because we don't want races with
|
||||
;;; `external-process-wait'. Take care of forgotten processes.
|
||||
(defun finalize-external-process (process)
|
||||
(unless (member (ext:external-process-wait process nil)
|
||||
'(:exited :signaled :abort :error))
|
||||
(ext:set-finalizer process #'finalize-external-process)))
|
||||
|
||||
;;;
|
||||
;;; Wrapper around si_run_program call. Thanks to that C interface
|
||||
;;; isn't clobbered with lispisms. Ultimately we'd want to have as
|
||||
;;; little as possible in unixsys.d.
|
||||
;;; Almighty EXT:RUN-PROGRAM. Built on top of SI:SPAWN-SUBPROCESS. For
|
||||
;;; simpler alternative see SI:RUN-PROGRAM-INNER.
|
||||
;;;
|
||||
(defun run-program (command argv
|
||||
&key
|
||||
|
|
@ -64,21 +107,28 @@
|
|||
(external-format :default)
|
||||
#+windows (escape-arguments t))
|
||||
|
||||
(flet ((process-stream (which default &rest args)
|
||||
(cond ((eql which t) default)
|
||||
(labels ((process-stream (which default &rest args)
|
||||
(cond ((eql which t)
|
||||
default)
|
||||
((eql which nil)
|
||||
(null-stream (getf args :direction)))
|
||||
((or (stringp which) (pathnamep which))
|
||||
(apply #'open which :external-format external-format args))
|
||||
;; this three cases are handled in create_descriptor (for now)
|
||||
((eql which nil) which)
|
||||
((eql which :stream) which)
|
||||
((streamp which) which)
|
||||
#+(and (or) clos-streams threads)
|
||||
((and (streamp which)
|
||||
(null (typep which 'ext:ansi-stream)))
|
||||
#| Here we may want to return `:stream' and spawn
|
||||
thread to handle data at runtime to fd. |#)
|
||||
((or (eql which :stream)
|
||||
(streamp which))
|
||||
which)
|
||||
;; signal error as early as possible
|
||||
(T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which))))
|
||||
|
||||
(prepare-args (args)
|
||||
#-windows
|
||||
(mapcar #'si:copy-to-simple-base-string args)
|
||||
#+windows
|
||||
(si:copy-to-simple-base-string
|
||||
(with-output-to-string (str)
|
||||
(loop for (arg . rest) on args
|
||||
do (if (and escape-arguments
|
||||
|
|
@ -89,26 +139,52 @@
|
|||
(princ arg str))
|
||||
(when rest
|
||||
(write-char #\Space str))))))
|
||||
(null-stream (direction)
|
||||
(open #-windows "/dev/null"
|
||||
#+windows "nul"
|
||||
:direction direction)))
|
||||
|
||||
(setf input (process-stream input *standard-input*
|
||||
(let ((progname (si:copy-to-simple-base-string command))
|
||||
(args (prepare-args (cons command argv)))
|
||||
(environ (mapcar #'si:copy-to-simple-base-string environ))
|
||||
(process (make-external-process))
|
||||
(process-input (process-stream input *standard-input*
|
||||
:direction :input
|
||||
:if-does-not-exist if-input-does-not-exist)
|
||||
output (process-stream output *standard-output*
|
||||
:if-does-not-exist if-input-does-not-exist))
|
||||
(process-output (process-stream output *standard-output*
|
||||
:direction :output
|
||||
:if-exists if-output-exists)
|
||||
error (if (eql error :output)
|
||||
:if-exists if-output-exists))
|
||||
(process-error (if (eql error :output)
|
||||
:output
|
||||
(process-stream error *error-output*
|
||||
:direction :output
|
||||
:if-exists if-error-exists)))
|
||||
pid parent-write parent-read parent-error)
|
||||
|
||||
(let ((progname (si:copy-to-simple-base-string command))
|
||||
(args (prepare-args (cons command argv))))
|
||||
(si:run-program-internal progname args
|
||||
input output error
|
||||
wait environ external-format))))
|
||||
(multiple-value-setq (pid parent-write parent-read parent-error)
|
||||
(si:spawn-subprocess progname args environ process-input process-output process-error))
|
||||
|
||||
(let ((stream-write
|
||||
(when (< 0 parent-write)
|
||||
(make-output-stream-from-fd progname parent-write external-format)))
|
||||
(stream-read
|
||||
(when (< 0 parent-read)
|
||||
(make-input-stream-from-fd progname parent-read external-format)))
|
||||
(stream-error
|
||||
(when (< 0 parent-error)
|
||||
(make-input-stream-from-fd progname parent-error external-format))))
|
||||
|
||||
(setf (external-process-pid process) pid
|
||||
(external-process-input process) (or stream-write (null-stream :output))
|
||||
(external-process-output process) (or stream-read (null-stream :input))
|
||||
(external-process-error-stream process) (or stream-error (null-stream :input)))
|
||||
|
||||
(values (make-two-way-stream (external-process-output process)
|
||||
(external-process-input process))
|
||||
(if wait
|
||||
(nth-value 1 (si:external-process-wait process t))
|
||||
(ext:set-finalizer process #'finalize-external-process))
|
||||
process)))))
|
||||
|
||||
#+windows
|
||||
(defun escape-arg (arg stream)
|
||||
|
|
@ -140,3 +216,17 @@
|
|||
(loop repeat slashes
|
||||
do (write-char #\\ stream)))
|
||||
(write-char #\" stream))
|
||||
|
||||
|
||||
;;; low level interface to descriptors
|
||||
(defun make-input-stream-from-fd (name fd external-format)
|
||||
(ffi:c-inline
|
||||
(name fd external-format) (:string :int :object) :object
|
||||
"ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)"
|
||||
:one-liner t))
|
||||
|
||||
(defun make-output-stream-from-fd (name fd external-format)
|
||||
(ffi:c-inline
|
||||
(name fd external-format) (:string :int :object) :object
|
||||
"ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)"
|
||||
:one-liner t))
|
||||
|
|
|
|||
|
|
@ -1448,11 +1448,12 @@ package."
|
|||
(setq *console-owner* mp:*current-process*)
|
||||
;; As of ECL 9.4.1 making a normal function return from the debugger
|
||||
;; seems to be a very bad idea! Basically, it dumps core...
|
||||
(ignore-errors
|
||||
(when (listen *debug-io*)
|
||||
(clear-input *debug-io*))
|
||||
(clear-input *debug-io*)))
|
||||
;; Like in SBCL, the error message is output through *error-output*
|
||||
;; The rest of the interaction is performed through *debug-io*
|
||||
(finish-output)
|
||||
(ignore-errors (finish-output))
|
||||
;; We wrap the following in `ignore-errors' because error may be
|
||||
;; caused by writing to the `*error-output*', what leads to
|
||||
;; infinite recursion!
|
||||
|
|
|
|||
46
src/tests/auxiliary/external-process-programs.lisp
Normal file
46
src/tests/auxiliary/external-process-programs.lisp
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
(in-package #:cl-user)
|
||||
|
||||
(defmacro define-function (name &body body)
|
||||
`(defun ,name (&aux
|
||||
(argc (si:argc))
|
||||
(argv (ext:command-args)))
|
||||
(declare (ignorable argc argv))
|
||||
,@body))
|
||||
|
||||
(define-function arg-test
|
||||
(if (= argc *args-number*)
|
||||
(quit 0)
|
||||
(quit 1)))
|
||||
|
||||
(define-function print-test
|
||||
(terpri *standard-output*)
|
||||
(princ "Hello stdout" *standard-output*)
|
||||
(terpri *error-output*)
|
||||
(princ "Hello stderr" *error-output*))
|
||||
|
||||
(define-function io/err
|
||||
(princ "Welcome to ITP(NR) - Intelligent Test Program (not really)!")
|
||||
(print argc *error-output*)
|
||||
|
||||
(princ "Type your SEXP: ")
|
||||
(let ((result (read *standard-input* nil :eof)))
|
||||
(princ result *error-output*)
|
||||
(cond ((eq result :eof)
|
||||
(princ "No? Shame...")
|
||||
(quit 1))
|
||||
(:otherwise
|
||||
"Thank you. Your wish has been heard loud and clear."
|
||||
(quit 0)))))
|
||||
|
||||
(define-function terminate
|
||||
;; timeout is for case of zombies, this process should be killed
|
||||
;; from the outside.
|
||||
(sleep 10)
|
||||
(quit 0))
|
||||
|
||||
(define-function heartbeat
|
||||
(do () (nil)
|
||||
(print "heartbit")
|
||||
(sleep 1)
|
||||
(print "boombaya")
|
||||
(sleep 1)))
|
||||
|
|
@ -21,6 +21,8 @@
|
|||
when (probe-file "configure.ac")
|
||||
return *default-pathname-defaults*))
|
||||
|
||||
(setf *ecl-sources* (truename *ecl-sources*))
|
||||
|
||||
(defvar *here* (merge-pathnames "@builddir@/"))
|
||||
(defvar *cache* (merge-pathnames "./cache/" *here*))
|
||||
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
(:file "mixed")
|
||||
(:file "compiler")
|
||||
(:file "executable-cli")
|
||||
(:file "run-program")
|
||||
(:file "multiprocessing" :if-feature :threads)
|
||||
(:file "embedding" :if-feature (:not :ecl-bytecmp))
|
||||
(:file "foreign-interface" :if-feature :ffi)
|
||||
|
|
|
|||
|
|
@ -22,11 +22,11 @@
|
|||
;;;; Declare the suites
|
||||
(suite 'ecl-tests
|
||||
'(executable eformat ieee-fp eprocess package-locks ansi+ mixed
|
||||
cmp emb ffi mop mp))
|
||||
cmp emb ffi mop mp run-program))
|
||||
|
||||
(suite 'make-check
|
||||
'(executable ieee-fp eprocess package-locks ansi+ mixed cmp emb
|
||||
ffi mop))
|
||||
ffi mop run-program))
|
||||
|
||||
|
||||
;;; Some syntactic sugar for 2am
|
||||
|
|
|
|||
|
|
@ -173,27 +173,6 @@
|
|||
(fail (ext:file-stream-fd (make-string-output-stream))
|
||||
"Not-file stream would cause internal error on this ECL (skipped)")))
|
||||
|
||||
|
||||
;;;; Author: Daniel Kochmański
|
||||
;;;; Created: 2016-09-07
|
||||
;;;; Contains: External process interaction API
|
||||
;;;;
|
||||
(test mix.0011.run-program
|
||||
(let ((p (nth-value 2 (ext:run-program #-windows "sleep"
|
||||
#+windows "timeout"
|
||||
(list "3") :wait nil))))
|
||||
(is (eql :running (ext:external-process-wait p nil))
|
||||
"process doesn't run")
|
||||
(ext:terminate-process p)
|
||||
(sleep 1)
|
||||
(multiple-value-bind (status code)
|
||||
(ext:external-process-wait p nil)
|
||||
(is (eql :signaled status)
|
||||
"status is ~s, should be ~s" status :signalled)
|
||||
(is (eql ext:+sigterm+ code)
|
||||
"signal code is ~s, should be ~s" code ext:+sigterm+))
|
||||
(finishes (ext:terminate-process p))))
|
||||
|
||||
|
||||
;;; Date: 2016-12-20
|
||||
;;; Reported by: Kris Katterjohn
|
||||
|
|
|
|||
137
src/tests/normal-tests/run-program.lsp
Normal file
137
src/tests/normal-tests/run-program.lsp
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
(in-package :cl-test)
|
||||
|
||||
(suite 'run-program)
|
||||
|
||||
;;; I was wondering about the program which we could could use to test
|
||||
;;; the interface (i.e both on Linux and Windows). Easy! ECL is a
|
||||
;;; perfect program for that.
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter *binary* (si:argv 0))
|
||||
(defparameter *program* (namestring (merge-pathnames "external-process-programs.lisp" *aux-dir*))))
|
||||
|
||||
(defmacro with-run-program ((name args &rest params) &body body)
|
||||
`(multiple-value-bind (,name code process)
|
||||
(ext:run-program *binary*
|
||||
'("--norc"
|
||||
"--eval" ,(format nil "(setf *args-number* ~a)" (+ 13 (length args)))
|
||||
"--eval" "(setf *load-verbose* nil)"
|
||||
"--load" ,*program*
|
||||
"--eval" ,(format nil "(~a)" name)
|
||||
"--eval" "(quit)"
|
||||
"--" ,@args)
|
||||
,@params
|
||||
:wait nil)
|
||||
(declare (ignorable ,name code))
|
||||
(let ((result (progn ,@body)))
|
||||
(cons result (multiple-value-list (ext:external-process-wait process t))))))
|
||||
|
||||
(defun slurp (stream)
|
||||
(do ((line #1=(read-line stream nil :eof) #1#)
|
||||
(last nil line))
|
||||
((eql line :eof) last)))
|
||||
|
||||
|
||||
(test arg-test
|
||||
(is (equal '(nil :exited 0)
|
||||
(with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\
|
||||
")))) "ext:run-program doesn't escape arguments properly")
|
||||
#+windows
|
||||
(is (null (equal '(nil :exited 0)
|
||||
(with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\
|
||||
") :escape-arguments nil)))) "ext:run-program :ESCAPE-ARGUMENTS NIL doesn't work"))
|
||||
|
||||
(test output-streams
|
||||
;; error is a separate stream
|
||||
(is-equal '(("Hello stdout" "Hello stderr") :exited 0)
|
||||
(with-run-program
|
||||
(print-test nil :output :stream :error :stream)
|
||||
(let ((print-test-err (ext:external-process-error-stream process)))
|
||||
(list (slurp print-test) (slurp print-test-err)))))
|
||||
;; :error :output
|
||||
(is-equal '(("Hello stderr" nil) :exited 0)
|
||||
(with-run-program
|
||||
(print-test nil :output :stream :error :output)
|
||||
(let ((print-test-err (ext:external-process-error-stream process)))
|
||||
;; print-test-err is drained by reading from print-test
|
||||
(list (slurp print-test) (slurp print-test-err))))))
|
||||
|
||||
(test interactive-input
|
||||
(is-equal '(nil :exited 0)
|
||||
(with-run-program (io/err nil)
|
||||
(format io/err "42~%")))
|
||||
;; process will have :eof on input and should quit with "1"
|
||||
(is-equal '(nil :exited 1) (with-run-program (io/err nil :input nil)))
|
||||
)
|
||||
|
||||
(test stream-values ()
|
||||
(finishes (with-run-program (print-test nil :output nil :error nil :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output nil :error nil :input t)))
|
||||
(finishes (with-run-program (print-test nil :output nil :error nil :input :stream)))
|
||||
(finishes (with-run-program (print-test nil :output nil :error :output :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output nil :error :output :input :stream)))
|
||||
(finishes (with-run-program (print-test nil :output t :error nil :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output t :error :output :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output t :error :stream :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output t :error nil :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output t :error :output :input nil)))
|
||||
(finishes (with-run-program (print-test nil :output t :error :stream :input nil)))
|
||||
(finishes (with-run-program
|
||||
(print-test nil :output :stream :error :output :input :stream)))
|
||||
(finishes (with-run-program
|
||||
(print-test nil :output :stream :error :stream :input :stream)))
|
||||
(signals simple-error
|
||||
(with-run-program (print-test nil :output :bam :error :stream :input :stream))))
|
||||
|
||||
|
||||
(test terminate-process
|
||||
(is-equal #-windows `(t :signaled ,ext:+sigterm+)
|
||||
#+windows `(t :exited -1)
|
||||
(with-run-program (terminate nil)
|
||||
(is-eql :running (ext:external-process-wait process nil))
|
||||
(finishes (ext:terminate-process process))
|
||||
(finishes (ext:terminate-process process)) ; no-op
|
||||
(sleep 1)
|
||||
#-windows(is-eql :signaled (ext:external-process-wait process nil))
|
||||
#+windows(is-eql :exited (ext:external-process-wait process nil))
|
||||
(finishes (ext:terminate-process process))))
|
||||
(is-equal #-windows `(t :signaled ,ext:+sigkill+)
|
||||
#+windows `(t :exited -1)
|
||||
(with-run-program (terminate nil)
|
||||
(is-eql :running (ext:external-process-wait process nil))
|
||||
(finishes (ext:terminate-process process t))
|
||||
(finishes (ext:terminate-process process t)) ; no-op
|
||||
(sleep 1)
|
||||
#-windows(is-eql :signaled (ext:external-process-wait process nil))
|
||||
#+windows(is-eql :exited (ext:external-process-wait process nil))
|
||||
(finishes (ext:terminate-process process t)))))
|
||||
|
||||
;;; We may want to craft it into an interface. Suspend/Resume *is* possible on Windows:
|
||||
;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows
|
||||
#-windows
|
||||
(test suspend-resume
|
||||
(is-equal `(t :signaled ,ext:+sigkill+)
|
||||
(with-run-program (heartbeat nil)
|
||||
(let ((pid (ext:external-process-pid process)))
|
||||
(is-eql :running (ext:external-process-wait process nil))
|
||||
(si:killpid pid ext:+sigstop+)
|
||||
(sleep 2)
|
||||
(is-eql :stopped (ext:external-process-wait process nil))
|
||||
(si:killpid pid ext:+sigcont+)
|
||||
(sleep 2)
|
||||
(is-eql :resumed (ext:external-process-wait process nil))
|
||||
(finishes (ext:terminate-process process t))))))
|
||||
|
||||
;;; This test is disabled because we don't support virtual streams in
|
||||
;;; run-program yet.
|
||||
#+ (or) (test no-fd-streams
|
||||
(let ((output-stream (make-string-output-stream))
|
||||
(error-stream (make-string-output-stream)))
|
||||
(with-input-from-string (input-stream "42")
|
||||
(with-run-program (io/err nil :input input-stream
|
||||
:output output-stream
|
||||
:error error-stream)))
|
||||
(is-not (zerop (length (get-output-stream-string output-stream))))
|
||||
(is-not (zerop (length (get-output-stream-string error-stream))))
|
||||
(mapc #'close (list output-stream error-stream))))
|
||||
|
||||
Loading…
Add table
Reference in a new issue