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 require = function
  30   | Goal_OK -> ()
  31   | r -> raise (Goal_result r)
  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 -> ()
  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 url_exists url = goal_failed "url_exists not implemented!"
  56
  57 let sh fs =
  58   let do_sh cmd =
  59     print_endline cmd;
  60     let cmd = "set -e\n\n" ^ cmd in
  61     let r = System.command cmd in
  62     if r <> 0 then (
  63       let msg = sprintf "sh: external command failed with code %d" r in
  64       goal_failed msg
  65     )
  66   in
  67   ksprintf do_sh fs
  68
  69 (*
  70 val shout : ('a, unit, string) format -> 'a
  71 val shlines : ('a, unit, string) format -> 'a
  72
  73 val shell : string ref
  74 *)
  75
  76 (*
  77 val replace_substring : string -> string -> string -> string
  78 val change_file_extension : string -> string -> string
  79 val filter_file_extension : string -> string list -> string
  80 *)
  81
  82 let goal_file_exists filename =
  83   if not (file_exists filename) then (
  84     let msg = sprintf "file_exists: %s: file not found" filename in
  85     goal_failed msg
  86   )
  87 let goal_file_newer_than f1 f2 =
  88   if not (file_newer_than f1 f2) then (
  89     let msg = sprintf "file %s is not newer than %s" f1 f2 in
  90     goal_failed msg
  91   )
  92 let goal_url_exists url =
  93   if not (url_exists url) then (
  94     let msg = sprintf "url_exists: %s: URL does not exist" url in
  95     goal_failed msg
  96   )