lib/whenutils.ml

   1 (* whenjobs
   2  * Copyright (C) 2012 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 Camlp4.PreCast
  20 open Ast
  21
  22 open CalendarLib
  23
  24 open Big_int
  25 open Unix
  26 open Printf
  27
  28 module StringMap = struct
  29   include Map.Make (String)
  30   let keys m = fold (fun k _ ks -> k :: ks) m []
  31   let values m = fold (fun _ v vs -> v :: vs) m []
  32 end
  33
  34 module IntMap = struct
  35   include Map.Make (struct type t = int let compare = compare end)
  36   let keys m = fold (fun k _ ks -> k :: ks) m []
  37   let values m = fold (fun _ v vs -> v :: vs) m []
  38 end
  39
  40 module StringSet = Set.Make (String)
  41
  42 let (//) = Filename.concat
  43
  44 let isalpha = function 'a'..'z' | 'A'..'Z' -> true | _ -> false
  45 let isalnum = function 'a'..'z' | 'A'..'Z' | '0'..'9' -> true | _ -> false
  46
  47 let rec filter_map f = function
  48   | [] -> []
  49   | x :: xs ->
  50     match f x with
  51     | Some y -> y :: filter_map f xs
  52     | None -> filter_map f xs
  53
  54 type whenexpr =
  55   | Expr_unit
  56   | Expr_bool of bool
  57   | Expr_str of string
  58   | Expr_int of Big_int.big_int
  59   | Expr_float of float
  60   | Expr_var of string
  61   | Expr_and of whenexpr * whenexpr
  62   | Expr_or of whenexpr * whenexpr
  63   | Expr_lt of whenexpr * whenexpr
  64   | Expr_le of whenexpr * whenexpr
  65   | Expr_eq of whenexpr * whenexpr
  66   | Expr_ge of whenexpr * whenexpr
  67   | Expr_gt of whenexpr * whenexpr
  68   | Expr_not of whenexpr
  69   | Expr_add of whenexpr * whenexpr
  70   | Expr_sub of whenexpr * whenexpr
  71   | Expr_mul of whenexpr * whenexpr
  72   | Expr_div of whenexpr * whenexpr
  73   | Expr_mod of whenexpr * whenexpr
  74   | Expr_changes of string
  75   | Expr_increases of string
  76   | Expr_decreases of string
  77   | Expr_prev of string
  78   | Expr_reloaded
  79
  80 (* This internal type is used during conversion of the OCaml AST
  81  * to the whenexpr type.
  82  *)
  83 type whenexpr_int =
  84   | IExpr_unit
  85   | IExpr_bool of bool
  86   | IExpr_str of string
  87   | IExpr_int of Big_int.big_int
  88   | IExpr_float of float
  89   | IExpr_var of string
  90   | IExpr_app of string * whenexpr_int list
  91
  92 (* Note that days are not necessarily expressible in seconds (because
  93  * of leap seconds), months are not expressible in days (because months
  94  * have different lengths), and years are not expressible in days
  95  * (because of leap days) although we could save a case here by
  96  * expressing years in months.
  97  *)
  98 type periodexpr =
  99   | Every_seconds of int
 100   | Every_days of int
 101   | Every_months of int
 102   | Every_years of int
 103
 104 type shell_script = {
 105   sh_loc : Loc.t;
 106   sh_script : string;
 107 }
 108
 109 type variable =
 110   | T_unit
 111   | T_bool of bool
 112   | T_string of string
 113   | T_int of big_int
 114   | T_float of float
 115
 116 let variable_of_rpc = function
 117   | `unit_t -> T_unit
 118   | `bool_t b -> T_bool b
 119   | `string_t s -> T_string s
 120   | `int_t i -> T_int (big_int_of_string i)
 121   | `float_t f -> T_float f
 122
 123 let rpc_of_variable = function
 124   | T_unit -> `unit_t
 125   | T_bool b -> `bool_t b
 126   | T_string s -> `string_t s
 127   | T_int i -> `int_t (string_of_big_int i)
 128   | T_float f -> `float_t f
 129
 130 type variables = variable StringMap.t
 131
 132 type job_private = {
 133   (* The result of the previous evaluation.  This is used for
 134    * implementing edge-triggering, since we only trigger the job to run
 135    * when the state changes from false -> true.
 136    *)
 137   job_prev_eval_state : bool;
 138
 139   (* When the job {i ran} last time, we take a copy of the variables.
 140    * This allows us to implement the 'changes' operator.
 141    *)
 142   job_prev_variables : variables;
 143 }
 144
 145 let no_job_private =
 146   { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
 147
 148 type job_cond =
 149   | When_job of whenexpr
 150   | Every_job of periodexpr
 151
 152 type job = {
 153   job_loc : Loc.t;
 154   job_name : string;
 155   job_cond : job_cond;
 156   job_script : shell_script;
 157   job_private : job_private;
 158 }
 159
 160 let rec expr_of_ast _loc ast =
 161   expr_of_iexpr _loc (iexpr_of_ast _loc ast)
 162
 163 and iexpr_of_ast _loc = function
 164   | ExId (_, IdUid (_, "()")) -> IExpr_unit
 165   | ExId (_, IdUid (_, "True")) -> IExpr_bool true
 166   | ExId (_, IdUid (_, "False")) -> IExpr_bool false
 167   | ExStr (_, str) -> IExpr_str str
 168   | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
 169   | ExFlo (_, f) -> IExpr_float (float_of_string f)
 170   | ExId (_, IdLid (_, id)) -> IExpr_var id
 171
 172   (* In the OCaml AST, functions are curried right to left, so we
 173    * must uncurry to get the list of arguments.
 174    *)
 175   | ExApp (_, left_tree, right_arg) ->
 176     let f, left_args = uncurry_app_tree _loc left_tree in
 177     IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
 178
 179   | e ->
 180     (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
 181     eprintf "expr_of_ast: invalid expression: %!";
 182     let e = Ast.StExp (_loc, e) in
 183     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 184
 185     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 186
 187 and uncurry_app_tree _loc = function
 188   | ExId (_, IdLid (_, f)) -> f, []
 189   | ExApp (_, left_tree, right_arg) ->
 190     let f, left_args = uncurry_app_tree _loc left_tree in
 191     f, (right_arg :: left_args)
 192   | e ->
 193     eprintf "uncurry_app_tree: invalid expression: %!";
 194     let e = Ast.StExp (_loc, e) in
 195     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 196
 197     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 198
 199 and expr_of_iexpr _loc = function
 200   | IExpr_unit -> Expr_unit
 201   | IExpr_bool b -> Expr_bool b
 202   | IExpr_str s -> Expr_str s
 203   | IExpr_int i -> Expr_int i
 204   | IExpr_float f -> Expr_float f
 205   | IExpr_var v -> Expr_var v
 206
 207   | IExpr_app ("&&", exprs) ->
 208     two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
 209
 210   | IExpr_app ("||", exprs) ->
 211     two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
 212
 213   | IExpr_app ("<", exprs) ->
 214     two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
 215
 216   | IExpr_app ("<=", exprs) ->
 217     two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
 218
 219   | IExpr_app (("="|"=="), exprs) ->
 220     two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
 221
 222   | IExpr_app (">=", exprs) ->
 223     two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
 224
 225   | IExpr_app (">", exprs) ->
 226     two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
 227
 228   | IExpr_app ("!", exprs) ->
 229     one_param _loc "!" exprs (fun e1 -> Expr_not e1)
 230
 231   | IExpr_app ("+", exprs) ->
 232     two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
 233
 234   | IExpr_app ("-", exprs) ->
 235     two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
 236
 237   | IExpr_app ("*", exprs) ->
 238     two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
 239
 240   | IExpr_app ("/", exprs) ->
 241     two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
 242
 243   | IExpr_app ("mod", exprs) ->
 244     two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
 245
 246   | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
 247     Expr_changes v
 248
 249   | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
 250     Expr_increases v
 251
 252   | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
 253     Expr_decreases v
 254
 255   | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
 256     Expr_prev v
 257
 258   | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
 259     invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
 260                    (Loc.to_string _loc) op)
 261
 262   | IExpr_app ("reloaded", [IExpr_unit]) ->
 263     Expr_reloaded
 264
 265   | IExpr_app ("reloaded", _) ->
 266     invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
 267
 268   | IExpr_app (op, _) ->
 269     invalid_arg (sprintf "%s: unknown operator in expression: %s"
 270                    (Loc.to_string _loc) op)
 271
 272 and two_params _loc op exprs f =
 273   match exprs with
 274   | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
 275   | _ ->
 276     invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
 277                    op (Loc.to_string _loc))
 278
 279 and one_param _loc op exprs f =
 280   match exprs with
 281   | [e1] -> f (expr_of_iexpr _loc e1)
 282   | _ ->
 283     invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
 284                    op (Loc.to_string _loc))
 285
 286 let rec string_of_whenexpr = function
 287   | Expr_unit -> "()"
 288   | Expr_bool b -> sprintf "%b" b
 289   | Expr_str s -> sprintf "%S" s
 290   | Expr_int i -> sprintf "%s" (string_of_big_int i)
 291   | Expr_float f -> sprintf "%f" f
 292   | Expr_var v -> sprintf "%s" v
 293   | Expr_and (e1, e2) ->
 294     sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 295   | Expr_or (e1, e2) ->
 296     sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 297   | Expr_lt (e1, e2) ->
 298     sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 299   | Expr_le (e1, e2) ->
 300     sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 301   | Expr_eq (e1, e2) ->
 302     sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 303   | Expr_ge (e1, e2) ->
 304     sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 305   | Expr_gt (e1, e2) ->
 306     sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 307   | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
 308   | Expr_add (e1, e2) ->
 309     sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 310   | Expr_sub (e1, e2) ->
 311     sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 312   | Expr_mul (e1, e2) ->
 313     sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 314   | Expr_div (e1, e2) ->
 315     sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 316   | Expr_mod (e1, e2) ->
 317     sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 318   | Expr_changes v -> sprintf "changes %s" v
 319   | Expr_increases v -> sprintf "increases %s" v
 320   | Expr_decreases v -> sprintf "decreases %s" v
 321   | Expr_prev v -> sprintf "prev %s" v
 322   | Expr_reloaded -> "reloaded ()"
 323
 324 let string_of_periodexpr = function
 325   | Every_seconds 1 -> "1 second"
 326   | Every_seconds i -> sprintf "%d seconds" i
 327   | Every_days 1 -> "1 day"
 328   | Every_days i -> sprintf "%d days" i
 329   | Every_months 1 -> "1 month"
 330   | Every_months i -> sprintf "%d months" i
 331   | Every_years 1 -> "1 year"
 332   | Every_years i -> sprintf "%d years" i
 333
 334 let rec dependencies_of_whenexpr = function
 335   | Expr_unit -> []
 336   | Expr_bool _ -> []
 337   | Expr_str _ -> []
 338   | Expr_int _ -> []
 339   | Expr_float _ -> []
 340   | Expr_var v -> [v]
 341   | Expr_and (e1, e2)
 342   | Expr_or (e1, e2)
 343   | Expr_lt (e1, e2)
 344   | Expr_le (e1, e2)
 345   | Expr_eq (e1, e2)
 346   | Expr_ge (e1, e2)
 347   | Expr_gt (e1, e2)
 348   | Expr_add (e1, e2)
 349   | Expr_sub (e1, e2)
 350   | Expr_mul (e1, e2)
 351   | Expr_div (e1, e2)
 352   | Expr_mod (e1, e2) ->
 353     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 354   | Expr_not e ->
 355     dependencies_of_whenexpr e
 356   | Expr_changes v
 357   | Expr_increases v
 358   | Expr_decreases v
 359   | Expr_prev v -> [v]
 360   | Expr_reloaded -> []
 361
 362 let dependencies_of_job = function
 363   | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
 364   | { job_cond = Every_job _ } -> []
 365
 366 let rec eval_whenexpr job variables onload = function
 367   | Expr_unit -> T_unit
 368   | Expr_bool b -> T_bool b
 369   | Expr_str s -> T_string s
 370   | Expr_int i -> T_int i
 371   | Expr_float f -> T_float f
 372
 373   | Expr_var v ->
 374     (try StringMap.find v variables with Not_found -> T_string "")
 375
 376   | Expr_and (e1, e2) ->
 377     if eval_whenexpr_as_bool job variables onload e1 &&
 378        eval_whenexpr_as_bool job variables onload e2 then
 379       T_bool true
 380     else
 381       T_bool false
 382
 383   | Expr_or (e1, e2) ->
 384     if eval_whenexpr_as_bool job variables onload e1 ||
 385        eval_whenexpr_as_bool job variables onload e2 then
 386       T_bool true
 387     else
 388       T_bool false
 389
 390   | Expr_lt (e1, e2) ->
 391     let e1 = eval_whenexpr job variables onload e1
 392     and e2 = eval_whenexpr job variables onload e2 in
 393     if compare_values e1 e2 < 0 then
 394       T_bool true
 395     else
 396       T_bool false
 397
 398   | Expr_le (e1, e2) ->
 399     let e1 = eval_whenexpr job variables onload e1
 400     and e2 = eval_whenexpr job variables onload e2 in
 401     if compare_values e1 e2 <= 0 then
 402       T_bool true
 403     else
 404       T_bool false
 405
 406   | Expr_eq (e1, e2) ->
 407     let e1 = eval_whenexpr job variables onload e1
 408     and e2 = eval_whenexpr job variables onload e2 in
 409     if compare_values e1 e2 = 0 then
 410       T_bool true
 411     else
 412       T_bool false
 413
 414   | Expr_ge (e1, e2) ->
 415     let e1 = eval_whenexpr job variables onload e1
 416     and e2 = eval_whenexpr job variables onload e2 in
 417     if compare_values e1 e2 >= 0 then
 418       T_bool true
 419     else
 420       T_bool false
 421
 422   | Expr_gt (e1, e2) ->
 423     let e1 = eval_whenexpr job variables onload e1
 424     and e2 = eval_whenexpr job variables onload e2 in
 425     if compare_values e1 e2 > 0 then
 426       T_bool true
 427     else
 428       T_bool false
 429
 430   | Expr_not e ->
 431     if not (eval_whenexpr_as_bool job variables onload e) then
 432       T_bool true
 433     else
 434       T_bool false
 435
 436   | Expr_add (e1, e2) ->
 437     let e1 = eval_whenexpr job variables onload e1
 438     and e2 = eval_whenexpr job variables onload e2 in
 439     add_values e1 e2
 440
 441   | Expr_sub (e1, e2) ->
 442     let e1 = eval_whenexpr job variables onload e1
 443     and e2 = eval_whenexpr job variables onload e2 in
 444     sub_values e1 e2
 445
 446   | Expr_mul (e1, e2) ->
 447     let e1 = eval_whenexpr job variables onload e1
 448     and e2 = eval_whenexpr job variables onload e2 in
 449     mul_values e1 e2
 450
 451   | Expr_div (e1, e2) ->
 452     let e1 = eval_whenexpr job variables onload e1
 453     and e2 = eval_whenexpr job variables onload e2 in
 454     div_values e1 e2
 455
 456   | Expr_mod (e1, e2) ->
 457     let e1 = eval_whenexpr job variables onload e1
 458     and e2 = eval_whenexpr job variables onload e2 in
 459     mod_values e1 e2
 460
 461   | Expr_changes v ->
 462     let prev_value, curr_value = get_prev_curr_value job variables v in
 463     if compare_values prev_value curr_value <> 0 then
 464       T_bool true
 465     else
 466       T_bool false
 467
 468   | Expr_increases v ->
 469     let prev_value, curr_value = get_prev_curr_value job variables v in
 470     if compare_values prev_value curr_value > 0 then
 471       T_bool true
 472     else
 473       T_bool false
 474
 475   | Expr_decreases v ->
 476     let prev_value, curr_value = get_prev_curr_value job variables v in
 477     if compare_values prev_value curr_value < 0 then
 478       T_bool true
 479     else
 480       T_bool false
 481
 482   | Expr_prev v ->
 483     (try StringMap.find v job.job_private.job_prev_variables
 484      with Not_found -> T_string "")
 485
 486   | Expr_reloaded ->
 487     T_bool onload
 488
 489 and get_prev_curr_value job variables v =
 490   let prev_value =
 491     try StringMap.find v job.job_private.job_prev_variables
 492     with Not_found -> T_string "" in
 493   let curr_value =
 494     try StringMap.find v variables
 495     with Not_found -> T_string "" in
 496   prev_value, curr_value
 497
 498 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
 499 and eval_whenexpr_as_bool job variables onload expr =
 500   match eval_whenexpr job variables onload expr with
 501   | T_unit -> false
 502   | T_bool r -> r
 503   | T_string s -> s <> ""
 504   | T_int i -> sign_big_int i <> 0
 505   | T_float f -> f <> 0.
 506
 507 (* Do a comparison on two typed values and return -1/0/+1.  If the
 508  * types are different then we compare the values as strings.  The user
 509  * can avoid this by specifying types.
 510  *)
 511 and compare_values value1 value2 =
 512   match value1, value2 with
 513   | T_bool b1, T_bool b2 -> compare b1 b2
 514   | T_string s1, T_string s2 -> compare s1 s2
 515   | T_int i1, T_int i2 -> compare_big_int i1 i2
 516   | T_float f1, T_float f2 -> compare f1 f2
 517   | _ ->
 518     let value1 = string_of_variable value1
 519     and value2 = string_of_variable value2 in
 520     compare value1 value2
 521
 522 (* + operator is addition or string concatenation. *)
 523 and add_values value1 value2 =
 524   match value1, value2 with
 525   | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
 526   | T_float i1, T_float i2 -> T_float (i1 +. i2)
 527   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
 528   | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
 529   | T_string i1, T_string i2 -> T_string (i1 ^ i2)
 530   | _ ->
 531     invalid_arg
 532       (sprintf "incompatible types in addition: %s + %s"
 533          (printable_string_of_variable value1)
 534          (printable_string_of_variable value2))
 535
 536 and sub_values value1 value2 =
 537   match value1, value2 with
 538   | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
 539   | T_float i1, T_float i2 -> T_float (i1 -. i2)
 540   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
 541   | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
 542   | _ ->
 543     invalid_arg
 544       (sprintf "incompatible types in subtraction: %s - %s"
 545          (printable_string_of_variable value1)
 546          (printable_string_of_variable value2))
 547
 548 and mul_values value1 value2 =
 549   match value1, value2 with
 550   | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
 551   | T_float i1, T_float i2 -> T_float (i1 *. i2)
 552   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
 553   | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
 554   | _ ->
 555     invalid_arg
 556       (sprintf "incompatible types in multiplication: %s * %s"
 557          (printable_string_of_variable value1)
 558          (printable_string_of_variable value2))
 559
 560 and div_values value1 value2 =
 561   match value1, value2 with
 562   | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
 563   | T_float i1, T_float i2 -> T_float (i1 /. i2)
 564   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
 565   | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
 566   | _ ->
 567     invalid_arg
 568       (sprintf "incompatible types in division: %s / %s"
 569          (printable_string_of_variable value1)
 570          (printable_string_of_variable value2))
 571
 572 and mod_values value1 value2 =
 573   match value1, value2 with
 574   | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
 575   | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
 576   | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
 577   | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
 578   | _ ->
 579     invalid_arg
 580       (sprintf "incompatible types in modulo: %s mod %s"
 581          (printable_string_of_variable value1)
 582          (printable_string_of_variable value2))
 583
 584 and string_of_variable = function
 585   | T_unit -> "" (* for string_of_variable, we don't want () here *)
 586   | T_bool b -> string_of_bool b
 587   | T_string s -> s
 588   | T_int i -> string_of_big_int i
 589   | T_float f -> string_of_float f
 590
 591 and printable_string_of_variable = function
 592   | T_unit -> "()"
 593   | T_bool b -> string_of_bool b
 594   | T_string s -> sprintf "%S" s
 595   | T_int i -> string_of_big_int i
 596   | T_float f -> string_of_float f
 597
 598 let job_evaluate job variables onload =
 599   match job with
 600   | { job_cond = Every_job _ } -> false, job
 601   | { job_cond = When_job whenexpr } ->
 602     let state = eval_whenexpr_as_bool job variables onload whenexpr in
 603
 604     (* Because jobs are edge-triggered, we're only interested in the
 605      * case where the evaluation state changes from false -> true.
 606      *)
 607     match job.job_private.job_prev_eval_state, state with
 608     | false, false
 609     | true, true
 610     | true, false ->
 611       let jobp = { job.job_private with job_prev_eval_state = state } in
 612       let job = { job with job_private = jobp } in
 613       false, job
 614
 615     | false, true ->
 616       let jobp = { job_prev_eval_state = true;
 617                    job_prev_variables = variables } in
 618       let job = { job with job_private = jobp } in
 619       true, job
 620
 621 let next_periodexpr =
 622   (* Round up 'a' to the next multiple of 'i'. *)
 623   let round_up_float a i =
 624     let r = mod_float a i in
 625     if r = 0. then a +. i else a +. (i -. r)
 626   and round_up a i =
 627     let r = a mod i in
 628     if r = 0 then a + i else a + (i - r)
 629   in
 630
 631   fun t -> function
 632   | Every_seconds i ->
 633     let i = float_of_int i in
 634     round_up_float t i
 635
 636   | Every_years i ->
 637     let tm = gmtime t in
 638
 639     (* Round 'tm' up to the first day of the next year. *)
 640     let year = round_up tm.tm_year i in
 641     let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
 642                        tm_mday = 1; tm_mon = 0; tm_year = year } in
 643     fst (mktime tm)
 644
 645   | Every_days i ->
 646     let t = Date.from_unixfloat t in
 647     let t0 = Date.make 1970 1 1 in
 648
 649     (* Number of whole days since Unix Epoch. *)
 650     let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
 651
 652     let nb_days = round_up nb_days i in
 653     let t' = Date.add t0 (Date.Period.day nb_days) in
 654     Date.to_unixfloat t'
 655
 656   | Every_months i ->
 657     (* Calculate number of whole months since Unix Epoch. *)
 658     let tm = gmtime t in
 659     let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
 660
 661     let months = round_up months i in
 662     let t0 = Date.make 1970 1 1 in
 663     let t' = Date.add t0 (Date.Period.month months) in
 664     Date.to_unixfloat t'