lurettetop.ml 24.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
(*pp camlp4o *)
(*-----------------------------------------------------------------------
** Copyright (C) 2002 - Verimag.
** This file may only be copied under the terms of the GNU Library General
** Public License 
**-----------------------------------------------------------------------
**
** File: lurettetop.ml
** Main author: jahier@imag.fr
*)

12

13
14
15
16
17
18
19
20
21
22
(** lurette toplevel loop. *)

let usage = "
usage: lurettetop [<options>] [<env ([x] env)*>]

lurettetop is a small top level loop that let one use lurette. 
Type help and/or man at the prompt for more info.

Command line <options> are:
"
23
type draw_mode = Verteces | Edges | Inside
24
25
26
27
28
29
30
31

type flagT = {
  mutable sut : string ;  
  mutable oracle : string option ;
  mutable env : string ;
  mutable step_nb : int;
  mutable formula_nb : int ;
  mutable draw_nb : int ;
32
  mutable draw_mode : draw_mode ;
33
34
35
36
37
38
39
  mutable step_by_step : bool ref ;
  mutable display_local_var : bool ref ;
  mutable display_sim2chro : bool ref;
  mutable seed : int option ;
  mutable verbose : bool ref ;
  mutable output : string ;
  mutable make_opt : string ;
40
  mutable prompt : string option ;
41
  mutable go : bool ref ;
42
  mutable restore : string option;
43
44
45
46
47
48
49
50
51
52
53
54
55
(* a flag to know whether lurette_exe needs to be (re-)build *)
  mutable to_build : bool ref
}


let (flag : flagT) = {
  sut = "" ;
  oracle = None ;
  env = "";
  make_opt = "" ;
  step_nb = 10;
  formula_nb = 1 ;
  draw_nb  = 1 ;
56
  draw_mode = Inside ;
57
58
59
60
61
62
  step_by_step = ref false ;
  display_local_var = ref true ;
  display_sim2chro = ref true ;
  seed = None ;
  verbose = ref false ;
  output = "lurette.rif" ;
63
  prompt = None ;
64
  go = ref false ;
65
  restore = None ;
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
  to_build = ref true
}

let rec speclist = 
  [
    "--sut", Arg.String (fun s -> flag.sut <- s), 
       "<string>\tFile name of the system under test (without extension).";
    "-sut", Arg.String (fun s -> flag.sut <- s), " <string>\n" ;

    "--oracle", Arg.String (fun s -> flag.oracle <- Some s), 
       "<string>\tFile name of the oracle (without extension).";
    "-oracle", Arg.String (fun s -> flag.oracle <- Some s), " <string>\n";

    "--test-length", Arg.Int (fun i -> flag.step_nb <- i),
       "<int>\tNumber of steps to be done";
    "-l", Arg.Int (fun i -> flag.step_nb <- i),  
    ("<int>\t\t(default=" ^ (string_of_int flag.step_nb) ^ ").\n");

    "--thick-form", Arg.Int (fun i -> flag.formula_nb <- i),
       "<int>\tNumber of formula to be drawn at each step";
    "-tf", Arg.Int (fun i -> flag.formula_nb <- i), 
    ("<int>\t\t(default=" ^ (string_of_int flag.formula_nb) ^ ").\n");

    "--thick-draw", Arg.Int (fun i -> flag.draw_nb <- i),
       "<int>\tNumber of draw to be done in each formula ";
    "-td", Arg.Int (fun i -> flag.draw_nb <- i),
    ("<int>\t\tat each step (default=" ^ 
     (string_of_int flag.draw_nb) ^ ").\n");
    
95
96
97
98
    "--draw-inside", Arg.Unit (fun _ -> flag.draw_mode <- Inside),
       "\t\tDraw on the edges of the convex hull of solutions.\n .";

    "--draw-edges", Arg.Unit (fun _ -> flag.draw_mode <- Edges),
99
100
       "\t\tDraw on the edges of the convex hull of solutions.\n .";

101
    "--draw-verteces", Arg.Unit (fun _ -> flag.draw_mode <- Verteces),
102
103
104
       "\t\tDraw among the verteces of the convex hull of solutions.\n .";


105
106
107
108
109
110
    "--seed", Arg.Int (fun i -> flag.seed <- Some i),
       "<int>\t\tSeed the random engine is init with." ;
    "-seed", Arg.Int (fun i -> flag.seed <- Some i), " <int>\n";

    "--make-opt", Arg.String (fun s -> flag.make_opt <- s), 
    ("<string>\tOptions to call make with when building \n" ^ 
111
     "\t\t\tlurette (default=\"" ^ flag.make_opt ^ "\").\n");
112
113
114
115
116
117
118
119
120
121

    "--output", Arg.String (fun s -> flag.output <- s),
    ("<string>\tSet the output file name (default is \"" ^ 
    flag.output ^ "\").");
    "-o", Arg.String (fun s -> flag.output <- s), "<string>\n";

    "--go", Arg.Set flag.go, 
    "\t\t\tStart the testing process directly without prompting.";
    "-go", Arg.Set flag.go, "\n";

122
    "--restore", Arg.String (fun s -> flag.restore <- Some s), 
123
       "<string>\tFile name of the package containing"
124
       ^ "\n\t\t\tthe temporarily files to be restored (cf the pack command).\n";
125

126
127
128
129
130
131
132
    "--step", Arg.Set flag.step_by_step, "\t\tRun lurette step by step." ;
    "-s", Arg.Set flag.step_by_step, "\n";

    "--verbose", Arg.Set flag.verbose,
       "\t\tSet on the verbose mode.";
    "-v", Arg.Set flag.verbose,"\n";

133
134
135
136
    "--prompt", Arg.String (fun s -> flag.prompt <- Some s), 
       "\t\tReplace the default prompt.\n";


137
    "--sim2chro", Arg.Set flag.display_sim2chro,
138
       "\t\tCall sim2chro when lurette resumes.\n";
139
140

    "--no-sim2chro", Arg.Clear flag.display_sim2chro,
141
       "\tDo not call sim2chro when lurette resumes.";
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
    "-ns2c", Arg.Clear flag.display_sim2chro, "\n";

    "--local-var", Arg.Set flag.display_local_var,
       "\t\tDisplay environment local variables in sim2chro (default).";

    "--no-local-var", Arg.Clear flag.display_local_var,
       "\tDo not display environment local variables in sim2chro.\n" ;

    "--help", Arg.Unit (fun _ -> (Arg.usage speclist usage ; exit 0)),
       "\t\tDisplay this list of options." ;
    "-help", Arg.Unit (fun _ -> (Arg.usage speclist usage ; exit 0)),
    "";
    "-h", Arg.Unit (fun _ -> (Arg.usage speclist usage ; exit 0)),
    ""
]



160
161
let (build : string -> string -> string -> bool) =
  fun user_dir lurette_tmp_dir lurette_dir ->
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    let sut = 
      if Filename.is_relative flag.sut 
      then (user_dir ^ flag.sut) 
      else flag.sut 
    in
      if not (Sys.file_exists (sut ^ ".lus"))
      then
	(
	  output_string stdout ("*** File " ^ sut ^ 
				".lus does not exist.\n");
	  flush stdout;
	  false
	)
      else
	(
	  output_string stderr "  building lurette ...\n";
	  flush stderr;
	  if (flag.sut = "" or flag.env = "")
	  then
	    (
	      print_string "*** 
183
184
  Both the sut and the env fields should be filled
  with set_sut and set_env commands respectively.\n ";
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
	      false
	    )
	  else
	    let (oracle, oracle2) =  
	      match flag.oracle 
	      with 
		  None -> "", (lurette_tmp_dir ^ "/always_true") 
		| Some str -> 
		    let str2 = 
		      if Filename.is_relative str then (user_dir ^ str) else str 
		    in
		      (str2, str2)
	    in
	    let gen_stubs_cmd = 
	      ("gen_stubs " ^ sut ^ " " ^ oracle ^ " > gen_stubs.log  \n") 
	    and make_cmd = 
	      ("make -I " ^ user_dir ^ " -f " 
	       ^ lurette_dir ^ "/Makefile.lurette " ^ flag.make_opt ^ "> make_lurette.log \n")
	    in
	      if oracle2 <>  (lurette_tmp_dir ^ "/always_true")
		&& not (Sys.file_exists (oracle2 ^ ".lus"))
	      then
		(
		  output_string stdout ("*** File " ^ oracle2 ^ 
					".lus does not exist.\n");
		  flush stdout;
		  false
		)
	      else
		(
		  Unix.putenv "SUT" (sut ^ ".c");
		  Unix.putenv "ORACLE" (oracle2 ^ ".c");
		  output_string stderr gen_stubs_cmd ;
		  flush stderr ;
		  flush stdout;
		  if ((Sys.command gen_stubs_cmd) <> 0)
		  then false
		  else
		    (
		      output_string stderr "   ... gen_stubs ok.\n";
		      output_string stderr make_cmd ;
		      flush stderr ;
		      flush stdout;
		      if ((Sys.command make_cmd) <> 0)
		      then false
		      else 
			(
			  output_string stderr "   ...make ok.\n";
			  true
			)
		    )
		)
	)
238
239
(* run lurette and returns the exit status *)
let (run : string -> int) =
240
  fun lurette_tmp_dir ->
241
242
243
244
245
    let seed_str = 
      match flag.seed with 
	  None -> "" 
	| Some i -> (" -seed " ^ (string_of_int i))
    and verb_str = if !(flag.verbose) then " -v" else ""
246
247
248
249
250
    and draw_mode_str = 
      match flag.draw_mode with
	  Inside -> " "
	| Edges -> " --draw-edges"
	| Verteces -> " --draw-verteces" 
251
252
253
254
255
256
257
258
259
260
    and orac_str = 
      match flag.oracle with 
	  None -> " --no-oracle" 
	| Some str -> ""
    and outp_str = (" -o " ^ flag.output)
    and step_str = if !(flag.step_by_step) then " -s" else ""
    and sim2_str = if !(flag.display_sim2chro) then " --call-sim2chro" else " -ns2c"
    and dlvr_str = 
      if !(flag.display_local_var) then " --display-local-var " else " -nlv "
    in
261
    let times0 = Unix.times () in
262
263
    let run_cmd =
      (lurette_tmp_dir ^ "/lurette " ^ 
264
265
266
      (string_of_int flag.step_nb) ^ " " ^
      (string_of_int flag.formula_nb) ^ " " ^
      (string_of_int flag.draw_nb) ^ " " ^
267
       draw_mode_str ^ seed_str ^ verb_str ^ orac_str ^ outp_str ^ step_str ^
268
       sim2_str ^ dlvr_str ^ flag.env
269
      )
270
    in
271
272
273
    let result =
      output_string stderr (run_cmd ^ "\n");
      flush stderr;
274
      Sys.command run_cmd
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
    in
      if result = 0 then
	(
	  let times1 = Unix.times () in
	  let times = 
	    times1.Unix.tms_cutime
	    +.times1.Unix.tms_cstime
	    -.times0.Unix.tms_cutime
	    -.times0.Unix.tms_cstime
	  in
	  let times_str = string_of_float times in
	    output_string stdout 
	      ("\nThe execution lasts " ^ times_str ^ " second" ^ 
	       (if times > 1. then "s" else "") ^ ".\n" ^
	       "********************************************************************\n");
	    flush stdout;
	    result
	)
	else
	  result
     
296
297
298
299
300
301
302
303
304
type cmd =
    Sut of string
  | Oracle of string
  | MakeOpt of string
  | Env of string
  | StepNb of int
  | FormulaNb of int
  | DrawNb of int
  | Step of bool
305
  | DisplaySim2chro of bool
306
  | DisplayLocalVar of bool
307
  | StepByStep of bool
308
  | Seed of int
309
  | RandomSeed
310
311
  | Verbose of bool
  | Output of string
312
  | CallSim2chro
313
314
315
  | Build
  | Clean
  | Run
316
317
318
  | DrawInside
  | DrawEdges
  | DrawVerteces
319
320
321
  | Quit
  | Help
  | Man
322
  | Prompt of string
323
  | Pack of string
324
  | Show
325
326
327
328
329
330
331
  | HelpSimple
  | Error of string

let lexer = Genlex.make_lexer []

type tok = Genlex.token Stream.t

332
333
334
335
336
337
338
339
340
341
342
343
344

let (remove_extension : string -> string) =
  fun str -> 
    let file_ext = Filename.basename str
    and dir  = Filename.dirname str in
    let file = try Filename.chop_extension file_ext with _ -> file_ext in
      (Filename.concat dir file)

let _ = assert ((remove_extension "../toto/tutu.lus") = "../toto/tutu")
let _ = assert ((remove_extension "/home/toto/tutu.lus") = "/home/toto/tutu")
let _ = assert ((remove_extension "home/toto/tutu.lus") = "home/toto/tutu")
let _ = assert ((remove_extension "home/toto/tutu") = "home/toto/tutu")

345
346
347
348
349
let rec 
  (read_cmd : tok -> cmd) =
  fun tok -> 
    match tok with parser
      | [< 'Genlex.Ident "run" >] -> Run
350
      | [< 'Genlex.Ident "r" >] -> Run
351
      | [< 'Genlex.Ident "b" >] -> Build
352
      | [< 'Genlex.Ident "build" >] -> Build
353
354
355
356
357
358
359
360
361
      | [< 'Genlex.Ident "set_draw_mode" ;'Genlex.Ident id >] -> 
	  (
	    match id with 
		"inside" -> DrawInside
	      | "edges"  -> DrawEdges
	      | "verteces" -> DrawVerteces
	      | _ -> Error ("Unknown draw mode (" ^ id ^ ")\n")
	  )
      | [< 'Genlex.Ident "show" >] -> Show
362
      | [< 'Genlex.Ident "clean" >] -> Clean
363
364
365
      | [< 'Genlex.Ident "set_prompt"; 'Genlex.String str >] -> Prompt(str)
      | [< 'Genlex.Ident "set_env" ; 'Genlex.String str >] -> Env(str)
(*       | [< 'Genlex.Ident "set_env" ; str = parse_env >] -> Env(str) *)
366
367
      | [< 'Genlex.Ident "set_sut" ; str = parse_file_name >] -> Sut(str)
      | [< 'Genlex.Ident "set_oracle" ; str = parse_file_name >] -> Oracle(str)
368
369
370
371
372
      | [< 'Genlex.Ident "set_make_opt" ; 'Genlex.Ident str >] -> MakeOpt(str)
      | [< 'Genlex.Ident "set_test_length" ; 'Genlex.Int i >] -> StepNb(i)
      | [< 'Genlex.Ident "set_formula_nb" ; 'Genlex.Int i >] -> FormulaNb(i)
      | [< 'Genlex.Ident "set_draw_nb" ; 'Genlex.Int i >] -> DrawNb(i)
      | [< 'Genlex.Ident "set_seed" ; 'Genlex.Int i >] -> Seed(i)
373
      | [< 'Genlex.Ident "set_seed_randomly" >] -> RandomSeed
374

375
376
377
378
379
      | [< 'Genlex.Ident "set_step_by_step" ; 'Genlex.Ident str >] -> 
	  if List.mem str ["t";"true"] 
	  then StepByStep(true)
	  else StepByStep(false)

380
381
382
383
      | [< 'Genlex.Ident "set_display_sim2chro" ; 'Genlex.Ident str >] -> 
	  if List.mem str ["t";"true"] 
	  then DisplaySim2chro(true)
	  else DisplaySim2chro(false)
384
385
386
387
388
389
390
391
392
393
      | [< 'Genlex.Ident "set_display_local_var" ; 'Genlex.Ident str >] -> 
	  if List.mem str ["t";"true"] 
	  then DisplayLocalVar(true)
	  else DisplayLocalVar(false)

      | [< 'Genlex.Ident "set_verbose" ; 'Genlex.Ident str >] -> 
	  if List.mem str ["t";"true"] 
	  then Verbose(true)
	  else Verbose(false)

394
      | [< 'Genlex.Ident "set_output" ; str = parse_file_name>] -> Output(str ^ ".rif")
395
      | [< 'Genlex.Ident "sim2chro" >] -> CallSim2chro
396
397
398
399
400
401
402
403

      | [< 'Genlex.Ident "quit"  >] -> Quit
      | [< 'Genlex.Ident "q"  >] -> Quit
      | [< 'Genlex.Ident "bye"  >] -> Quit
      | [< 'Genlex.Ident "exit"  >] -> Quit

      | [< 'Genlex.Ident "man"  >] -> Man

404
405
      | [< 'Genlex.Ident "pack"  ; 'Genlex.Ident file >] -> Pack(file)

406
407
408
409
410
411
      | [< 'Genlex.Ident "help"  >] -> Help
      | [< 'Genlex.Ident "h"  >] -> Help
      | [< 'Genlex.Ident "?"  >] -> Help
      | [< 'Genlex.Ident _ >]  -> Error "Unknown command.\n"
      | [<   >] -> HelpSimple

412
413
414
415
416
and  
  (parse_file_name : tok -> string) = 
  fun tok -> 
    try
      match tok with parser 
417
418
	| [<  'Genlex.String str >] -> 
	    if str = "" then "" else remove_extension str 
419
	| [<  'Genlex.Ident id  >] -> id
420
	| [<  >]  ->  "" 
421
422
      with _ -> 
	print_string 
423
424
425
	   "*** parse error: cannot parse that file name.\n";
	flush stdout;
	""
426
and  
427
  (parse_env : tok -> string) = 
428
429
  fun tok -> 
    try
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
      (
	match tok with parser 
	  | [<  'Genlex.Ident "x" ; tail = parse_env >] -> (" x " ^ tail)
	  | [<  'Genlex.String str ; tail = parse_env >] -> 
	      ((remove_extension str) ^ ".ima " ^ tail) 
	  | [<  'Genlex.Ident id  ; tail = parse_env >] -> (id ^ ".ima " ^ tail)
	  | [< _ >]  ->  "" 
      )
    with e -> 
      print_string (Printexc.to_string e);
      print_string 
         "*** Error when parsing the environment field.\n";
      flush stdout;
      ""
	
	
446

447
let cmd_usage = "  Type h for help, or man for a small user manual.
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
"

let man = "
Once lurettetop has been run, a prompt is printed waiting for 
user queries. One first need at least to set the sut (system 
under test) and the environement fields like that:

    [your shell prompt] lurettetop  
    <lurette> set_sut my_program_to_test
    <lurette> set_oracle my_oracle
    <lurette> set_env my_env_file1 my_env_file2 x my_env_file3

And then the testing process can start:

    <lurette> run
       ... [test, test, test, ...]
   
Equivalently, you can directly set values at the command line:

    [your shell prompt] lurettetop --sut my_program_to_test  \\
                          --oracle my_oracle \\
                          my_env_file1 my_env_file2 x my_env_file3
    <lurette> run
       ... [test, test, test, ...]
"

	
let (display_cmd : unit -> unit) = 
  fun _ -> 
    let msg =  "The commands are: 

479
run, r
480
     to start the testing process. Note that the sut and the environment
481
482
     fields (described below) should be set.

483
quit q, bye  
484
485
486
487
488
489
490
491
492
493
494
495
     to quit the lurette top level


help, h, ?
     display this list of commands

man
     display a small user manual

clean
     run a make clean (you can try it if <<run>> failed)

496
497
498
499
500
pack <file_name>
     package up in <file_name>.tgz files created in a temporary 
     directory. This file can then be given in argument of the 
     <<--restore>> option of lurettetop so that they are not 
     computed again.
501
502
503
504

show
    show of post-script version of the current environment

505

506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
set_env  <env ([x] env)*>  (env=<file name without extension>)                   
     to set the environment field (.ima files). Automata of
     environments separated by \"x\" are multiplied.
     The current value of this field is "
	       ^ 
	       (if flag.env = "" 
		then "UNSET!" 
		else ("\"" ^ flag.env ^ "\" ")) ^ "

set_sut  <file name without extension>            
     to set the sut field. Its current value is " ^ 
	       (if flag.sut = "" 
		then "UNSET!" 
		else ("\"" ^ flag.sut ^ "\"")) ^ "

set_oracle  <file name without extension>      
     to set the oracle field. Its current value is " ^ 
	       (match flag.oracle with
		    None ->  "unset" 
		  | Some str -> ("\"" ^ str ^ "\"")) ^ "
    
set_test_length  <integer>
     to set the test length. Its current value is \"" ^ 
	       (string_of_int flag.step_nb) ^ "\"

set_formula_nb  <integer>                      
     to set the number of formula to be drawn at each step. Its current 
     value is \"" 
	       ^ (string_of_int flag.formula_nb) ^ "\"

set_draw_nb  <integer>
     to set the number of draw to be done in each formula at each step
     Its current value is \"" ^ (string_of_int flag.draw_nb) ^ "\"

540
541
542
543
544
545
546
547
548
549
550
set_draw_mode <draw_mode>
    set the draw mode, which can be either be inside, edges, or verteces.
    - inside : draw inside the convex hull of solutions.
    - edges : draw on the edges of the convex hull of solutions.
    - verteces : draw among the verteces of the convex hull of solutions.
    Its current mode is \"" ^ (match flag.draw_mode with
			    	 Inside -> "inside"
			       | Edges -> "edges"
			       | Verteces -> "verteces" 
			    ) ^ "\".

551
552
553
554
555
set_seed  <integer>
     to set the seed the random engine is initialised with.
     Its current value is " ^ (match flag.seed with
			       None ->  "chose randomly" 
			     | Some i -> ("\"" ^ (string_of_int i) ^ "\""))  ^ "
556
557
558

set_seed_randomly
     to the system set a seed randomly.
559
560
561
562
563
564
565
566
567
  
set_step_by_step  <boolean>
     to set a flag saying whether or not the test should proceed step
     by step. Its current value is " ^ (if !(flag.step_by_step) 
			   then "\"true\""
			   else "\"false\"") ^ "

set_display_sim2chro  <boolean>
     to set a flag saying whether or not sim2chro is called when 
568
       lurette resumes. Its current value is " 
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
	       ^ (if !(flag.display_sim2chro)
			   then "\"true\""
			   else "\"false\"") ^ "

set_display_local_var  <boolean>
     to set a flag saying whether or not the local var be displayed in  
     sim2cro. Its current value is " ^ (if !(flag.display_local_var) 
			   then "\"true\""
			   else "\"false\"") ^ "

set_verbose  <boolean>
     to set on and off a verbose mode. Its current value is " 
	       ^ (if !(flag.verbose) 
			   then "\"true\""
			   else "\"false\"") ^ "

set_make_opt  <string>
586
     to set the options to give to make for building lurette
587
588
589
590
591
592
     Its current value is \"" ^ flag.make_opt ^ "\"

set_output  <string>
     to set the name of the file the (rif) output of the test is
     put into. Its current value is \"" ^ flag.output ^ "\"

593
594
595
sim2chro
    call sim2chro

596
597
598
599
600
"
    in
      print_string msg
    

601
602
603
604
605
606
607
608
609
610
611
let rec (main_loop : string -> string -> string -> int -> unit) =
  fun user_dir lurette_tmp_dir lurette_dir cpt ->
    let _ = 
      print_string 
	(
	  match flag.prompt with 
	      None -> "<lurette " ^ (string_of_int cpt) ^ "> "
	    | Some prompt -> prompt
	) ; 
      flush stdout 
    in
612
613
614
615
616
    let continue =
      try 
	( match (read_cmd (lexer (Stream.of_string (read_line ())))) with
		     Sut(str) -> 
		       flag.sut <- str ; flag.to_build := true; true
617
618
619
620
621
		   | Oracle(str) ->
		       if str = "" then
			 ( flag.oracle <- None ; flag.to_build := true; true)
		       else 
			 ( flag.oracle <- Some str ; flag.to_build := true; true)
622
623
624
625
626
627
628
629
630
631
632
633
		   | MakeOpt(str) -> 
		       flag.make_opt <- str; true
		   | Env(llist) -> 
		       flag.env <- llist; true
		   | StepNb(i) -> 
		       flag.step_nb <- i; true
		   | FormulaNb(i) -> 
		       flag.formula_nb <- i; true
		   | DrawNb(i) -> 
		       flag.draw_nb <- i; true
		   | Step(b) -> 
		       flag.step_by_step := b; true
634
635
		   | DisplaySim2chro(b) -> 
		       flag.display_sim2chro := b; true
636
637
		   | DisplayLocalVar(b) -> 
		       flag.display_local_var := b; true
638
639
		   | StepByStep(b) -> 
		       flag.step_by_step := b; true
640
641
		   | Seed(i) -> 
		       flag.seed <- Some i; true
642
643
		   | RandomSeed -> 
		       flag.seed <- None; true
644
645
		   | Verbose(b) -> 
		       flag.verbose := b; true
646
647
		   | Prompt(p) -> 
		       flag.prompt <- Some p; true
648
649
650
651
652
653
		   | DrawInside -> 
		       flag.draw_mode <- Inside; true
		   | DrawEdges -> 
		       flag.draw_mode <- Edges; true
		   | DrawVerteces -> 
		       flag.draw_mode <- Verteces; true
654
655
656
		   | Output(str) -> 
		       flag.output <- str; true
		   | Clean -> 
657
658
659
660
		       let rm_cmd = ("rm -f " ^ lurette_tmp_dir ^ "/*") in 
		       let _ = Sys.command rm_cmd in
			 print_string (rm_cmd ^ "\n");
			 flag.to_build := true; 
661
662
			 true
		   | Build -> 
663
		       let build_ok = build user_dir lurette_tmp_dir lurette_dir in
664
665
666
			 if 
			   not build_ok 
			 then 
667
			   print_string "\n*** Cannot build lurette, sorry.\n"
668
669
			 else
			   flag.to_build := false; 
670
			 flush stdout;
671
672
			 true
		   | Run -> 
673
		       if (not !(flag.to_build) or (build user_dir lurette_tmp_dir lurette_dir))
674
675
676
		       then 
			 (
			   flag.to_build := false; 
677
			   Unix.chdir user_dir;
678
			   let result = run lurette_tmp_dir in
679
680
681
682
683
684
			     if 
			       result <> 0  
			     then 
			       output_string stdout "\n*** Can not run lurette, sorry.\n"
			     else 
			       (output_string stderr "   ... lurette ok.\n"; flush stderr)
685
			 )
686
687
688
		       else 
		         print_string "\n*** Cannot build lurette, sorry.\n";
		       flush stdout;
689
		       Unix.chdir lurette_tmp_dir;
690
691
		       true
			 
692
693
694
695
696
		   | Show -> let _ = Sys.command ("show_ima " ^ user_dir ^ "/" ^ flag.env) in true
		   | CallSim2chro -> 
		       let sim_cmd = "sim2chro -ecran -in " ^ user_dir ^ "/" ^ flag.output ^ 
					    " > /dev/null &\n" in
		       let _ = output_string stderr sim_cmd ; flush stderr; Sys.command sim_cmd 
697
		       in
698
			 true
699
700
701
702
		   | Quit -> false
		   | HelpSimple -> print_string cmd_usage; true
		   | Help -> display_cmd (); true
		   | Man -> print_string man ; true
703
		   | Pack(file) ->
704
		       (* XXX autoconf: gnu tar ougth to be installed ! *)
705
706
707
708
709
710
		       let 
			 cmd = ("mv " ^ lurette_tmp_dir ^ " /tmp/" ^ file ^  
				"; cd " ^ user_dir ^ "; tar cvfz " ^ 
				file ^ ".tgz /tmp/" ^ file ^ 
				" > tar.log; mv /tmp/" ^ 
				file ^ " " ^ lurette_tmp_dir ^ " >> tar.log " ) 
711
		       
712
		       in
713
		       let tar_res = 
714
715
716
			 output_string stderr (cmd ^ "\n") ; 
			 flush stderr;
			 Sys.command cmd 
717
718
719
720
721
722
723
724
725
726
727
		       in	 
			 if tar_res <> 0 
			 then 
			   (
			     print_string ("*** <<" ^ cmd ^ 
					   ">> failed. Is gnu-tar in your path ?\n");
			     flush stdout;
			     true
			   )
			 else
			   true
728
729
730
731
732
		   | Error(errmsg) -> 
		       print_string errmsg; 
		       print_string cmd_usage;
		       true
	)
733
734
      with e -> 
	print_string ("Bad command\n " ^ (Printexc.to_string e) ^ "\n") ; 
735
736
737
	print_string cmd_usage ;
	true
    in
738
      if continue 
739
      then main_loop user_dir lurette_tmp_dir lurette_dir (cpt+1)
740
      else print_string "bye!\n"
741
742


743
744


745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
let (get_fresh_dir : unit -> string) = 
  fun _ ->  
    let rec get_fresh_dir_rec n = 
      let dir = "/tmp/lurette" ^ (string_of_int n) in 
	if 
	  not (Sys.file_exists dir) 
	then 
	  (  
	    Unix.mkdir dir 0o755;
	    dir 
	  )
	else 
	  get_fresh_dir_rec (n+1) 
    in 
      get_fresh_dir_rec 1 
760
761

   
762
763
764
765
766
767
768
769
770
771
772
773
let (rm_dir : string -> unit) =
  fun dir -> 
    (* XXX probably not very portable ...*)
    let cmd = ("rm -rf " ^ dir) in
      print_string cmd;
      print_string "\n";
      flush stdout;
      if Sys.command cmd <> 0 
      then print_string ("Can not remove" ^ dir ^ "\n")



774
let _ =
775
776
777
778
779
780
781
  let user_dir = (Unix.getcwd ()) ^ "/"  in 
  let lurette_dir = 
    try Sys.getenv "LURETTE_PATH"
    with _ -> 
      print_string "Environment var LURETTE_PATH is unset.\n";
      exit 2
  in
782
  let _ = 
783
784
785
786
787
788
789
    try
      Arg.parse speclist 
	  (fun s -> 
	     if s = "x" 
	     then flag.env <- (flag.env ^ " x ")
	     else flag.env <- (flag.env ^ s ^ ".ima ")
	  ) 
790
	  usage
791
792
793
794
795
796
797
    with 
	Failure(e) ->
	  print_string e;
	  flush stdout ;
	  flush stderr ;
	  exit 2
      | _ ->
798
	  exit 2
799
  in
800
  let tmp_dir = get_fresh_dir () in
801
802
  let lurette_tmp_dir = 
    match flag.restore with
803
	None -> tmp_dir
804
805
      | Some file ->
	  (* XXX autoconf: gnu tar ougth to be installed ! *)
806
807
	  let cmd = ("tar xvfz " ^ user_dir ^ file ^ " --directory " ^ tmp_dir) in 
	  let tar_res = 
808
809
	    output_string stderr (cmd ^ "\n"); 
	    flush stderr;
810
811
812
813
814
815
816
817
818
819
820
821
	    Sys.command cmd 
	  in
	    if tar_res <> 0 
	    then 
	      (
		print_string ("*** <<" ^ cmd ^ 
			      ">> failed. Is gnu-tar in your path?\n");
		flush stdout;
		exit 2
	      )
	    else
	      (tmp_dir ^ "/tmp/" ^ (remove_extension file))
822
  in
823
    
824
825
826
827
828
829
830
831
832
833
834
835
836
837
    Unix.chdir lurette_tmp_dir;
    if 
      !(flag.go)
    then 
      (
	if 
	  build user_dir lurette_tmp_dir lurette_dir
	then
	  (
	    Unix.chdir user_dir;
	    if 
	      (run lurette_tmp_dir) <> 0
	    then 
	      (
838
		print_string "Can not run lurette, sorry\n";
839
840
841
842
843
844
		exit 1
	      );
	    rm_dir lurette_tmp_dir;
	  )
	else  
	  (
845
	    print_string "Can not build lurette, sorry\n";
846
847
848
849
850
851
852
	    rm_dir lurette_tmp_dir;
	    exit 1
	  )
      )
    else 
      (* flag.go *)
      (
853
	main_loop user_dir lurette_tmp_dir lurette_dir 1;
854
855
856
	Unix.chdir user_dir;
	rm_dir lurette_tmp_dir
      )
857
858
859
860