PreviousUpNext

15.4.1159  src/lib/std/src/posix/spawn–premicrothread.pkg

## 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.pkg
herein

    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;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext