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 open Goaljobs_config
  23
  24 type goal_result_t = Goal_OK | Goal_failed of string
  25 exception Goal_result of goal_result_t
  26
  27 let goal_failed msg = raise (Goal_result (Goal_failed msg))
  28
  29 let target v =
  30   if v then raise (Goal_result Goal_OK)
  31 let target_all vs = target (List.fold_left (&&) true vs)
  32 let target_exists vs = target (List.fold_left (||) false vs)
  33 let require () = ()
  34
  35 let file_exists = Sys.file_exists
  36
  37 let file_newer_than f1 f2 =
  38   let stat f =
  39     try Some (stat f)
  40     with
  41     | Unix_error (ENOENT, _, _) -> None
  42     | Unix_error (err, _, _) ->
  43       let msg = sprintf "file_newer_than: %s: %s" f (error_message err) in
  44       goal_failed msg
  45   in
  46   let s1 = stat f1 and s2 = stat f2 in
  47   match s1 with
  48   | None -> false
  49   | Some s1 ->
  50     match s2 with
  51     | None ->
  52       let msg = sprintf "file_newer_than: %s: file does not exist" f2 in
  53       goal_failed msg
  54     | Some s2 ->
  55       s1.st_mtime >= s2.st_mtime
  56
  57 let more_recent objs srcs =
  58   if not (List.for_all file_exists objs) then false
  59   else (
  60     List.for_all (
  61       fun obj -> List.for_all (file_newer_than obj) srcs
  62     ) objs
  63   )
  64
  65 let url_exists url = goal_failed "url_exists not implemented!"
  66
  67 let sh fs =
  68   let do_sh cmd =
  69     let cmd = "set -e\nset -x\n\n" ^ cmd in
  70     let r = Sys.command cmd in
  71     if r <> 0 then (
  72       let msg = sprintf "external command failed with code %d" r in
  73       goal_failed msg
  74     )
  75   in
  76   ksprintf do_sh fs
  77
  78 let do_shlines cmd =
  79   let cmd = "set -e\nset -x\n\n" ^ cmd in
  80   let chan = open_process_in cmd in
  81   let lines = ref [] in
  82   let rec loop () =
  83     let line = input_line chan in
  84     lines := line :: !lines;
  85     loop ()
  86   in
  87   (try loop () with End_of_file -> ());
  88   let r = close_process_in chan in
  89   match r with
  90   | WEXITED 0 -> List.rev !lines
  91   | WEXITED i ->
  92     let msg = sprintf "external command failed with code %d" i in
  93     goal_failed msg
  94   | WSIGNALED i ->
  95     let msg = sprintf "external command was killed by signal %d" i in
  96     goal_failed msg
  97   | WSTOPPED i ->
  98     let msg = sprintf "external command was stopped by signal %d" i in
  99     goal_failed msg
 100 let shlines fs = ksprintf do_shlines fs
 101
 102 let do_shout cmd =
 103   let lines = do_shlines cmd in
 104   String.concat "\n" lines
 105 let shout fs = ksprintf do_shout fs
 106
 107 (*
 108 val shell : string ref
 109 *)
 110
 111 (*
 112 val replace_substring : string -> string -> string -> string
 113 *)
 114
 115 let change_file_extension ext filename =
 116   let i =
 117     try String.rindex filename '.'
 118     with Not_found -> String.length filename in
 119   String.sub filename 0 i ^ "." ^ ext
 120
 121 (*
 122 val filter_file_extension : string -> string list -> string
 123 *)
 124
 125 (* XXX The Memory is not actually persistent yet. *)
 126 let memory = Hashtbl.create 13
 127
 128 let memory_exists = Hashtbl.mem memory
 129 let memory_set = Hashtbl.replace memory
 130 let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
 131 let memory_delete = Hashtbl.remove memory
 132
 133 let published_goals = ref []
 134 let publish name fn = published_goals := (name, fn) :: !published_goals
 135 let get_goal name =
 136   try Some (List.assoc name !published_goals) with Not_found -> None
 137
 138 let goal_file_exists filename =
 139   if not (file_exists filename) then (
 140     let msg = sprintf "file '%s' required but not found" filename in
 141     goal_failed msg
 142   )
 143 let goal_file_newer_than f1 f2 =
 144   if not (file_newer_than f1 f2) then (
 145     let msg = sprintf "file %s is required to be newer than %s" f1 f2 in
 146     goal_failed msg
 147   )
 148 let goal_more_recent objs srcs =
 149   if not (more_recent objs srcs) then (
 150     let msg = sprintf "object(s) %s are required to be newer than source(s) %s"
 151       (String.concat " " objs) (String.concat " " srcs) in
 152     goal_failed msg
 153   )
 154 let goal_url_exists url =
 155   if not (url_exists url) then (
 156     let msg = sprintf "url_exists: URL '%s' required but does not exist" url in
 157     goal_failed msg
 158   )
 159 let goal_memory_exists k =
 160   if not (memory_exists k) then (
 161     let msg = sprintf "memory_exists: key '%s' required but does not exist" k in
 162     goal_failed msg
 163   )
 164
 165 (* Run the program. *)
 166 let init () =
 167   let prog = Sys.executable_name in
 168   let prog = Filename.basename prog in
 169
 170   let args = ref [] in
 171
 172   let display_version () =
 173     printf "%s %s\n" package_name package_version;
 174     exit 0
 175   in
 176
 177   let list_goals () =
 178     let names = !published_goals in
 179     let names = List.map fst names in
 180     let names = List.sort compare names in
 181     List.iter print_endline names
 182   in
 183
 184   let argspec = Arg.align [
 185     "--goals", Arg.Unit list_goals, " List all goals";
 186     "-l", Arg.Unit list_goals, " List all goals";
 187     "-V", Arg.Unit display_version, " Display version number and exit";
 188     "--version", Arg.Unit display_version, " Display version number and exit";
 189   ] in
 190   let anon_fun str = args := str :: !args in
 191   let usage_msg = sprintf "\
 192 %s: a script generated by goaljobs
 193
 194 List all goals:                %s -l
 195 Run a single goal like this:   %s <name-of-goal> [<goal-args ...>]
 196
 197 For more information see the goaljobs(1) man page.
 198
 199 Options:
 200 " prog prog prog in
 201
 202   Arg.parse argspec anon_fun usage_msg;
 203
 204   let args = List.rev !args in
 205
 206   (* Was a goal named on the command line? *)
 207   match args with
 208   | name :: args ->
 209     (match get_goal name with
 210     | Some fn -> fn args
 211     | None ->
 212       eprintf "error: no goal called '%s' was found.\n" name;
 213       eprintf "Use %s -l to list all published goals in this script.\n" name;
 214       exit 1
 215     )
 216   | [] ->
 217     (* Does a published 'all' goal exist? *)
 218     match get_goal "all" with
 219     | Some fn -> fn []
 220     | None ->
 221       (* No published 'all' goal.  This is only a warning, because
 222        * other top-level code may exist in the script.
 223        *)
 224       eprintf "warning: no 'all' goal found.\n"