First published version.

[goaljobs.git] / goaljobs.ml

diff --git a/goaljobs.ml b/goaljobs.ml
index 45422d2..282c29e 100644 (file)
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -26,9 +26,9 @@ let goal_failed msg = raise (Goal_result (Goal_failed msg))
 
 let target v =
   if v then raise (Goal_result Goal_OK)
-let require = function
-  | Goal_OK -> ()
-  | r -> raise (Goal_result r)
+let target_all vs = target (List.fold_left (&&) true vs)
+let target_exists vs = target (List.fold_left (||) false vs)
+let require () = ()
 
 let file_exists = Sys.file_exists
 
@@ -43,7 +43,7 @@ let file_newer_than f1 f2 =
   in
   let s1 = stat f1 and s2 = stat f2 in
   match s1 with
-  | None -> ()
+  | None -> false
   | Some s1 ->
     match s2 with
     | None ->
@@ -52,45 +52,105 @@ let file_newer_than f1 f2 =
     | Some s2 ->
       s1.st_mtime >= s2.st_mtime
 
+let more_recent objs srcs =
+  if not (List.for_all file_exists objs) then false
+  else (
+    List.for_all (
+      fun obj -> List.for_all (file_newer_than obj) srcs
+    ) objs
+  )
+
 let url_exists url = goal_failed "url_exists not implemented!"
 
 let sh fs =
   let do_sh cmd =
-    print_endline cmd;
-    let cmd = "set -e\n\n" ^ cmd in
-    let r = System.command cmd in
+    let cmd = "set -e\nset -x\n\n" ^ cmd in
+    let r = Sys.command cmd in
     if r <> 0 then (
-      let msg = sprintf "sh: external command failed with code %d" r in
+      let msg = sprintf "external command failed with code %d" r in
       goal_failed msg
     )
   in
   ksprintf do_sh fs
 
-(*
-val shout : ('a, unit, string) format -> 'a
-val shlines : ('a, unit, string) format -> 'a
+let do_shlines cmd =
+  let cmd = "set -e\nset -x\n\n" ^ cmd in
+  let chan = open_process_in cmd in
+  let lines = ref [] in
+  let rec loop () =
+    let line = input_line chan in
+    lines := line :: !lines;
+    loop ()
+  in
+  (try loop () with End_of_file -> ());
+  let r = close_process_in chan in
+  match r with
+  | WEXITED 0 -> List.rev !lines
+  | WEXITED i ->
+    let msg = sprintf "external command failed with code %d" i in
+    goal_failed msg
+  | WSIGNALED i ->
+    let msg = sprintf "external command was killed by signal %d" i in
+    goal_failed msg
+  | WSTOPPED i ->
+    let msg = sprintf "external command was stopped by signal %d" i in
+    goal_failed msg
+let shlines fs = ksprintf do_shlines fs
+
+let do_shout cmd =
+  let lines = do_shlines cmd in
+  String.concat "\n" lines
+let shout fs = ksprintf do_shout fs
 
+(*
 val shell : string ref
 *)
 
 (*
 val replace_substring : string -> string -> string -> string
-val change_file_extension : string -> string -> string
+*)
+
+let change_file_extension ext filename =
+  let i =
+    try String.rindex filename '.'
+    with Not_found -> String.length filename in
+  String.sub filename 0 i ^ "." ^ ext
+
+(*
 val filter_file_extension : string -> string list -> string
 *)
 
+(* XXX The Memory is not actually persistent yet. *)
+let memory = Hashtbl.create 13
+
+let memory_exists = Hashtbl.mem memory
+let memory_set = Hashtbl.replace memory
+let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
+let memory_delete = Hashtbl.remove memory
+
 let goal_file_exists filename =
   if not (file_exists filename) then (
-    let msg = sprintf "file_exists: %s: file not found" filename in
+    let msg = sprintf "file '%s' required but not found" filename in
     goal_failed msg
   )
 let goal_file_newer_than f1 f2 =
   if not (file_newer_than f1 f2) then (
-    let msg = sprintf "file %s is not newer than %s" f1 f2 in
+    let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
+    goal_failed msg
+  )
+let goal_more_recent objs srcs =
+  if not (more_recent objs srcs) then (
+    let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
+      (String.concat " " objs) (String.concat " " srcs) in
     goal_failed msg
   )
 let goal_url_exists url =
   if not (url_exists url) then (
-    let msg = sprintf "url_exists: %s: URL does not exist" url in
+    let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
+    goal_failed msg
+  )
+let goal_memory_exists k =
+  if not (memory_exists k) then (
+    let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
     goal_failed msg
   )