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