16. Process Management and Communication

(* Process support is mostly in the "unix" library. *)
#load "unix.cma";;

(* Run a command and return its results as a string. *)
let read_process command =
  let buffer_size = 2048 in
  let buffer = Buffer.create buffer_size in
  let string = String.create buffer_size in
  let in_channel = Unix.open_process_in command in
  let chars_read = ref 1 in
  while !chars_read <> 0 do
    chars_read := input in_channel string 0 buffer_size;
    Buffer.add_substring buffer string 0 !chars_read
  done;
  ignore (Unix.close_process_in in_channel);
  Buffer.contents buffer

(* Run a command and return its results as a list of strings,
   one per line. *)
let read_process_lines command =
  let lines = ref [] in
  let in_channel = Unix.open_process_in command in
  begin
    try
      while true do
        lines := input_line in_channel :: !lines
      done;
    with End_of_file ->
      ignore (Unix.close_process_in in_channel)
  end;
  List.rev !lines

(* Example: *)
let output_string = read_process "program args"
let output_lines = read_process_lines "program args"

(*-----------------------------*)

(* Create a pipe for the subprocess output. *)
let readme, writeme = Unix.pipe ()

(* Launch the program, redirecting its stdout to the pipe.
   By calling Unix.create_process, we can avoid running the
   command through the shell. *)
let () =
  let pid = Unix.create_process
    program [| program; arg1; arg2 |]
    Unix.stdin writeme Unix.stderr in
  Unix.close writeme;
  let in_channel = Unix.in_channel_of_descr readme in
  let lines = ref [] in
  begin
    try
      while true do
        lines := input_line in_channel :: !lines
      done
    with End_of_file -> ()
  end;
  Unix.close readme;
  List.iter print_endline (List.rev !lines)

(* Run a simple command and retrieve its result code. *)
let status = Sys.command ("vi " ^ myfile)

(*-----------------------------*)

(* Use the shell to perform redirection. *)
let _ = Sys.command "cmd1 args | cmd2 | cmd3 >outfile"
let _ = Sys.command "cmd args <infile >outfile 2>errfile"

(*-----------------------------*)

(* Run a command, handling its result code or signal. *)
#load "unix.cma";;
let () =
  match Unix.system command with
    | Unix.WEXITED status ->
        Printf.printf "program exited with status %d\n" status
    | Unix.WSIGNALED signal ->
        Printf.printf "program killed by signal %d\n" signal
    | Unix.WSTOPPED signal ->
        Printf.printf "program stopped by signal %d\n" signal

(*-----------------------------*)

(* Run a command while blocking interrupt signals. *)
#load "unix.cma";;
let () =
  match Unix.fork () with
    | 0 ->
        (* child ignores INT and does its thing *)
        Sys.set_signal Sys.sigint Sys.Signal_ignore;
        Unix.execv "/bin/sleep" [| "/bin/sleep"; "10" |]
    | pid ->
        (* parent catches INT and berates user *)
        Sys.set_signal Sys.sigint
          (Sys.Signal_handle
            (fun _ -> print_endline "Tsk tsk, no process interruptus"));
        let running = ref true in
        while !running do
          try (ignore (Unix.waitpid [] pid); running := false)
          with Unix.Unix_error _ -> ()
        done;
        Sys.set_signal Sys.sigint Sys.Signal_default

(*-----------------------------*)

(* Run a command with a different name in the process table. *)
#load "unix.cma";;
let shell = "/bin/tcsh"
let () =
  match Unix.fork () with
    | 0 -> Unix.execv shell [| "-csh" |] (* pretend it's a login shell *)
    | pid -> ignore (Unix.waitpid [] pid)

#load "unix.cma";;
(* Transfer control to the shell to run another program. *)
let () = Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; "archive *.data" |]
(* Transfer control directly to another program in the path. *)
let () = Unix.execvp "archive" [| "archive"; "accounting.data" |]

#load "unix.cma";;

(*-----------------------------*)

(* Handle each line in the output of a process. *)
let () =
  let readme = Unix.open_process_in "program arguments" in
  let rec loop line =
    (* ... *)
    loop (input_line readme) in
  try loop (input_line readme)
  with End_of_file -> ignore (Unix.close_process_in readme)

(*-----------------------------*)

(* Write to the input of a process. *)
let () =
  let writeme = Unix.open_process_out "program arguments" in
  output_string writeme "data\n";
  ignore (Unix.close_process_out writeme)

(*-----------------------------*)

(* Wait for a process to complete. *)
let () =
  (* child goes to sleep *)
  let f = Unix.open_process_in "sleep 100000" in
  (* and parent goes to lala land *)
  ignore (Unix.close_process_in f);
  ignore (Unix.wait ())

(*-----------------------------*)

let () =
  let writeme = Unix.open_process_out "program args" in
  (* program will get hello\n on STDIN *)
  output_string writeme "hello\n";
  (* program will get EOF on STDIN *)
  ignore (Unix.close_process_out writeme)

(*-----------------------------*)

(* Redirect standard output to the pager. *)
let () =
  let pager =
    try Sys.getenv "PAGER" (* XXX: might not exist *)
    with Not_found -> "/usr/bin/less" in
  let reader, writer = Unix.pipe () in
  match Unix.fork () with
    | 0 ->
        Unix.close writer;
        Unix.dup2 reader Unix.stdin;
        Unix.close reader;
        Unix.execvp pager [| pager |]
    | pid ->
        Unix.close reader;
        Unix.dup2 writer Unix.stdout;
        Unix.close writer

(* Do something useful that writes to standard output, then
   close the stream and wait for the pager to finish. *)
let () =
  (* ... *)
  close_out stdout;
  ignore (Unix.wait ())

#load "unix.cma";;

(* Fork a process that calls f to post-process standard output. *)
let push_output_filter f =
  let reader, writer = Unix.pipe () in
  match Unix.fork () with
    | 0 ->
        Unix.close writer;
        Unix.dup2 reader Unix.stdin;
        Unix.close reader;
        f ();
        exit 0
    | pid ->
        Unix.close reader;
        Unix.dup2 writer Unix.stdout;
        Unix.close writer

(* Only display a certain number of lines of output. *)
let head ?(lines=20) () =
  push_output_filter
    (fun () ->
       let lines = ref lines in
       try
         while !lines > 0 do
           print_endline (read_line ());
           decr lines
         done
       with End_of_file -> ())

(* Prepend line numbers to each line of output. *)
let number () =
  push_output_filter
    (fun () ->
       let line_number = ref 0 in
       try
         while true do
           let line = read_line () in
           incr line_number;
           Printf.printf "%d: %s\n" !line_number line
         done
       with End_of_file -> ())

(* Prepend "> " to each line of output. *)
let quote () =
  push_output_filter
    (fun () ->
       try
         while true do
           let line = read_line () in
           Printf.printf "> %s\n" line
         done
       with End_of_file -> ())

let () =
  head ~lines:100 ();  (* push head filter on STDOUT *)
  number ();           (* push number filter on STDOUT *)
  quote ();            (* push quote filter on STDOUT *)

  (* act like /bin/cat *)
  begin
    try
      while true do
        print_endline (read_line ())
      done
    with End_of_file -> ()
  end;

  (* tell kids we're done--politely *)
  close_out stdout;
  ignore (Unix.waitpid [] (-1));
  exit 0

#load "unix.cma";;
#load "str.cma";;

(* Tagged filename or URL type. *)
type filename =
  | Uncompressed of string
  | Compressed of string
  | URL of string

(* try/finally-like construct to ensure we dispose of resources properly. *)
let finally handler f x =
  let result = try f x with e -> handler (); raise e in handler (); result

(* Call f with an in_channel given a tagged filename. If the filename is
   tagged Uncompressed, open it normally. If it is tagged Compressed then
   pipe it through gzip. If it is tagged URL, pipe it through "lynx -dump".
   Ensure that the channel is closed and any created processes have
   terminated before returning. As a special case, a filename of
   Uncompressed "-" will result in stdin being passed, and no channel
   will be closed. *)
let with_in_channel filename f =
  let pipe_input args f =
    let reader, writer = Unix.pipe () in
    let pid =
      Unix.create_process args.(0) args Unix.stdin writer Unix.stderr in
    Unix.close writer;
    let in_channel = Unix.in_channel_of_descr reader in
    finally
      (fun () -> close_in in_channel; ignore (Unix.waitpid [] pid))
      f in_channel in
  match filename with
    | Uncompressed "-" ->
        f stdin
    | Uncompressed filename ->
        let in_channel = open_in filename in
        finally
          (fun () -> close_in in_channel)
          f in_channel
    | Compressed filename ->
        pipe_input [| "gzip"; "-dc"; filename |] f
    | URL url ->
        pipe_input [| "lynx"; "-dump"; url |] f

(* Return true if the string s starts with the given prefix. *)
let starts_with s prefix =
  try Str.first_chars s (String.length prefix) = prefix
  with Invalid_argument _ -> false

(* Return true if the string s ends with the given suffix. *)
let ends_with s suffix =
  try Str.last_chars s (String.length suffix) = suffix
  with Invalid_argument _ -> false

(* Return true if the string s contains the given substring. *)
let contains s substring =
  try ignore (Str.search_forward (Str.regexp_string substring) s 0); true
  with Not_found -> false

(* Tag the filename depending on its contents or extension. *)
let tag_filename filename =
  if contains filename "://"
  then URL filename
  else if List.exists (ends_with filename) [".gz"; ".Z"]
  then Compressed filename
  else Uncompressed filename

(* Process a tagged filename. *)
let process filename =
  with_in_channel
    filename
    (fun in_channel ->
       try
         while true do
           let line = input_line in_channel in
           (* ... *)
           ()
         done
       with End_of_file -> ())

(* Parse the command-line arguments and process each file or URL. *)
let () =
  let args =
    if Array.length Sys.argv > 1
    then (List.tl (Array.to_list Sys.argv))
    else ["-"] in
  List.iter process (List.map tag_filename args)

(* pipe1 - use pipe and fork so parent can send to child *)
#load "unix.cma"
open Unix

let reader, writer = pipe ()

let () =
  match fork () with
    | 0 ->
        close writer;
        let input = in_channel_of_descr reader in
        let line = input_line input in
        Printf.printf "Child Pid %d just read this: `%s'\n" (getpid ()) line;
        close reader;  (* this will happen anyway *)
        exit 0
    | pid ->
        close reader;
        let output = out_channel_of_descr writer in
        Printf.fprintf output "Parent Pid %d is sending this\n" (getpid ());
        flush output;
        close writer;
        ignore (waitpid [] pid)

(*-----------------------------*)

(* pipe2 - use pipe and fork so child can send to parent *)
#load "unix.cma"
open Unix

let reader, writer = pipe ()

let () =
  match fork () with
    | 0 ->
        close reader;
        let output = out_channel_of_descr writer in
        Printf.fprintf output "Child Pid %d is sending this\n" (getpid ());
        flush output;
        close writer;  (* this will happen anyway *)
        exit 0
    | pid ->
        close writer;
        let input = in_channel_of_descr reader in
        let line = input_line input in
        Printf.printf "Parent Pid %d just read this: `%s'\n" (getpid ()) line;
        close reader;
        ignore (waitpid [] pid)

(*-----------------------------*)

(* pipe3 and pipe4 demonstrate the use of perl's "forking open" feature to
 * reimplement pipe1 and pipe2. Since OCaml does not support such a feature,
 * these are skipped here. *)

(*-----------------------------*)

(* pipe5 - bidirectional communication using two pipe pairs
           designed for the socketpair-challenged *)
#load "unix.cma"
open Unix

let parent_rdr, child_wtr = pipe ()
let child_rdr, parent_wtr = pipe ()

let () =
  match fork () with
    | 0 ->
        close child_rdr;
        close child_wtr;
        let input = in_channel_of_descr parent_rdr in
        let output = out_channel_of_descr parent_wtr in
        let line = input_line input in
        Printf.printf "Child Pid %d just read this: `%s'\n" (getpid ()) line;
        Printf.fprintf output "Child Pid %d is sending this\n" (getpid ());
        flush output;
        close parent_rdr;
        close parent_wtr;
        exit 0
    | pid ->
        close parent_rdr;
        close parent_wtr;
        let input = in_channel_of_descr child_rdr in
        let output = out_channel_of_descr child_wtr in
        Printf.fprintf output "Parent Pid %d is sending this\n" (getpid());
        flush output;
        let line = input_line input in
        Printf.printf "Parent Pid %d just read this: `%s'\n" (getpid ()) line;
        close child_rdr;
        close child_wtr;
        ignore (waitpid [] pid)

(*-----------------------------*)

(* pipe6 - bidirectional communication using socketpair
           "the best ones always go both ways" *)
#load "unix.cma"
open Unix

let child, parent = socketpair PF_UNIX SOCK_STREAM 0

let () =
  match fork () with
    | 0 ->
        close child;
        let input = in_channel_of_descr parent in
        let output = out_channel_of_descr parent in
        let line = input_line input in
        Printf.printf "Child Pid %d just read this: `%s'\n" (getpid ()) line;
        Printf.fprintf output "Child Pid %d is sending this\n" (getpid ());
        flush output;
        close parent;
        exit 0
    | pid ->
        close parent;
        let input = in_channel_of_descr child in
        let output = out_channel_of_descr child in
        Printf.fprintf output "Parent Pid %d is sending this\n" (getpid ());
        flush output;
        let line = input_line input in
        Printf.printf "Parent Pid %d just read this: `%s'\n" (getpid ()) line;
        close child;
        ignore (waitpid [] pid)

(*-----------------------------*)

(* Simulating a pipe using a socketpair. *)
let reader, writer = socketpair PF_UNIX SOCK_STREAM 0 in
shutdown reader SHUTDOWN_SEND;      (* no more writing for reader *)
shutdown writer SHUTDOWN_RECEIVE;   (* no more reading for writer *)

(* OCaml does not currently support SysV IPC. *)

% echo 'module M = Sys;;' | ocaml | grep 'val sig'
    val sigabrt : int
    val sigalrm : int
    val sigfpe : int
    val sighup : int
    val sigill : int
    val sigint : int
    val sigkill : int
    val sigpipe : int
    val sigquit : int
    val sigsegv : int
    val sigterm : int
    val sigusr1 : int
    val sigusr2 : int
    val sigchld : int
    val sigcont : int
    val sigstop : int
    val sigtstp : int
    val sigttin : int
    val sigttou : int
    val sigvtalrm : int
    val sigprof : int

% grep -A1 'val sig' sys.mli
val sigabrt : int
(** Abnormal termination *)
--
val sigalrm : int
(** Timeout *)
--
val sigfpe : int
(** Arithmetic exception *)
--
val sighup : int
(** Hangup on controlling terminal *)
--
val sigill : int
(** Invalid hardware instruction *)
--
val sigint : int
(** Interactive interrupt (ctrl-C) *)
--
val sigkill : int
(** Termination (cannot be ignored) *)
--
val sigpipe : int
(** Broken pipe *)
--
val sigquit : int
(** Interactive termination *)
--
val sigsegv : int
(** Invalid memory reference *)
--
val sigterm : int
(** Termination *)
--
val sigusr1 : int
(** Application-defined signal 1 *)
--
val sigusr2 : int
(** Application-defined signal 2 *)
--
val sigchld : int
(** Child process terminated *)
--
val sigcont : int
(** Continue *)
--
val sigstop : int
(** Stop *)
--
val sigtstp : int
(** Interactive stop *)
--
val sigttin : int
(** Terminal read from background process *)
--
val sigttou : int
(** Terminal write from background process *)
--
val sigvtalrm : int
(** Timeout in virtual time *)
--
val sigprof : int
(** Profiling interrupt *)

#load "unix.cma";;
let () =
  (* send pid a signal 9 *)
  Unix.kill pid 9;
  (* send whole job a signal 1 *)
  Unix.kill pgrp (-1);
  (* send myself a SIGUSR1 *)
  Unix.kill (Unix.getpid ()) Sys.sigusr1;
  (* send a SIGHUP to processes in pids *)
  List.iter (fun pid -> Unix.kill pid Sys.sighup) pids

(*-----------------------------*)

(* Use kill with pseudo-signal 0 to see if process is alive. *)
let () =
  try
    Unix.kill minion 0;
    Printf.printf "%d is alive!\n" minion
  with
    | Unix.Unix_error (Unix.EPERM, _, _) -> (* changed uid *)
        Printf.printf "%d has escaped my control!\n" minion
    | Unix.Unix_error (Unix.ESRCH, _, _) ->
        Printf.printf "%d is deceased.\n" (* or zombied *) minion
    | e ->
        Printf.printf "Odd; I couldn't check on the status of %d: %s\n"
          minion
          (Printexc.to_string e)

let () =
  (* call got_sig_quit for every SIGQUIT *)
  Sys.set_signal Sys.sigquit (Sys.Signal_handle got_sig_quit);
  (* call got_sig_pipe for every SIGPIPE *)
  Sys.set_signal Sys.sigpipe (Sys.Signal_handle got_sig_pipe);
  (* increment ouch for every SIGINT *)
  Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> incr ouch));
  (* ignore the signal INT *)
  Sys.set_signal Sys.sigint Sys.Signal_ignore;
  (* restore default STOP signal handling *)
  Sys.set_signal Sys.sigstop Sys.Signal_default

let finally handler f x =
  let result = try f x with e -> handler (); raise e in handler (); result

(* call f with signal behavior temporarily set *)
let local_set_signal signal behavior f =
  let old_behavior = Sys.signal signal behavior in
  finally (fun () -> Sys.set_signal signal old_behavior) f ()

(* the signal handler *)
let rec ding _ =
  Sys.set_signal Sys.sigint (Sys.Signal_handle ding);
  prerr_endline "\x07Enter your name!"

(* prompt for name, overriding SIGINT *)
let get_name () =
  local_set_signal
    Sys.sigint (Sys.Signal_handle ding)
    (fun () ->
       print_string "Kindly Stranger, please enter your name: ";
       read_line ())

let rec got_int _ =
  Sys.set_signal Sys.sigint (Sys.Signal_handle got_int);
  (* but not for SIGCHLD! *)
  (* ... *)
  ()

(*-----------------------------*)

let rec got_int _ =
  Sys.set_signal Sys.sigint Sys.Signal_default; (* or Signal_ignore *)
  failwith "interrupted"

let () =
  Sys.set_signal Sys.sigint (Sys.Signal_handle got_int);
  try
    (* ... long-running code that you don't want to restart *)
    ()
  with Failure "interrupted" ->
    (* deal with the signal *)
    ()

let () =
  (* ignore signal INT *)
  Sys.set_signal Sys.sigint Sys.Signal_ignore;

  (* install signal handler *)
  let rec tsktsk signal =
    Sys.set_signal Sys.sigint (Sys.Signal_handle tsktsk);
    print_endline "\x07The long habit of living indisposeth us for dying." in
  Sys.set_signal Sys.sigint (Sys.Signal_handle tsktsk)

#load "unix.cma";;

let () =
  Sys.set_signal Sys.sigchld Sys.Signal_ignore

(*-----------------------------*)

let rec reaper signal =
  try while true do ignore (Unix.waitpid [Unix.WNOHANG] (-1)) done
  with Unix.Unix_error (Unix.ECHILD, _, _) -> ();
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)

let () =
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)

(*-----------------------------*)

let rec reaper signal =
  begin try
    let pid, status = Unix.waitpid [Unix.WNOHANG] (-1) in begin
      match status with
        | Unix.WEXITED _ ->
            Printf.printf "Process %d exited.\n" pid
        | _ ->
            Printf.printf "False alarm on %d.\n" pid;
    end;
    reaper signal
  with Unix.Unix_error (Unix.ECHILD, _, _) ->
    () (* No child waiting. Ignore it. *)
  end;
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)

let () =
  Sys.set_signal Sys.sigchld (Sys.Signal_handle reaper)

#load "unix.cma";;

(* define the signals to block *)
let sigset = [Sys.sigint; Sys.sigkill]

let () =
  (* block signals *)
  let old_sigset = Unix.sigprocmask Unix.SIG_BLOCK sigset in

  (* ... *)

  (* unblock signals *)
  (* the original recipe uses SIG_UNBLOCK, but that doesn't seem right... *)
  ignore (Unix.sigprocmask Unix.SIG_SETMASK old_sigset)

#load "unix.cma";;
let () =
  Sys.set_signal Sys.sigalrm
    (Sys.Signal_handle (fun _ -> failwith "timeout"));

  ignore (Unix.alarm 3600);
  try
    (* long-time operations here *)
    ignore (Unix.alarm 0)
  with
    | Failure "timeout" ->
        (* timed out; do what you will here *)
        ()
    | e ->
        (* clear the still-pending alarm *)
        ignore (Unix.alarm 0);
        (* propagate unexpected exception *)
        raise e