sysutil.ml 3.84 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2010-                                                   *)
(*    Francois Bobot                                                      *)
(*    Jean-Christophe Filliatre                                           *)
(*    Johannes Kanig                                                      *)
(*    Andrei Paskevich                                                    *)
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
(*  License version 2.1, with the special exception on linking            *)
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software is distributed in the hope that it will be useful,      *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
(*                                                                        *)
(**************************************************************************)

20 21 22 23 24 25 26 27 28 29 30
let channel_contents_fmt cin fmt =
  let buff = String.make 1024 ' ' in
  let n = ref 0 in
  while n := input cin buff 0 1024; !n <> 0 do
    Format.pp_print_string fmt
      (if !n = 1024 then
         buff
       else
         String.sub buff 0 !n)
  done

31 32 33 34
let channel_contents_buf cin =
  let buf = Buffer.create 1024
  and buff = String.make 1024 ' ' in
  let n = ref 0 in
35
  while n := input cin buff 0 1024; !n <> 0 do
36 37 38 39 40 41
    Buffer.add_substring buf buff 0 !n
  done;
  buf

let channel_contents cin = Buffer.contents (channel_contents_buf cin)

42 43 44 45 46
let rec fold_channel f acc cin =
  try
    fold_channel f (f acc (input_line cin)) cin
  with End_of_file -> acc

47 48 49 50 51
let file_contents_fmt f fmt =
  try
    let cin = open_in f in
    channel_contents_fmt cin fmt;
    close_in cin
52
  with _ ->
53 54
    invalid_arg (Printf.sprintf "(cannot open %s)" f)

55
let file_contents_buf f =
56
  try
57 58 59 60
    let cin = open_in f in
    let buf = channel_contents_buf cin in
    close_in cin;
    buf
61
  with _ ->
62 63 64 65
    invalid_arg (Printf.sprintf "(cannot open %s)" f)

let file_contents f = Buffer.contents (file_contents_buf f)

Francois Bobot's avatar
Francois Bobot committed
66
let open_temp_file ?(debug=false) filesuffix usefile =
67 68 69
  let file,cout = Filename.open_temp_file "why" filesuffix in
  try
    let res = usefile file cout in
Francois Bobot's avatar
Francois Bobot committed
70
    if not debug then Sys.remove file;
71 72 73
    close_out cout;
    res
  with
74
    | e ->
Francois Bobot's avatar
Francois Bobot committed
75
        if not debug then Sys.remove file;
76 77
        close_out cout;
        raise e
78

Francois Bobot's avatar
Francois Bobot committed
79 80 81 82 83 84 85 86
type 'a result =
  | Result of 'a
  | Exception of exn

open Unix

exception Bad_execution of process_status

87
let call_asynchronous (f : unit -> 'a) =
Francois Bobot's avatar
Francois Bobot committed
88 89 90 91
  let cin,cout = pipe () in
  let cin = in_channel_of_descr cin in
  let cout = out_channel_of_descr cout in
  match fork () with
92 93
    | 0 ->
        let result =
Francois Bobot's avatar
Francois Bobot committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
          try
            Result (f ())
          with exn -> Exception exn in
        Marshal.to_channel cout (result : 'a result) [];
        close_out cout;
        exit 0
    | pid ->
        let f () =
          let result = (Marshal.from_channel cin: 'a result) in
          close_in cin;
          let _, ps = waitpid [] pid in
          match ps with
            | WEXITED 0 ->
                begin match result with
                  | Result res -> res
                  | Exception exn -> raise exn
                end
            | _ -> raise (Bad_execution ps) in
        f
113

François Bobot's avatar
François Bobot committed
114 115 116 117 118 119 120 121
let copy_file from to_ =
  let cin = open_in from in
  let cout = open_out to_ in
  let buff = String.make 1024 ' ' in
  let n = ref 0 in
  while n := input cin buff 0 1024; !n <> 0 do
    output cout buff 0 !n
  done