system.ml 1.92 KB
Newer Older
1 2
open Operators
open Builtin_defs
3
open Ident
4

5 6 7 8 9 10 11 12 13
let variant_type_ascii l =
  List.fold_left
    (fun accu (l,t) ->
       Types.cup accu
	 (Types.times 
	    (Types.cons (Types.atom (Atoms.atom (Atoms.V.mk_ascii l))))
	    (Types.cons t)))
    Types.empty
    l
14

15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
let record_type_ascii l =
  Types.record' (false,
    (LabelMap.from_list_disj 
       (List.map (fun (l,t) -> Value.label_ascii l, Types.cons t) l)))

module Reader = struct
  let b = Buffer.create 10240
  let buf = String.create 1024
  
  let rec read_loop ic =
    let i = input ic buf 0 (String.length buf) in
    if i > 0 then (Buffer.add_string b (String.sub buf 0 i); read_loop ic)

  let ic ic =
    read_loop ic;
    let s = Buffer.contents b in
    Buffer.clear b;
    s
end

let run_process cmd =
  let (sout,sin,serr) as h = Unix.open_process_full cmd (Unix.environment()) in
  close_out sin;
  let sout = Reader.ic sout in
  let serr = Reader.ic serr in
  sout,serr, Unix.close_process_full h

let process_status = function
  | Unix.WEXITED n ->
      Value.Pair (Value.atom_ascii "exited", Value.ocaml2cduce_int n)
  | Unix.WSTOPPED n ->
      Value.Pair (Value.atom_ascii "stopped", Value.ocaml2cduce_int n)
  | Unix.WSIGNALED n ->
      Value.Pair (Value.atom_ascii "signaled", Value.ocaml2cduce_int n)
49 50


51 52 53 54 55 56 57 58 59 60 61
let system_out =
  record_type_ascii [
    "stdout", string_latin1;
    "stderr", string_latin1;
    "status", variant_type_ascii [
      "exited", int;
      "stopped", int;
      "signaled", int
    ]
  ]
    
62

63
let () = register_fun "system" string_latin1 system_out
64 65
  (fun v ->
     Location.protect_op "system";
66 67 68 69 70 71 72
     let cmd = Value.get_string_latin1 v in
     let sout,serr,ps = run_process cmd in
     Value.record_ascii [
       "stdout", Value.string_latin1 sout;
       "stderr", Value.string_latin1 serr;
       "status", process_status ps
     ]
73
  )
74 75 76
  
let () = register_fun "exit" byte_int Types.empty
  (fun v -> Location.protect_op "exit"; exit (Value.cduce2ocaml_int v))