lurette 0.79 Thu, 29 Aug 2002 16:55:47 +0200 by jahier

Parent-Version:      0.78
Version-Log:

source/lurettetop.ml:
   Add a pack command and a --restore option to lurettetop that respectively
   save temporarily created files during a session and restore them
   later on.

   Also clean-up temporarily created files when lurettetop resumes.

Project-Description: Lurette

lurette.prj

 ;; -*- Prcs -*-
 (Created-By-Prcs-Version 1 3 3)
 (Project-Description "Lurette")
-(Project-Version lurette 0 78)
-(Parent-Version lurette 0 77)
+(Project-Version lurette 0 79)
+(Parent-Version lurette 0 78)
 (Version-Log "
-source/parse_env.ml:
-   Fix a bug where empty ctrl expr labels were causing
-   a parse error.
+source/lurettetop.ml:
+   Add a pack command and a --restore option to lurettetop that respectively
+   save temporarily created files during a session and restore them
+   later on.
 
-source/control.ml,mli:
-   Add those files to the project as should have been done for a while...
-
-   Do not handle infinite values for ctrl expr counters anymore as it is 
-   useless (and not so easy to be handled properly).
+   Also clean-up temporarily created files when lurettetop resumes.
 
 ")
 (New-Version-Log "")
-(Checkin-Time "Thu, 29 Aug 2002 15:19:15 +0200")
+(Checkin-Time "Thu, 29 Aug 2002 16:55:47 +0200")
 (Checkin-Login jahier)
 (Populate-Ignore ())
 (Project-Keywords)
@@ -82,7 +79,7 @@ source/control.ml,mli:
   (source/gne.mli (lurette/b/36_gne.mli 1.2 644))
   (source/gne.ml (lurette/b/37_gne.ml 1.2 644))
 
-  (source/lurettetop.ml (lurette/c/1_lurettetop 1.3 644))
+  (source/lurettetop.ml (lurette/c/1_lurettetop 1.4 644))
   (source/gen_stubs.ml (lurette/24_generate_l 1.30 644))
 
   (source/control.mli (lurette/c/3_control.ml 1.1 644))

source/lurettetop.ml

@@ -35,6 +35,7 @@ type flagT = {
   mutable output : string ;
   mutable make_opt : string ;
   mutable go : bool ref ;
+  mutable restore : string option;
 (* a flag to know whether lurette_exe needs to be (re-)build *)
   mutable to_build : bool ref
 }
@@ -55,6 +56,7 @@ let (flag : flagT) = {
   verbose = ref false ;
   output = "lurette.rif" ;
   go = ref false ;
+  restore = None ;
   to_build = ref true
 }
 
@@ -101,6 +103,10 @@ let rec speclist =
     "\t\t\tStart the testing process directly without prompting.";
     "-go", Arg.Set flag.go, "\n";
 
+    "--restore", Arg.String (fun s -> flag.restore <- Some s), 
+       "<string>\tFile name (without extension) of the package containing"
+       ^ "\t\tthe temporarily files to be restored (cf the pack command).\n";
+
     "--step", Arg.Set flag.step_by_step, "\t\tRun lurette step by step." ;
     "-s", Arg.Set flag.step_by_step, "\n";
 
@@ -171,7 +177,8 @@ let (build : string -> string -> string -> bool) =
 	  )
 
 
-let (run : string -> bool) =
+(* run lurette and returns the exit status *)
+let (run : string -> int) =
   fun lurette_tmp_dir ->
     let seed_str = 
       match flag.seed with 
@@ -198,7 +205,7 @@ let (run : string -> bool) =
       ) 
     in
       print_string (run_cmd ^ "\n");
-      (Sys.command run_cmd) = 0
+      Sys.command run_cmd
 	
 	
 
@@ -223,6 +230,7 @@ type cmd =
   | Quit
   | Help
   | Man
+  | Pack of string
   | Show
   | HelpSimple
   | Error of string
@@ -273,6 +281,8 @@ let rec
 
       | [< 'Genlex.Ident "man"  >] -> Man
 
+      | [< 'Genlex.Ident "pack"  ; 'Genlex.Ident file >] -> Pack(file)
+
       | [< 'Genlex.Ident "help"  >] -> Help
       | [< 'Genlex.Ident "h"  >] -> Help
       | [< 'Genlex.Ident "?"  >] -> Help
@@ -341,6 +351,11 @@ man
 clean
      run a make clean (you can try it if <<run>> failed)
 
+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.
 
 show
     show of post-script version of the current environment
@@ -473,8 +488,8 @@ let rec (main_loop : string -> string -> string -> unit) =
 			 (
 			   flag.to_build := false; 
 			   Unix.chdir user_dir;
-			   let result =  run lurette_tmp_dir in
-			     if not result  
+			   let result = run lurette_tmp_dir in
+			     if result <> 0  
 			     then output_string stderr "Can not run lurette.\n"
 			 )
 			 else 
@@ -487,6 +502,14 @@ let rec (main_loop : string -> string -> string -> unit) =
 		   | HelpSimple -> print_string cmd_usage; true
 		   | Help -> display_cmd (); true
 		   | Man -> print_string man ; true
+		   | Pack(file) -> 
+		       (* XXX autoconf: gnu tar ougth to be installed ! *)
+		       let cmd = ("mv " ^ lurette_tmp_dir ^ " /tmp/" ^ file ^  
+				  "; cd " ^ user_dir ^ "; tar cvfz " ^ 
+				  file ^ ".tgz /tmp/" ^ file ^ "; mv /tmp/" ^ 
+				  file ^ " " ^ lurette_tmp_dir ) 
+		       in
+		       let _ = print_string (cmd ^ "\n") ; Sys.command cmd in true
 		   | Error(errmsg) -> 
 		       print_string errmsg; 
 		       print_string cmd_usage;
@@ -519,15 +542,27 @@ let (get_fresh_dir : unit -> string) =
       get_fresh_dir_rec 1 
 
    
+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")
+
+
+
 let _ =
   let user_dir = (Unix.getcwd ()) ^ "/"  in 
-  let lurette_tmp_dir = get_fresh_dir () in
   let lurette_dir = 
     try Sys.getenv "LURETTE_PATH"
     with _ -> 
       print_string "Environment var LURETTE_PATH is unset.\n";
       exit 2
   in
+  let _ = 
     try
       Arg.parse speclist 
 	  (fun s -> 
@@ -535,23 +570,7 @@ let _ =
 	     then flag.env <- (flag.env ^ " x ")
 	     else flag.env <- (flag.env ^ s ^ ".ima ")
 	  ) 
-	  usage;
-      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 
-	      then exit 0 
-	      else print_string "Can not run lurette_exe\n"
-	    )
-	  else  print_string "Can not build lurette_exe\n"
-	)
-      else main_loop user_dir lurette_tmp_dir lurette_dir;
-      Unix.chdir user_dir
+	  usage
     with 
 	Failure(e) ->
 	  print_string e;
@@ -559,7 +578,50 @@ let _ =
 	  flush stderr ;
 	  exit 2
       | _ ->
-	  exit 2
+	    exit 2
+  in
+  let lurette_tmp_dir = 
+    match flag.restore with
+	None -> get_fresh_dir ()
+      | Some file ->
+	  (* XXX autoconf: gnu tar ougth to be installed ! *)
+	  let cmd = ("cd /; tar xvfz " ^ user_dir ^ file ^ ".tgz") in 
+	  let _ = print_string (cmd ^ "\n"); Sys.command cmd in
+	    ("/tmp/" ^ file)
+  in
+    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 
+	      (
+		print_string "Can not run lurette_exe\n";
+		exit 1
+	      );
+	    rm_dir lurette_tmp_dir;
+	  )
+	else  
+	  (
+	    print_string "Can not build lurette_exe\n";
+	    rm_dir lurette_tmp_dir;
+	    exit 1
+	  )
+      )
+    else 
+      (* flag.go *)
+      (
+	main_loop user_dir lurette_tmp_dir lurette_dir;
+	Unix.chdir user_dir;
+	rm_dir lurette_tmp_dir
+      )