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