First published version.
[goaljobs.git] / goaljobs.ml
1 (* goaljobs
2  * Copyright (C) 2013 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License along
15  * with this program; if not, write to the Free Software Foundation, Inc.,
16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17  *)
18
19 open Unix
20 open Printf
21
22 type goal_result_t = Goal_OK | Goal_failed of string
23 exception Goal_result of goal_result_t
24
25 let goal_failed msg = raise (Goal_result (Goal_failed msg))
26
27 let target v =
28   if v then raise (Goal_result Goal_OK)
29 let target_all vs = target (List.fold_left (&&) true vs)
30 let target_exists vs = target (List.fold_left (||) false vs)
31 let require () = ()
32
33 let file_exists = Sys.file_exists
34
35 let file_newer_than f1 f2 =
36   let stat f =
37     try Some (stat f)
38     with
39     | Unix_error (ENOENT, _, _) -> None
40     | Unix_error (err, _, _) ->
41       let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
42       goal_failed msg
43   in
44   let s1 = stat f1 and s2 = stat f2 in
45   match s1 with
46   | None -> false
47   | Some s1 ->
48     match s2 with
49     | None ->
50       let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
51       goal_failed msg
52     | Some s2 ->
53       s1.st_mtime >= s2.st_mtime
54
55 let more_recent objs srcs =
56   if not (List.for_all file_exists objs) then false
57   else (
58     List.for_all (
59       fun obj -> List.for_all (file_newer_than obj) srcs
60     ) objs
61   )
62
63 let url_exists url = goal_failed "url_exists not implemented!"
64
65 let sh fs =
66   let do_sh cmd =
67     let cmd = "set -e\nset -x\n\n" ^ cmd in
68     let r = Sys.command cmd in
69     if r <> 0 then (
70       let msg = sprintf "external command failed with code %d" r in
71       goal_failed msg
72     )
73   in
74   ksprintf do_sh fs
75
76 let do_shlines cmd =
77   let cmd = "set -e\nset -x\n\n" ^ cmd in
78   let chan = open_process_in cmd in
79   let lines = ref [] in
80   let rec loop () =
81     let line = input_line chan in
82     lines := line :: !lines;
83     loop ()
84   in
85   (try loop () with End_of_file -> ());
86   let r = close_process_in chan in
87   match r with
88   | WEXITED 0 -> List.rev !lines
89   | WEXITED i ->
90     let msg = sprintf "external command failed with code %d" i in
91     goal_failed msg
92   | WSIGNALED i ->
93     let msg = sprintf "external command was killed by signal %d" i in
94     goal_failed msg
95   | WSTOPPED i ->
96     let msg = sprintf "external command was stopped by signal %d" i in
97     goal_failed msg
98 let shlines fs = ksprintf do_shlines fs
99
100 let do_shout cmd =
101   let lines = do_shlines cmd in
102   String.concat "\n" lines
103 let shout fs = ksprintf do_shout fs
104
105 (*
106 val shell : string ref
107 *)
108
109 (*
110 val replace_substring : string -> string -> string -> string
111 *)
112
113 let change_file_extension ext filename =
114   let i =
115     try String.rindex filename '.'
116     with Not_found -> String.length filename in
117   String.sub filename 0 i ^ "." ^ ext
118
119 (*
120 val filter_file_extension : string -> string list -> string
121 *)
122
123 (* XXX The Memory is not actually persistent yet. *)
124 let memory = Hashtbl.create 13
125
126 let memory_exists = Hashtbl.mem memory
127 let memory_set = Hashtbl.replace memory
128 let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
129 let memory_delete = Hashtbl.remove memory
130
131 let goal_file_exists filename =
132   if not (file_exists filename) then (
133     let msg = sprintf "file '%s' required but not found" filename in
134     goal_failed msg
135   )
136 let goal_file_newer_than f1 f2 =
137   if not (file_newer_than f1 f2) then (
138     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
139     goal_failed msg
140   )
141 let goal_more_recent objs srcs =
142   if not (more_recent objs srcs) then (
143     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
144       (String.concat " " objs) (String.concat " " srcs) in
145     goal_failed msg
146   )
147 let goal_url_exists url =
148   if not (url_exists url) then (
149     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
150     goal_failed msg
151   )
152 let goal_memory_exists k =
153   if not (memory_exists k) then (
154     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
155     goal_failed msg
156   )