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 published_goals = ref []
 132 let publish name fn = published_goals := (name, fn) :: !published_goals
 133 let get_goal name =
 134   try Some (List.assoc name !published_goals) with Not_found -> None
 135
 136 let goal_file_exists filename =
 137   if not (file_exists filename) then (
 138     let msg = sprintf "file '%s' required but not found" filename in
 139     goal_failed msg
 140   )
 141 let goal_file_newer_than f1 f2 =
 142   if not (file_newer_than f1 f2) then (
 143     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
 144     goal_failed msg
 145   )
 146 let goal_more_recent objs srcs =
 147   if not (more_recent objs srcs) then (
 148     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
 149       (String.concat " " objs) (String.concat " " srcs) in
 150     goal_failed msg
 151   )
 152 let goal_url_exists url =
 153   if not (url_exists url) then (
 154     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
 155     goal_failed msg
 156   )
 157 let goal_memory_exists k =
 158   if not (memory_exists k) then (
 159     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
 160     goal_failed msg
 161   )
 162
 163 (* Run the program. *)
 164 let init () =
 165   let prog = Sys.executable_name in
 166   let prog = Filename.basename prog in
 167
 168   let args = ref [] in
 169
 170   let display_version () =
 171     printf "%s %s\n" Config.package_name Config.package_version;
 172     exit 0
 173   in
 174
 175   let list_goals () =
 176     let names = !published_goals in
 177     let names = List.map fst names in
 178     let names = List.sort compare names in
 179     List.iter print_endline names
 180   in
 181
 182   let argspec = Arg.align [
 183     "--goals", Arg.Unit list_goals, " List all goals";
 184     "-l", Arg.Unit list_goals, " List all goals";
 185     "-V", Arg.Unit display_version, " Display version number and exit";
 186     "--version", Arg.Unit display_version, " Display version number and exit";
 187   ] in
 188   let anon_fun str = args := str :: !args in
 189   let usage_msg = sprintf "\
 190 %s: a script generated by goaljobs
 191
 192 List all goals:                %s -l
 193 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
 194
 195 For more information see the goaljobs(1) man page.
 196
 197 Options:
 198 " prog prog prog in
 199
 200   Arg.parse argspec anon_fun usage_msg;
 201
 202   let args = List.rev !args in
 203
 204   (* Was a goal named on the command line? *)
 205   match args with
 206   | name :: args ->
 207     (match get_goal name with
 208     | Some fn -> fn args
 209     | None ->
 210       eprintf "error: no goal called '%s' was found.\n" name;
 211       eprintf "Use %s -l to list all published goals in this script.\n" name;
 212       exit 1
 213     )
 214   | [] ->
 215     (* Does a published 'all' goal exist? *)
 216     match get_goal "all" with
 217     | Some fn -> fn []
 218     | None ->
 219       (* No published 'all' goal.  This is only a warning, because
 220        * other top-level code may exist in the script.
 221        *)
 222       eprintf "warning: no 'all' goal found.\n"