2 * Copyright (C) 2013 Red Hat Inc.
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.
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.
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.
22 type goal_result_t = Goal_OK | Goal_failed of string
23 exception Goal_result of goal_result_t
25 let goal_failed msg = raise (Goal_result (Goal_failed msg))
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)
33 let file_exists = Sys.file_exists
35 let file_newer_than f1 f2 =
39 | Unix_error (ENOENT, _, _) -> None
40 | Unix_error (err, _, _) ->
41 let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
44 let s1 = stat f1 and s2 = stat f2 in
50 let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
53 s1.st_mtime >= s2.st_mtime
55 let more_recent objs srcs =
56 if not (List.for_all file_exists objs) then false
59 fun obj -> List.for_all (file_newer_than obj) srcs
63 let url_exists url = goal_failed "url_exists not implemented!"
67 let cmd = "set -e\nset -x\n\n" ^ cmd in
68 let r = Sys.command cmd in
70 let msg = sprintf "external command failed with code %d" r in
77 let cmd = "set -e\nset -x\n\n" ^ cmd in
78 let chan = open_process_in cmd in
81 let line = input_line chan in
82 lines := line :: !lines;
85 (try loop () with End_of_file -> ());
86 let r = close_process_in chan in
88 | WEXITED 0 -> List.rev !lines
90 let msg = sprintf "external command failed with code %d" i in
93 let msg = sprintf "external command was killed by signal %d" i in
96 let msg = sprintf "external command was stopped by signal %d" i in
98 let shlines fs = ksprintf do_shlines fs
101 let lines = do_shlines cmd in
102 String.concat "\n" lines
103 let shout fs = ksprintf do_shout fs
106 val shell : string ref
110 val replace_substring : string -> string -> string -> string
113 let change_file_extension ext filename =
115 try String.rindex filename '.'
116 with Not_found -> String.length filename in
117 String.sub filename 0 i ^ "." ^ ext
120 val filter_file_extension : string -> string list -> string
123 (* XXX The Memory is not actually persistent yet. *)
124 let memory = Hashtbl.create 13
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
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
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
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
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
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