X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=tools%2Fwhenjobs.ml;h=440d4251bc1fd290308a685829531f0e0f91125e;hb=080d38e64fe2aaec17e3ff853682188196b429f9;hp=cfef9d6471123975ee0759f511a6f37dc3cebc35;hpb=1d8348d52e7d5b7f23c9c86841879afdf2aa5458;p=whenjobs.git

diff --git a/tools/whenjobs.ml b/tools/whenjobs.ml
index cfef9d6..440d425 100644
--- a/tools/whenjobs.ml
+++ b/tools/whenjobs.ml
@@ -102,6 +102,7 @@ let rec main () =
     "-e", Arg.Unit (set_mode `Edit), " Edit and upload the script";
     "--edit", Arg.Unit (set_mode `Edit), " Edit and upload the script";
     "--get", Arg.Unit (set_mode `Get), "var Display the variable";
+    "--job-names", Arg.Unit (set_mode `JobNames), " List names of loaded jobs";
     "--jobs", Arg.Unit (set_mode `Jobs), " List running jobs";
     "-l", Arg.Unit (set_mode `List), " List the script";
     "--list", Arg.Unit (set_mode `List), " List the script";
@@ -109,17 +110,20 @@ let rec main () =
     "--set", Arg.Unit (set_mode `Set), " Set the variable";
     "--start", Arg.Unit (set_mode `Start), "name Start a job manually";
     "--tail", Arg.Unit (set_mode `Tail), "serial Tail job output";
+    "--test", Arg.Unit (set_mode `Test), " Test the effect of setting variables";
     "--type", Arg.String set_type, "bool|int|float|string|.. Set the variable type";
     "--upload", Arg.Unit (set_mode `Upload), " Upload the script";
     "--variables", Arg.Unit (set_mode `Variables), " Display all variables and values";
     "-V", Arg.Unit display_version, " Display version number and exit";
     "--version", Arg.Unit display_version, " Display version number and exit";
+    "--whisper", Arg.Unit (set_mode `Whisper), " Set the variable, quietly";
   ] in
 
   (* anon_fun normally just collects up the anonymous arguments as
    * strings, and most modes just use 'args' as a list of strings.
-   * However for `Set mode we need to record the type of each argument
-   * as well, so we keep that in a separate list (argtypes).
+   * However for `Set, `Test and `Whisper modes we need to record the
+   * type of each argument as well, so we keep that in a separate list
+   * (argtypes).
    *)
   let argtypes = ref [] in
   let anon_fun str = argtypes := (str, !typ) :: !argtypes in
@@ -188,6 +192,14 @@ Options:
     if nr_args > 0 then
       set_variables argtypes
 
+  | Some `Test ->
+    if nr_args > 0 then
+      test_variables argtypes
+
+  | Some `Whisper ->
+    if nr_args > 0 then
+      whisper_variables argtypes
+
   | Some `Get ->
     if nr_args != 1 then (
       eprintf "whenjobs --get variable\n";
@@ -245,6 +257,10 @@ Options:
     );
     tail arg1
 
+  | Some `JobNames ->
+    unused_error args "--job-names";
+    job_names ()
+
 and edit_file () =
   (* If there is no initial file, create an empty one containing the
    * tutorial.
@@ -291,26 +307,76 @@ and list_file () =
   close_in chan
 
 and upload_file () =
-  (* Recompile the jobs file. *)
-  let file = get_jobs_filename () in
-  let cmo_file = sprintf "%s/jobs.cmo" jobsdir in
-  let cmd = sprintf "ocamlfind ocamlc -I +camlp4 -I %s -package unix,camlp4.lib -pp 'camlp4o %s/pa_when.cmo' -c %s -o %s"
-    !libdir !libdir file cmo_file in
+  let suffix = if not Config.have_ocamlopt then "cmo" else "cmx" in
+
+  (* Recompile the jobs file(s). *)
+  let files = get_multijobs_filenames () in
+
+  (* Choose a random name for the output file.  time_t is convenient.
+   * See: https://sympa-roc.inria.fr/wws/arc/caml-list/2012-03/msg00276.html?checked_cas=2
+   *)
+  let t = Int64.of_float (time ()) in
+
+  (* Compilation step. *)
+  List.iter (
+    fun file ->
+      let cmd =
+        if not Config.have_ocamlopt then
+          (* bytecode *)
+          sprintf "%s c -for-pack Jobs__%Ld -I +camlp4 -I %s -package unix,camlp4.lib -pp 'camlp4o %s/pa_when.cmo' -c %s"
+            Config.ocamlfind t !libdir !libdir file
+        else
+          (* native code *)
+          sprintf "%s opt -for-pack Jobs__%Ld -I +camlp4 -I %s -package unix,camlp4.lib -pp 'camlp4o %s/pa_when.cmo' -c %s"
+            Config.ocamlfind t !libdir !libdir file in
+      if Sys.command cmd <> 0 then (
+        eprintf "whenjobs: %s: could not compile jobs script, see earlier errors\n"
+          file;
+        eprintf "compile command was:\n%s\n" cmd;
+        exit 1
+      )
+  ) files;
+
+  (* Pack into a single file. *)
+  let filename = sprintf "%s/jobs__%Ld.%s" jobsdir t suffix in
+  let cmd =
+    let objects = List.map (
+      fun file ->
+        let base = Filename.chop_extension file in
+        base ^ if not Config.have_ocamlopt then ".cmo" else ".cmx"
+    ) files in
+    sprintf "%s %s -pack -o %s %s"
+      Config.ocamlfind
+      (if not Config.have_ocamlopt then "c" else "opt")
+      filename (String.concat " " objects) in
   if Sys.command cmd <> 0 then (
-    eprintf "whenjobs: could not compile jobs script, see earlier error messages\n";
+    eprintf "whenjobs: could not pack jobs script, see earlier errors\n";
     eprintf "compile command was:\n%s\n" cmd;
     exit 1
   );
 
-  (* Test-load the jobs file to ensure it makes sense. *)
+  (* For native code only, write a *.cmxs file. *)
+  let filename =
+    if Config.have_ocamlopt then (
+      let cmd = sprintf "%s opt -shared -linkall %s -o %ss"
+        Config.ocamlfind filename filename in
+      if Sys.command cmd <> 0 then (
+        eprintf "whenjobs: could not convert to *.cmxs, see earlier errors\n";
+        eprintf "compile command was:\n%s\n" cmd;
+        exit 1
+      );
+      filename ^ "s" (* .cmx -> .cmxs *)
+    )
+    else filename in
+
+  (* Test-load the jobs files to ensure they make sense. *)
   Whenfile.init Whenstate.empty;
-  (try
-     Dynlink.loadfile cmo_file
+  (try Dynlink.loadfile filename
    with
      Dynlink.Error err ->
-       eprintf "whenjobs: %s\n" (Dynlink.error_message err);
-       (* Since it failed, unlink it. *)
-       (try unlink cmo_file with Unix_error _ -> ());
+       eprintf "whenjobs: dynlink: %s\n" (Dynlink.error_message err);
+       (* Since it failed, unlink the compiled file. *)
+       (try unlink filename with Unix_error _ -> ());
        exit 1
   );
 
@@ -354,6 +420,60 @@ and set_variables argtypes =
   );
   stop_client client
 
+and test_variables argtypes =
+  let vars = List.map (
+    fun (def, typ) ->
+      (* 'def' should have the form "name=value".  The value part may
+       * be missing, but the equals sign is required.
+       *)
+      let i =
+        try String.index def '='
+        with Not_found ->
+          eprintf "whenjobs: test: missing = sign in variable definition\n";
+          suggest_help ();
+          exit 1 in
+      let name = String.sub def 0 i in
+      let value = String.sub def (i+1) (String.length def - (i+1)) in
+      let value = value_of_string value typ in
+      { Whenproto_aux.sv_name = name; sv_value = value }
+  ) argtypes in
+  let vars = Array.of_list vars in
+
+  let client = start_client () in
+  let jobnames = Whenproto_clnt.When.V1.test_variables client vars in
+  stop_client client;
+
+  Array.iter print_endline jobnames
+
+and whisper_variables argtypes =
+  let vars = List.map (
+    fun (def, typ) ->
+      (* 'def' should have the form "name=value".  The value part may
+       * be missing, but the equals sign is required.
+       *)
+      let i =
+        try String.index def '='
+        with Not_found ->
+          eprintf "whenjobs: whisper: missing = sign in variable definition\n";
+          suggest_help ();
+          exit 1 in
+      let name = String.sub def 0 i in
+      let value = String.sub def (i+1) (String.length def - (i+1)) in
+      let value = value_of_string value typ in
+      { Whenproto_aux.sv_name = name; sv_value = value }
+  ) argtypes in
+  let vars = Array.of_list vars in
+
+  let client = start_client () in
+  (match Whenproto_clnt.When.V1.whisper_variables client vars with
+  | `ok -> ()
+  | `error msg ->
+    eprintf "whenjobs: whisper: %s\n" msg;
+    suggest_check_server_logs ();
+    exit 1
+  );
+  stop_client client
+
 and get_variable name =
   let client = start_client () in
   let value = Whenproto_clnt.When.V1.get_variable client name in
@@ -371,7 +491,7 @@ and list_variables () =
   stop_client client
 
 and daemon_start () =
-  assert false
+  exit (Sys.command "whenjobsd")
 
 and daemon_stop () =
   let client = start_client () in
@@ -385,10 +505,25 @@ and daemon_stop () =
   stop_client client
 
 and daemon_restart () =
-  assert false
+  (try
+     let client = start_client_no_exit () in
+     ignore (Whenproto_clnt.When.V1.exit_daemon client ());
+     stop_client client
+   with _ -> ()
+  );
+  sleep 1;
+  daemon_start ()
 
 and daemon_status () =
-  assert false
+  let r =
+    try
+      let client = start_client_no_exit () in
+      let r = Whenproto_clnt.When.V1.ping_daemon client () in
+      stop_client client;
+      r = `ok
+    with
+      exn -> false in
+  print_endline (if r then "up" else "down")
 
 and jobs () =
   let client = start_client () in
@@ -447,6 +582,12 @@ and tail serial =
       (Filename.quote job.Whenproto_aux.job_tmpdir) in
   exit (Sys.command cmd)
 
+and job_names () =
+  let client = start_client () in
+  let names = Whenproto_clnt.When.V1.get_job_names client () in
+  stop_client client;
+  Array.iter print_endline names
+
 and unused_error args op =
   if args <> [] then (
     eprintf "whenjobs %s: unused parameters on the command line.\n" op;
@@ -464,6 +605,13 @@ and suggest_check_server_logs () =
 and get_jobs_filename () =
   sprintf "%s/jobs.ml" jobsdir
 
+and get_multijobs_filenames () =
+  (* Get dir/*.ml *)
+  let files = Array.to_list (Sys.readdir jobsdir) in
+  let files = List.filter (fun file -> string_endswith file ".ml") files in
+  let files = List.map (fun file -> jobsdir // file) files in
+  List.sort compare files
+
 and create_tutorial file =
   let chan = open_out file in
   output_string chan Tutorial.tutorial;
@@ -472,10 +620,7 @@ and create_tutorial file =
 and start_client () =
   let addr = sprintf "%s/socket" jobsdir in
   let client =
-    try
-      Whenproto_clnt.When.V1.create_client
-        (Rpc_client.Unix addr)
-        Rpc.Tcp (* not TCP, this is the same as SOCK_STREAM *)
+    try start_client_no_exit ()
     with
     | Unix_error ((ECONNREFUSED|ENOENT), _, _) ->
       eprintf "whenjobs: error: the daemon ('whenjobsd') is not running\n";
@@ -486,6 +631,12 @@ and start_client () =
       exit 1 in
   client
 
+and start_client_no_exit () =
+  let addr = sprintf "%s/socket" jobsdir in
+  Whenproto_clnt.When.V1.create_client
+    (Rpc_client.Unix addr)
+    Rpc.Tcp (* not TCP, this is the same as SOCK_STREAM *)
+
 and stop_client client =
   Rpc_client.shut_down client