## spawn--premicrothread.pkg -- high-level support for spawning unix child processes.
# Compiled by:
# src/lib/std/src/standard-core.sublib# See comments in spawn--premicrothread.api
### "Waiting is a very funny activity:
### you can't wait twice as fast."
###
### -- E.J. Dijkstra
stipulate
package bio = data_file__premicrothread; # data_file__premicrothread is from src/lib/std/src/posix/data-file--premicrothread.pkg package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package sig = interprocess_signals; # interprocess_signals is from src/lib/std/src/nj/interprocess-signals.pkg package pe = posixlib; # posixlib is from src/lib/std/src/psx/posixlib.pkg package pf = posixlib; # posixlib is from src/lib/std/src/psx/posixlib.pkg package pio = posixlib; # posixlib is from src/lib/std/src/psx/posixlib.pkg package psx = posixlib; # posixlib is from src/lib/std/src/psx/posixlib.pkg package is = interprocess_signals; # interprocess_signals is from src/lib/std/src/nj/interprocess-signals.pkg package sst = substring; # substring is from src/lib/std/src/substring.pkg package u1b = one_byte_unt_guts; # one_byte_unt_guts is from src/lib/std/src/one-byte-unt-guts.pkg package wt = winix_types; # winix_types is from src/lib/std/src/posix/winix-types.pkgherein
package spawn__premicrothread
: (weak) Spawn__Premicrothread # Spawn__Premicrothread is from src/lib/std/src/posix/spawn--premicrothread.api {
Exit_Status == psx::Exit_Status;
Spawn_Option
= WITH_ENVIRONMENT List(String)
| REDIRECT_STDIN_IN_CHILD Bool
| REDIRECT_STDOUT_IN_CHILD Bool
| REDIRECT_STDERR_IN_CHILD Bool
| REDIRECT_STDERR_TO_STDOUT_IN_CHILD Bool
;
Stream( A_stream )
#
= NONE
| UNOPENED pio::File_Descriptor
| OPENED { stream: A_stream,
close: Void -> Void
}
;
Process_Status
#
= ALIVE psx::Process_Id
| DEAD { status: wt::process::Status,
process_id: psx::Process_Id
}
;
Process (A_stdin_stream, A_stdout_stream, A_stderr_stream)
=
PROCESS
{ executable_name: String, # If executable was "/bin/sh", "executable_name" will be "sh".
#
stdin_to_child: Ref( Stream( A_stdin_stream ) ),
stdout_from_child: Ref( Stream( A_stdout_stream ) ),
stderr_from_child: Ref( Stream( A_stderr_stream ) ),
#
status: Ref( Process_Status )
};
fun protect f x
=
{ is::mask_signals is::MASK_ALL;
#
y = (f x)
except
ex = { is::unmask_signals is::MASK_ALL;
raise exception ex;
};
is::unmask_signals is::MASK_ALL;
y;
};
fun fd_text_reader (filename: String, file_descriptor: pio::File_Descriptor)
=
winix_text_file_io_driver_for_posix__premicrothread::make_filereader
{
filename,
file_descriptor,
ok_to_block => TRUE
};
fun fd_bin_reader (filename: String, file_descriptor: pio::File_Descriptor)
=
winix_data_file_io_driver_for_posix__premicrothread::make_filereader
{
filename,
file_descriptor,
ok_to_block => TRUE
};
fun fd_text_writer (filename, file_descriptor)
=
winix_text_file_io_driver_for_posix__premicrothread::make_filewriter
{
filename,
file_descriptor,
append_mode => FALSE,
ok_to_block => TRUE,
best_io_quantum => 4096
};
fun fd_bin_writer (filename, file_descriptor)
=
winix_data_file_io_driver_for_posix__premicrothread::make_filewriter
{
file_descriptor,
filename,
append_mode => FALSE,
ok_to_block => TRUE,
best_io_quantum => 4096
};
fun open_txt_out_fd (filename, fd)
=
fil::make_outstream (
#
fil::pur::make_outstream
(
fd_text_writer (filename, fd),
io_exceptions::BLOCK_BUFFERING
)
);
fun open_bin_out_fd (filename, fd)
=
bio::make_outstream (
#
bio::pur::make_outstream
(
fd_bin_writer (filename, fd),
io_exceptions::BLOCK_BUFFERING
)
);
fun open_txt_in_fd (filename, fd)
=
fil::make_instream (
#
fil::pur::make_instream
(
fd_text_reader (filename, fd),
""
)
);
fun open_bin_in_fd (filename, fd)
=
bio::make_instream (
#
bio::pur::make_instream
(
fd_bin_reader (filename, fd),
byte::string_to_bytes ""
)
);
fun stream_of (stream_selector, sfx, opener, closer) (PROCESS p)
=
case (stream_selector p)
#
REF (NONE ) => raise exception DIE "Cannot do I/O to non-redirected process stream";
#
REF (OPENED s) => s.stream;
#
r as REF (UNOPENED fd)
=>
{ s = opener ( p.executable_name + "_ext_" + sfx,
fd
);
r := OPENED { stream => s,
close => \\ () = closer s
};
s;
};
esac;
fun get_stdin_to_child_as_text_stream process = stream_of (.stdin_to_child, "txt_out", open_txt_out_fd, fil::close_output) process;
fun get_stdin_to_child_as_binary_stream process = stream_of (.stdin_to_child, "bin_out", open_bin_out_fd, bio::close_output) process;
fun get_stdout_from_child_as_text_stream process = stream_of (.stdout_from_child, "txt_in", open_txt_in_fd, fil::close_input ) process;
fun get_stdout_from_child_as_binary_stream process = stream_of (.stdout_from_child, "bin_in", open_bin_in_fd, bio::close_input ) process;
fun get_stderr_from_child_as_text_stream process = stream_of (.stderr_from_child, "txt_in", open_txt_in_fd, fil::close_input ) process;
fun get_stderr_from_child_as_binary_stream process = stream_of (.stderr_from_child, "bin_in", open_bin_in_fd, bio::close_input ) process;
fun text_streams_of process
=
{ stdin_to_child => get_stdin_to_child_as_text_stream process,
stdout_from_child => get_stdout_from_child_as_text_stream process
};
# Joe Wells suggests that it would be useful to optionally allow the subprocess to inherit
# one or more of stdin/stdout/stderr instead of always converting them to pipes to us.
#
# This suggests that instead of
#
# spawn_process_in_environment
# :
# ( String, # executable -- "/usr/bin/foo" or such.
# List(String), # Remaining arguments for executable.
# List(String) # Unix environment, for example [ "LOGNAME=cynbe", "SHELL=/bin/tcsh", "HOME=/pub/home/cynbe" ]
# )
# ->
# Process(X,Y,Z);
#
# we should instead have something like
#
# Spawn_Arg
# #
# = ENVIRONMENT List(String) # Specify unix environmet for child. If not specified, pe::environ() is used.
# | STDIN psx::File_Descriptor # Specify stdin for child; making it file::stdin leaves it unchanged. If not supplied, normal parent<->child pipe construction is done.
# | STDOUT psx::File_Descriptor # Specify stdout for child; making it file::stdout leaves it unchanged. If not supplied, normal parent<->child pipe construction is done.
# | COMMAND (String, List(String) # Specify executable and arguments for it. If not supplied, we do a fork() but no exec().
# ;
#
# spawn_process'
# :
# List( Spawn_Arg )
# ->
# Process(X,Y,Z);
#
stipulate
Options_Record
=
{ environment: List(String),
#
redirect_stdin_in_child: Bool,
redirect_stdout_in_child: Bool,
redirect_stderr_in_child: Bool,
#
redirect_stderr_to_stdout_in_child: Bool
};
fun options_to_option_record options
=
{ # Set up default values for options:
#
environment_ref = REF (pe::environment());
#
redirect_stdin_in_child_ref = REF TRUE;
redirect_stdout_in_child_ref = REF TRUE;
redirect_stderr_in_child_ref = REF FALSE;
#
redirect_stderr_to_stdout_in_child_ref = REF FALSE;
# Now apply any user overrides to the defaults:
#
options_to_option_record' options
where
fun options_to_option_record' []
=>
{ # Done processing user-specified options;
# construct and return final options record:
#
if (*redirect_stderr_in_child_ref
and *redirect_stderr_to_stdout_in_child_ref)
#
raise exception DIE "May not specify both (REDIRECT_STDERR_IN_CHILD TRUE) and (REDIRECT_STDERR_TO_STDOUT_IN_CHILD TRUE)";
fi;
{ environment => *environment_ref,
#
redirect_stdin_in_child => *redirect_stdin_in_child_ref,
redirect_stdout_in_child => *redirect_stdout_in_child_ref,
redirect_stderr_in_child => *redirect_stderr_in_child_ref,
#
redirect_stderr_to_stdout_in_child => *redirect_stderr_to_stdout_in_child_ref
};
};
options_to_option_record' (WITH_ENVIRONMENT environment ! rest) => { environment_ref := environment; options_to_option_record' rest; };
#
options_to_option_record' (REDIRECT_STDIN_IN_CHILD bool ! rest) => { redirect_stdin_in_child_ref := bool; options_to_option_record' rest; };
options_to_option_record' (REDIRECT_STDOUT_IN_CHILD bool ! rest) => { redirect_stdout_in_child_ref := bool; options_to_option_record' rest; };
options_to_option_record' (REDIRECT_STDERR_IN_CHILD bool ! rest) => { redirect_stderr_in_child_ref := bool; options_to_option_record' rest; };
#
options_to_option_record' (REDIRECT_STDERR_TO_STDOUT_IN_CHILD bool ! rest) => { redirect_stderr_to_stdout_in_child_ref := bool; options_to_option_record' rest; };
end;
end;
};
fun fork_process' (r: Options_Record)
=
{
fil::flush fil::stdout; # Avoid anomalies due to pending output being
fil::flush fil::stderr; # duplicated between parent and child processes.
#
my { infd => stdin_from_parent, outfd => stdin_to_child }
=
if r.redirect_stdin_in_child pio::make_pipe ();
else { infd => psx::int_to_fd 0, outfd => psx::int_to_fd 1 }; # Won't be used; just need to be type-correct.
fi;
my { infd => stdout_from_child, outfd => stdout_to_parent }
=
if r.redirect_stdout_in_child pio::make_pipe ();
else { infd => psx::int_to_fd 1, outfd => psx::int_to_fd 0 }; # Won't be used; just need to be type-correct.
fi;
my { infd => stderr_from_child, outfd => stderr_to_parent }
=
if r.redirect_stderr_in_child pio::make_pipe ();
else { infd => psx::int_to_fd 2, outfd => psx::int_to_fd 0 }; # Won't be used; just need to be type-correct.
fi;
fun close_pipes ()
=
{ close = pio::close__without_syscall_redirection; # Redirection won't work in child, and we'd like to be safe-and-simple in parent here.
#
if r.redirect_stdin_in_child
#
close stdin_from_parent;
close stdin_to_child;
fi;
if r.redirect_stdout_in_child
#
close stdout_from_child;
close stdout_to_parent;
fi;
if r.redirect_stderr_in_child
#
close stderr_from_child;
close stderr_to_parent;
fi;
};
case (protect psx::fork ())
#
THE pid =>
{
# We're the parent process:
#
close = pio::close__without_syscall_redirection; # Redirection should work in parent, but let's be straightforward.
setfd = pio::setfd__without_syscall_redirection;
# Close the child-side fds:
#
if r.redirect_stdin_in_child close stdin_from_parent; fi;
if r.redirect_stdout_in_child close stdout_to_parent; fi;
if r.redirect_stderr_in_child close stderr_to_parent; fi;
# Set the fds to close on exec:
#
if r.redirect_stdin_in_child setfd (stdin_to_child, pio::fd::flags [pio::fd::cloexec]); fi;
if r.redirect_stdout_in_child setfd (stdout_from_child, pio::fd::flags [pio::fd::cloexec]); fi;
if r.redirect_stderr_in_child setfd (stderr_from_child, pio::fd::flags [pio::fd::cloexec]); fi;
THE { pid, stdin_to_child, stdout_from_child, stderr_from_child };
};
#
NULL =>
{ # We're the child process:
#
close = pio::close__without_syscall_redirection; # Redirection won't work in child.
dup2 = pio::dup2__without_syscall_redirection;
#
old_stdin = stdin_from_parent; new_stdin = psx::int_to_fd 0; # An fd is still an int internally.
old_stdout = stdout_to_parent; new_stdout = psx::int_to_fd 1;
old_stderr = stderr_to_parent; new_stderr = psx::int_to_fd 2;
# Close the parent-side fds:
#
if r.redirect_stdin_in_child close stdin_to_child; fi;
if r.redirect_stdout_in_child close stdout_from_child; fi;
if r.redirect_stderr_in_child close stderr_from_child; fi;
if r.redirect_stdin_in_child
#
# Make our stdin fd be 0 per unix stdin/stdout/stderr convention:
#
if (old_stdin != new_stdin)
#
dup2 { old => old_stdin, # Make fd 0 ("stdin") be a copy of fd for our input pipe from parent.
new => new_stdin
};
close old_stdin; # With input pipe now safely ensconced in fd 0, close the now-unneeded original fd for that pipe.
fi;
fi;
if r.redirect_stdout_in_child
#
# Make our stdout fd be 1 per unix stdin/stdout/stderr convention:
#
if (old_stdout != new_stdout)
#
dup2 { old => old_stdout, # Make fd 1 ("stdout") be a copy of fd for our output pipe to parent.
new => new_stdout
};
close old_stdout; # With output pipe now safely ensconced in fd 1, close the now-unneeded original fd for that pipe.
fi;
fi;
if r.redirect_stderr_in_child
#
# Make our stderr fd be 2 per unix stdin/stdout/stderr convention:
#
if (old_stderr != new_stderr)
#
dup2 { old => old_stderr, # Make fd 2 ("stderr") be a copy of fd for our output pipe to parent.
new => new_stderr
};
close old_stderr; # With output pipe now safely ensconced in fd 2, close the now-unneeded original fd for that pipe.
fi;
fi;
if r.redirect_stderr_to_stdout_in_child
#
# Make our stderr fd (2) be a clone of our stdout fd (1):
#
if (new_stderr != new_stdout)
#
close new_stderr;
#
dup2 { old => new_stdout,
new => new_stderr
};
fi;
fi;
NULL;
};
esac
except
whatever_exception
=
{ close_pipes ();
#
raise exception whatever_exception;
};
};
#
fun spawn_process' (executable, arguments, r: Options_Record)
=
{ fun is_file filename
=
psx::stat::is_file (psx::stat filename)
except
_ = FALSE;
fun may_execute filename
=
{ include package psx::s;
#
stat = psx::stat filename;
all_set (flags [ ixusr ], stat.mode); # Order of args is critical!
};
#
# XXX BUGGO FIXME Checking this one bit is hardly definitive.
# What does (say) Perl do?
if (not (is_file executable)) raise exception DIE ("spawn__premicrothread: No file " + executable + " exists." ); fi;
if (not (may_execute executable)) raise exception DIE ("spawn__premicrothread: File " + executable + " is not executable."); fi;
# Get bare executable name, to be arg[0]:
#
executable_name # If 'executable' is "/bin/sh" 'executable_name' will be "sh".
=
sst::to_string
(sst::get_suffix
(\\ c = c != '/')
(sst::from_string executable)
);
case (fork_process' r)
#
THE { pid, stdin_to_child, stdout_from_child, stderr_from_child }
=>
# We're the parent process:
#
PROCESS
{
executable_name,
#
stdin_to_child => REF if r.redirect_stdin_in_child UNOPENED stdin_to_child; else NONE; fi,
stdout_from_child => REF if r.redirect_stdout_in_child UNOPENED stdout_from_child; else NONE; fi,
stderr_from_child => REF if r.redirect_stderr_in_child UNOPENED stderr_from_child; else NONE; fi,
#
status => REF (ALIVE pid)
};
NULL =>
# We're the child process:
#
psx::exece (executable, executable_name ! arguments, r.environment);
esac;
}; # fun spawn_process_in_environment (commandpath, argv, env)
herein
#
fun fork_process options
=
{ r = options_to_option_record options;
#
case (fork_process' r)
#
THE { pid, stdin_to_child, stdout_from_child, stderr_from_child }
=>
# We're the parent process:
#
THE (
PROCESS
{
executable_name => "",
#
stdin_to_child => REF if r.redirect_stdin_in_child UNOPENED stdin_to_child; else NONE; fi,
stdout_from_child => REF if r.redirect_stdout_in_child UNOPENED stdout_from_child; else NONE; fi,
stderr_from_child => REF if r.redirect_stderr_in_child UNOPENED stderr_from_child; else NONE; fi,
#
status => REF (ALIVE pid)
}
);
NULL => NULL; # We're the child process.
esac; # fun fork_process
};
fun spawn_process { executable, arguments, options }
=
spawn_process' (executable, arguments, options_to_option_record options);
end;
fun kill (PROCESS { status => REF (ALIVE pid), ... }, signal)
=>
psx::kill (psx::K_PROC pid, signal);
kill _ => (); # raise an exception here?
end;
###################################################################
# "If any question why we died,
# Tell them, because our fathers lied."
#
# -- Rudyard Kipling
###################################################################
fun reap (PROCESS { status => REF (DEAD { status, ... }), ... })
=>
status;
reap (PROCESS { status => status_ref as REF (ALIVE process_id), stdin_to_child, stdout_from_child, stderr_from_child, ... } )
=>
{
# 'protect' is probably too much; typically,
# one would only mask SIGINT, SIGQUIT and SIGHUP XXX BUGGO FIXME
#
fun wait_proc ()
=
case (#2 (protect psx::waitpid (psx::W_CHILD process_id, [])))
#
W_EXITED => 0;
W_EXITSTATUS status => u1b::to_int status;
W_SIGNALED status => 256 + (sig::signal_to_int status);
W_STOPPED status => 512 + (sig::signal_to_int status); # This should not happen.
esac;
fun close (UNOPENED fd ) => pio::close fd;
close (OPENED stream) => stream.close ();
close (NONE ) => ();
end;
close *stdout_from_child;
close *stderr_from_child;
close *stdin_to_child
except
_ = ();
status = wait_proc ();
status_ref := DEAD { status, process_id };
status;
};
end;
fun process_id_of (PROCESS { status => REF (ALIVE process_id), ... })
=>
(host_unt_guts::to_int (psx::pid_to_unt process_id));
process_id_of (PROCESS { status => REF (DEAD { process_id, ... }), ... })
=>
(host_unt_guts::to_int (psx::pid_to_unt process_id));
end;
fun bin_sh cmdline
=
{ child_process
=
spawn_process { executable => "/bin/sh", arguments => ["-c", cmdline], options => [] };
(text_streams_of child_process)
->
{ stdin_to_child, stdout_from_child };
fil::close_output stdin_to_child;
output = fil::read_all stdout_from_child;
reap child_process;
output;
};
exit = psx::exit;
}; # package spawn__premicrothread
# SML/NJ calls this "unix" -- a singularly unhelpful appellation.
end;