lurettetop.ml 7.42 KB
Newer Older
1
(*-----------------------------------------------------------------------
2
** Copyright (C) - Verimag.
3 4 5 6 7 8 9
**
** File: lurettetop.ml
** Main author: jahier@imag.fr
*)

(** lurette toplevel loop. *)

10

11
open LtopArg
12 13

(***********************************************************************)
14
(* Parsing .lurette_rc and command line options *)
15

16

17 18
let main_read_arg () =
  let sut_dir = (Unix.getcwd ())  in
19
  let _ = args.sut_dir <- sut_dir in
20
  let lurette_rc = (Filename.concat args.sut_dir ".lurette_rc") in
21
  let _ =
22 23 24
    (* Read command in the .lurette_rc file *)
    (if Sys.file_exists lurette_rc then
       let ic = (open_in lurette_rc) in
25 26
	      try
	        while true do
27 28
             let str = input_line ic in
	          ignore (Cmd.read str)
29 30 31
	        done
	      with End_of_file ->
	        close_in ic
32
     else
33
       ()
34
    );
35 36
    let (explicit_the_luc_files : string -> unit) =
      fun s -> 
37 38 39 40 41 42 43
        if Filename.is_implicit s
        then args.env <- Filename.concat args.sut_dir s
        else args.env <- s;
        if not (Sys.file_exists args.env) then (
          Printf.printf "*** File %s does not exist!\n" s;
          flush stdout
        )
44
    in
45 46
      (* read the lurettetop command line options (that will override the
         .lurette_rc ones) *)
47 48 49
    let env_saved = args.env in
      args.env <- "";      
      ( try Arg.parse LtopArg.speclist explicit_the_luc_files usage
50 51 52 53 54 55 56 57 58 59
	     with
	         Failure(e) ->
	           output_string args.ocr e;
	           flush args.ocr ;
	           flush args.ecr ;
	           exit 2
	       | e ->
	           output_string args.ocr (Printexc.to_string e);
	           flush args.ocr;
	           exit 2
60
      );
61
      if args.sut_node = "" then 
62
	     args.sut_node <- (Util.chop_ext_no_excp (Filename.basename args.sut));
63 64
      if args.root_node = "" then args.root_node <- args.sut_node;
      if (args.env = "") then args.env <- env_saved;
65 66
  in  
  let lurette_tmp_dir = 
67
    match args.tmp_dir_provided with 
68
	     None -> 
69
          if args.direct_mode then "." else  Util.get_fresh_dir Sys.os_type 
70 71 72
      | Some file -> file  
  in 
  let _ = 
73
    args.tmp_dir <- lurette_tmp_dir; 
74 75
    Unix.putenv "TMPDIR" (String.escaped lurette_tmp_dir) ; 
  in 
erwan's avatar
erwan committed
76
  let _source_dir = (Filename.concat (ExtTools.lurette_path()) "source") in
77
    match args.sut_compiler with
78
      | Scade  -> assert false     
79 80 81 82 83
      | VerimagV4
      | VerimagV6
      | ScadeGUI
      | Sildex
      | Stdin
84
      | Ocamlopt -> ()
85 86 87 88
	      
let _ = main_read_arg ()

(***********************************************************************)
89
(* Socket administration.
90

91 92 93 94
Indeed,  xlurette calls lurettetop (as a client) via sockets
*)

let _ = match args.socket_port, args.socket_inet_addr with
95 96 97
  | None, None -> ()
  | None, _ -> failwith "*** --socket-port expected.\n"
  | _, None -> failwith "*** --socket-inet-addr expected.\n"
98
  | Some port, Some sock_inet_addr_str ->       
99
      let port_err = 
100 101 102 103
	     match args.socket_err_port with
	         None -> if not args.log then 
	           failwith "--log or --socket-err-port excpected.\n" else 0
	       | Some port_err -> port_err
104 105 106 107 108 109 110
      in
      let sock_addr = Unix.inet_addr_of_string sock_inet_addr_str in
      let sock_io =  Unix.socket Unix.PF_INET Unix.SOCK_STREAM  0 in
      let sock_err = Unix.socket Unix.PF_INET Unix.SOCK_STREAM  0 in

      (* loop to avoid the race between connect and accept *)
      let rec connect_loop s saddr p cpt =
111 112 113 114 115 116
	     try
	       Unix.connect s (Unix.ADDR_INET(saddr, p))
	     with Unix.Unix_error(errcode, funcstr, paramstr) ->
	       Unix.sleep 1; (* so that xlurette have the time to connect... Beurk! *)
	       if cpt = 0 then 
	         (
117
	           output_string args.ocr "ltop connect failure: ";
118 119 120 121 122 123 124 125 126 127
	           output_string args.ocr (Unix.error_message errcode);
	           flush args.ocr;
	           exit 2
	         )
	       else 
	         (
	           output_string args.ocr "ltop: retry connecting ...\n";
	           flush args.ocr;
	           connect_loop s saddr p (cpt-1)
	         )
128
      in
129
	     connect_loop sock_io sock_addr port 10;
130
        let ic = Unix.in_channel_of_descr sock_io in 
131
	     let oc =
132
          if args.log 
133 134 135 136 137 138 139 140
	       then 
	         open_out 
		        (Filename.concat args.tmp_dir 
		           (Filename.concat ".."
		              (Filename.concat ".." "lurette_stdout.log")))
	       else
	         Unix.out_channel_of_descr sock_io
	     in
141
	       if (args.verbose > 0) then (
142 143 144 145 146 147 148 149 150 151 152 153
	         output_string args.ocr ("connect stdout on port " ^ 
				                          (string_of_int port) ^ "\n");
	         flush args.ocr
	       );
	       args.icr <- ic;
	       args.ocr <- oc;
	       
	       flush oc;
	       let x = input_line args.icr in (* that one is blocking (hopefully) *)
	         if x = "hello." then ( ) else
	           (
		          output_string args.ocr (
154
		            "ltop: socket connection error.\n" ^ x ^ "<>hello.\n");
155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
		          flush args.ocr;
		          exit 2
	           );	   	    
	         let ec = 
	           if args.log 
	           then 
		          open_out
		            (Filename.concat args.tmp_dir 
		               (Filename.concat ".."
		                  (Filename.concat ".." "lurette_stderr.log")))
	           else 
		          (
		            connect_loop sock_err sock_addr port_err 10; 
		            Unix.out_channel_of_descr sock_err 
		          )
	         in
171
	           if (args.verbose > 0) then 
172 173 174 175 176 177
		          (
		            output_string args.ecr (
		              "connect stderr on port " ^ (string_of_int port_err) ^ "\n"); 
		            flush args.ecr
		          );
	           args.ecr <- ec
178 179 180

(**************************************************************************)

181 182 183 184
let rec (main_loop : int -> unit) =
  fun cpt ->
    if args.socket_port = None then
      (output_string args.ocr
185 186 187 188
	      (match args.prompt with
	           None -> "<lurette " ^ (string_of_int cpt) ^ "> "
	         | Some prompt -> prompt
	      );
189 190
       flush args.ocr
      );
191 192
    let str = input_line args.icr in
    let continue = Cmd.read str in
193
      if continue then main_loop (cpt+1)
194

195
let lurettetop_quit msg () =
196 197 198 199 200 201
  let tmp_file = (Filename.temp_file "lurette" "") in
    if Filename.dirname tmp_file = Filename.dirname args.tmp_dir 
      && not (args.direct_mode)
    then
	   (* do not clean if the tmp dir is a user dir (--tmp-dir option) *) 
	   Util.rm_dir stdout args.tmp_dir;
202

203 204
    Sys.remove tmp_file ;    
    Unix.chdir args.sut_dir;
205
    flush args.ecr;
206
    output_string args.ecr (msg^"\nlurettetop: bye!\n");
207
    flush args.ocr
208
      
209 210

let main_loop_start () =
211
  output_string args.ocr ("This is Lurette Version "^(Version.str)^" (\""^Version.sha^"\") \n");
212
  flush args.ocr;
213
  if not (args.go) then (main_loop 1; Unix.chdir args.sut_dir) else
214 215 216 217
    (if args.direct_mode || Build.f args then (
	    Unix.chdir args.sut_dir;
       let res = Run.f () in
	      if (res) <> 0 then (
218
	        Printf.fprintf args.ocr "\nLurette launched a process that failed (exit %d).\n \n" res;
219
           flush args.ocr; 
220 221
           Sys.catch_break false;
	        exit res
222 223 224 225 226 227 228 229 230
	      );
     )
     else
	    (
	      output_string args.ocr "Can not build lurette, sorry\n \n \n";
	      flush args.ocr; 
	      exit 2
	    )
    )
231

232

233 234
let _ =  
  Sys.catch_break true;
235
  at_exit (lurettetop_quit "break signal catched\n"); 
236
  if args.verbose > 0 then output_string args.ocr "lurettetop: starting...\n";
237 238
  flush args.ocr;
  try  main_loop_start ()
239 240 241
  with e -> 
    print_string ("*** lurettetop: " ^ (Printexc.to_string e) ^ "\n");
    flush stdout;
242
    exit 2
243
;;
244