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)

#load "unix.cma";;

(* Read STDERR and STDOUT at the same time. *)
let () =
  let ph = Unix.open_process_in "cmd 2>&1" in
  while true do
    let line = input_line ph in
    (* ... *)
    ()
  done

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

(* Read STDOUT and discard STDERR. *)
let output = read_process "cmd 2>/dev/null"
(* or *)
let () =
  let ph = Unix.open_process_in "cmd 2>/dev/null" in
  while true do
    let line = input_line ph in
    (* ... *)
    ()
  done

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

(* Read STDERR and discard STDOUT. *)
let output = read_process "cmd 2>&1 1>/dev/null"
(* or *)
let () =
  let ph = Unix.open_process_in "cmd 2>&1 1>/dev/null" in
  while true do
    let line = input_line ph in
    (* ... *)
    ()
  done

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

(* Swap STDOUT with STDERR and read original STDERR. *)
let output = read_process "cmd 3>&1 1>&2 2>&3 3>&-"
(* or *)
let () =
  let ph = Unix.open_process_in "cmd 3>&1 1>&2 2>&3 3>&-" in
  while true do
    let line = input_line ph in
    (* ... *)
    ()
  done

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

(* Redirect STDOUT and STDERR to temporary files. *)
let () =
  ignore
    (Sys.command
       "program args 1>/tmp/program.stdout 2>/tmp/program.stderr")

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

(* If the following redirections were done in OCaml... *)
let output = read_process "cmd 3>&1 1>&2 2>&3 3>&-"

(* ...they would look something like this: *)
let fd3 = fd1
let fd1 = fd2
let fd2 = fd3
let fd3 = undef

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

(* Send STDOUT and STDERR to a temporary file. *)
let () = ignore (Sys.command "prog args 1>tmpfile 2>&1")

(* Send STDOUT to a temporary file and redirect STDERR to STDOUT. *)
let () = ignore (Sys.command "prog args 2>&1 1>tmpfile")

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

(* If the following redirections were done in OCaml... *)
let () = ignore (Sys.command "prog args 1>tmpfile 2>&1")

(* ...they would look something like this: *)
let fd1 = "tmpfile"       (* change stdout destination first *)
let fd2 = fd1             (* now point stderr there, too *)

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

(* If the following redirections were done in OCaml... *)
let () = ignore (Sys.command "prog args 2>&1 1>tmpfile")

(* ...they would look something like this: *)
let fd2 = fd1             (* stderr same destination as stdout *)
let fd1 = "tmpfile"       (* but change stdout destination  *)

#load "unix.cma";;

let () =
  let (readme, writeme) = Unix.open_process program in
  output_string writeme "here's your input\n";
  close_out writeme;
  let output = input_line readme in
  ignore (Unix.close_process (readme, writeme))

#load "unix.cma";;
let () =
  let proc =
    Unix.open_process_in
      ("(" ^ cmd ^ " | sed -e 's/^/stdout: /' ) 2>&1") in
  try
    while true do
      let line = input_line proc in
      if String.length line >= 8
        && String.sub line 0 8 = "stdout: "
      then Printf.printf "STDOUT: %s\n"
        (String.sub line 8 (String.length line - 8))
      else Printf.printf "STDERR: %s\n" line
    done
  with End_of_file ->
    ignore (Unix.close_process_in proc)

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

#!/usr/bin/ocaml
(* cmd3sel - control all three of kids in, out, and error. *)
#load "unix.cma";;

let cmd = "grep vt33 /none/such - /etc/termcap"
let cmd_out, cmd_in, cmd_err = Unix.open_process_full cmd [| |]

let () =
  output_string cmd_in "This line has a vt33 lurking in it\n";
  close_out cmd_in;
  let cmd_out_descr = Unix.descr_of_in_channel cmd_out in
  let cmd_err_descr = Unix.descr_of_in_channel cmd_err in
  let selector = ref [cmd_err_descr; cmd_out_descr] in
  while !selector <> [] do
    let can_read, _, _ = Unix.select !selector [] [] 1.0 in
    List.iter
      (fun fh ->
         try
           if fh = cmd_err_descr
           then Printf.printf "STDERR: %s\n" (input_line cmd_err)
           else Printf.printf "STDOUT: %s\n" (input_line cmd_out)
         with End_of_file ->
           selector := List.filter (fun fh' -> fh <> fh') !selector)
      can_read
  done;
  ignore (Unix.close_process_full (cmd_out, cmd_in, cmd_err))

(* 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 *)

% mkfifo /path/to/named.pipe

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

let () =
  let fifo = open_in "/path/to/named.pipe" in
  try
    while true do
      let line = input_line fifo in
      Printf.printf "Got: %s\n" line
    done
  with End_of_file ->
    close_in fifo

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

let () =
  let fifo = open_out "/path/to/named.pipe" in
  output_string fifo "Smoke this.\n";
  close_out fifo

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

% mkfifo ~/.plan                    # isn't this everywhere yet?
% mknod  ~/.plan p                  # in case you don't have mkfifo

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

(* dateplan - place current date and time in .plan file *)
#load "unix.cma";;
let () =
  while true do
    let home = Unix.getenv "HOME" in
    let fifo = open_out (home ^ "/.plan") in
    Printf.fprintf fifo "The current time is %s\n"
      (format_time (Unix.time ()));
    close_out fifo;
    Unix.sleep 1
  done

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

#!/usr/bin/ocaml
(* fifolog - read and record log msgs from fifo *)
#load "unix.cma";;

let fifo = ref None

let handle_alarm signal =
  match !fifo with
    | Some channel ->
        (* move on to the next queued process *)
        close_in channel;
        fifo := None
    | None -> ()

let () =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle handle_alarm)

let read_fifo () =
  try
    match !fifo with
      | Some channel -> Some (input_line channel)
      | None -> None
  with
    | End_of_file ->
        None
    | Sys_error e ->
        Printf.eprintf "Error reading fifo: %s\n%!" e;
        fifo := None;
        None

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let format_time time =
  let tm = Unix.localtime time in
  Printf.sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.Unix.tm_wday)
    months.(tm.Unix.tm_mon)
    tm.Unix.tm_mday
    tm.Unix.tm_hour
    tm.Unix.tm_min
    tm.Unix.tm_sec
    (tm.Unix.tm_year + 1900)

let () =
  while true do
    (* turn off alarm for blocking open *)
    ignore (Unix.alarm 0);
    begin
      try fifo := Some (open_in "/tmp/log")
      with Sys_error e ->
        Printf.eprintf "Can't open /tmp/log: %s\n%!" e;
        exit 1
    end;

    (* you have 1 second to log *)
    ignore (Unix.alarm 1);

    let service = read_fifo () in
    let message = read_fifo () in

    (* turn off alarms for message processing *)
    ignore (Unix.alarm 0);

    begin
      match service, message with
        | None, _ | _, None ->
            (* interrupted or nothing logged *)
            ()
        | Some service, Some message ->
            if service = "http"
            then () (* ignoring *)
            else if service = "login"
            then
              begin
                (* log to /tmp/login *)
                try
                  let log =
                    open_out_gen
                      [Open_wronly; Open_creat; Open_append]
                      0o666
                      "/tmp/login" in
                  Printf.fprintf log "%s %s %s\n%!"
                    (format_time (Unix.time ())) service message;
                  close_out log
                with Sys_error e ->
                  Printf.eprintf "Couldn't log %s %s to /tmp/login: %s\n%!"
                    service message e
              end
    end
  done

(* 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

#!/usr/bin/ocaml
(* sigrand - supply random fortunes for .signature file *)
#load "str.cma";;
#load "unix.cma";;

(* globals *)

let pwd = Unix.getpwuid (Unix.getuid ())

let home =
  try Unix.getenv "HOME" with Not_found ->
    try Unix.getenv "LOGDIR" with Not_found ->
      pwd.Unix.pw_dir

let fortune_path = ref ""

(**************************************************************)
(* begin configuration section *)

(* for rec/humor/funny instead of rec.humor.funny *)
let ng_is_dir      = true

let fullname       = home ^ "/.fullname"
let fifo           = home ^ "/.signature"
let art            = home ^ "/.article"
let news           = home ^ "/News"
let sigs           = news ^ "/SIGNATURES"
let sema           = home ^ "/.sigrandpid"
let globrand       = 0.25  (* chance to use global sigs anyway *)

(* name should be (1) left None to have program guess
   read address for signature maybe looking in ~/.fullname,
   (2) set to an exact address, or (3) set to empty string
   to be omitted entirely. *)

(* let name        = ref None *)
(* let name        = ref (Some ("me@home.org")) *)
let name           = ref (Some "")

(* end configuration section *)
(**************************************************************)

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

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let delimited_stream_of_channel delim channel =
  let lines = line_stream_of_channel channel in
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some delim', [] when delim' = delim ->
          Stream.junk lines; next para_lines i
      | Some delim', _ when delim' = delim ->
          Some (String.concat "\n" (List.rev para_lines))
      | None, _ ->
          Some (String.concat "\n" (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

(* Make sure there's a fortune program.  Search
   for its full path and set global to that. *)
let check_fortunes () =
  if !fortune_path <> ""
  then ()  (* already set *)
  else
    let path = Str.split (Str.regexp ":") (Unix.getenv "PATH") in
    let rec check = function
      | [] ->
          Printf.eprintf
            "Need either %s or a fortune program, bailing out\n"
            sigs;
          exit 1
      | dir :: dirs ->
          let p = Filename.concat dir "fortune" in
          if Sys.file_exists p then p else check dirs in
    fortune_path := check (path @ ["/usr/games"])

(* Call the fortune program with -s for short flag until
   we get a small enough fortune or ask too much. *)
let fortune () =
  let cmd = !fortune_path ^ " -s" in
  let rec loop tries =
    let lines = read_process_lines cmd in
    if List.length lines < 5 then lines
    else if tries < 20 then loop (tries + 1)
    else [] in
  match loop 0 with
    | [] ->
        [" SIGRAND: deliver random signals to all processes."]
    | lines ->
        List.map (( ^ ) " ") lines

(* See whether ~/.article contains a Newsgroups line. if so, see the
   first group posted to and find out whether it has a dedicated set of
   fortunes. otherwise return the global one. Also, return the global
   one randomly now and then to spice up the sigs. *)
let signame () =
  if Random.float 1.0 > globrand
  then
    begin
      try
        let channel = open_in art in
        let regexp = Str.regexp "Newsgroups:[ \t]*\\([^, \r\n\t]*\\)" in
        let ng = ref "" in
        begin
          try
            while true do
              let line = input_line channel in
              if Str.string_match regexp line 0
              then ng := Str.matched_group 1 line
            done
          with End_of_file ->
            close_in channel
        end;
        if ng_is_dir
        then ng := Str.global_replace (Str.regexp "\\.") "/" !ng;
        ng := news ^ "/" ^ !ng ^ "/" ^ "SIGNATURES";
        if Sys.file_exists !ng then !ng else sigs
      with Sys_error e ->
        sigs
    end
  else sigs

(* choose a random signature *)
let pick_quote () =
  let sigfile = signame () in
  if not (Sys.file_exists sigfile)
  then fortune ()
  else
    begin
      let channel = open_in sigfile in
      let stream = delimited_stream_of_channel "%%" channel in
      let quip = ref [] in
      let num = ref 1 in
      Stream.iter
        (fun chunk ->
           if Random.int !num = 0
           then quip := Str.split (Str.regexp "\n") chunk;
           incr num)
        stream;
      close_in channel;
      if !quip <> []
      then List.map (( ^ ) " ") !quip
      else [" ENOSIG: This signature file is empty."]
    end

(* Ignore SIGPIPE in case someone opens us up and then closes the fifo
   without reading it; look in a .fullname file for their login name.
   Try to determine the fully qualified hostname. Make sure we have
   signatures or fortunes. Build a fifo if we need to. *)

let setup () =
  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;

  if !name = Some "" then
    begin
      try
        let channel = open_in fullname in
        name := Some (input_line channel);
        close_in channel
      with Sys_error _ ->
        name := Some (Str.global_replace (Str.regexp ",.*") ""
                        pwd.Unix.pw_gecos)
    end;

  if not (Sys.file_exists sigs) then check_fortunes ();

  if Sys.file_exists fifo
  then (if (Unix.stat fifo).Unix.st_kind = Unix.S_FIFO
        then (Printf.eprintf "%s: using existing named pipe %s\n"
                Sys.argv.(0) fifo)
        else (Printf.eprintf "%s: won't overwrite file %s\n"
                Sys.argv.(0) fifo;
              exit 1))
  else (Unix.mkfifo fifo 0o666;
        Printf.eprintf "%s: created %s as a named pipe\n"
          Sys.argv.(0) fifo);

  Random.self_init ()

(* "There can be only one."  --the Highlander *)
let justme () =
  let channel =
    try Some (open_in sema)
    with Sys_error _ -> None in
  match channel with
    | Some channel ->
        begin
          let pid = int_of_string (input_line channel) in
          try
            Unix.kill pid 0;
            Printf.eprintf "%s already running (pid %d), bailing out\n"
              Sys.argv.(0) pid;
            exit 1
          with _ ->
            close_in channel
        end
    | None -> ()

let () =
  setup ();                (* pull in inits *)
  justme ();               (* make sure program not already running *)
  match Unix.fork () with  (* background ourself and go away *)
    | 0 ->
        let channel = open_out sema in
        output_string channel (string_of_int (Unix.getpid ()));
        output_string channel "\n";
        close_out channel;

        (* now loop forever, writing a signature into the
           fifo file.  if you don't have real fifos, change
           sleep time at bottom of loop to like 10 to update
           only every 10 seconds. *)

        while true do
          let channel = open_out fifo in
          let sig' = pick_quote () in
          let sig' = Array.of_list sig' in

          (* trunc to 4 lines *)
          let sig' =
            if Array.length sig' > 4
            then Array.sub sig' 0 4
            else sig' in

          (* trunc long lines *)
          let sig' =
            Array.map
              (fun line ->
                 if String.length line > 80
                 then String.sub line 0 80
                 else line)
              sig' in

          (* print sig, with name if present, padded to four lines *)
          begin
            match !name with
              | None | Some "" ->
                  Array.iter
                    (fun line ->
                       output_string channel line;
                       output_string channel "\n")
                    sig'
              | Some name ->
                  output_string channel name;
                  for i = 4 downto Array.length sig' do
                    output_string channel "\n";
                  done;
                  Array.iter
                    (fun line ->
                       output_string channel line;
                       output_string channel "\n")
                    sig'
          end;
          close_out channel;

          (* Without a microsleep, the reading process doesn't finish
             before the writer tries to open it again, which since the
             reader exists, succeeds. They end up with multiple
             signatures. Sleep a tiny bit between opens to give readers
             a chance to finish reading and close our pipe so we can
             block when opening it the next time. *)

          ignore (Unix.select [] [] [] 0.2)  (* sleep 1/5 second *)
        done
    | _ ->
        exit 0