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