2 * Copyright (C) 2012 Red Hat Inc.
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.
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.
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.
34 | Expr_int of Big_int.big_int
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_len of whenexpr
51 | Expr_changes of string
52 | Expr_increases of string
53 | Expr_decreases of string
57 (* This internal type is used during conversion of the OCaml AST
58 * to the whenexpr type.
64 | IExpr_int of Big_int.big_int
65 | IExpr_float of float
67 | IExpr_app of string * whenexpr_int list
69 (* Note that days are not necessarily expressible in seconds (because
70 * of leap seconds), months are not expressible in days (because months
71 * have different lengths), and years are not expressible in days
72 * (because of leap days) although we could save a case here by
73 * expressing years in months.
76 | Every_seconds of int
93 let variable_of_rpc = function
95 | `bool_t b -> T_bool b
96 | `string_t s -> T_string s
97 | `int_t i -> T_int (big_int_of_string i)
98 | `float_t f -> T_float f
100 let rpc_of_variable = function
102 | T_bool b -> `bool_t b
103 | T_string s -> `string_t s
104 | T_int i -> `int_t (string_of_big_int i)
105 | T_float f -> `float_t f
107 type variables = variable StringMap.t
110 pi_job_name : string;
111 pi_serial : Big_int.big_int;
112 pi_variables : (string * variable) list;
113 pi_running : preinfo_running_job list;
115 and preinfo_running_job = {
116 pirun_job_name : string;
117 pirun_serial : Big_int.big_int;
118 pirun_start_time : float;
123 res_job_name : string;
124 res_serial : Big_int.big_int;
128 res_start_time : float;
131 type pre = preinfo -> bool
132 type post = result -> unit
135 | When_job of whenexpr
136 | Every_job of periodexpr
141 job_pre : pre option;
142 job_post : post option;
144 job_script : shell_script;
147 let rec expr_of_ast _loc ast =
148 expr_of_iexpr _loc (iexpr_of_ast _loc ast)
150 and iexpr_of_ast _loc = function
151 | ExId (_, IdUid (_, "()")) -> IExpr_unit
152 | ExId (_, IdUid (_, "True")) -> IExpr_bool true
153 | ExId (_, IdUid (_, "False")) -> IExpr_bool false
154 | ExStr (_, str) -> IExpr_str str
155 | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
156 | ExFlo (_, f) -> IExpr_float (float_of_string f)
157 | ExId (_, IdLid (_, id)) -> IExpr_var id
159 (* In the OCaml AST, functions are curried right to left, so we
160 * must uncurry to get the list of arguments.
162 | ExApp (_, left_tree, right_arg) ->
163 let f, left_args = uncurry_app_tree _loc left_tree in
164 IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
167 (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
168 eprintf "expr_of_ast: invalid expression: %!";
169 let e = Ast.StExp (_loc, e) in
170 Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
172 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
174 and uncurry_app_tree _loc = function
175 | ExId (_, IdLid (_, f)) -> f, []
176 | ExApp (_, left_tree, right_arg) ->
177 let f, left_args = uncurry_app_tree _loc left_tree in
178 f, (right_arg :: left_args)
180 eprintf "uncurry_app_tree: invalid expression: %!";
181 let e = Ast.StExp (_loc, e) in
182 Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
184 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
186 and expr_of_iexpr _loc = function
187 | IExpr_unit -> Expr_unit
188 | IExpr_bool b -> Expr_bool b
189 | IExpr_str s -> Expr_str s
190 | IExpr_int i -> Expr_int i
191 | IExpr_float f -> Expr_float f
192 | IExpr_var v -> Expr_var v
194 | IExpr_app ("&&", exprs) ->
195 two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
197 | IExpr_app ("||", exprs) ->
198 two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
200 | IExpr_app ("<", exprs) ->
201 two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
203 | IExpr_app ("<=", exprs) ->
204 two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
206 | IExpr_app (("="|"=="), exprs) ->
207 two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
209 | IExpr_app (">=", exprs) ->
210 two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
212 | IExpr_app (">", exprs) ->
213 two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
215 | IExpr_app ("!", exprs) ->
216 one_param _loc "!" exprs (fun e1 -> Expr_not e1)
218 | IExpr_app ("+", exprs) ->
219 two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
221 | IExpr_app ("-", exprs) ->
222 two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
224 | IExpr_app ("*", exprs) ->
225 two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
227 | IExpr_app ("/", exprs) ->
228 two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
230 | IExpr_app ("mod", exprs) ->
231 two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
233 | IExpr_app (("len"|"length"|"size"), exprs) ->
234 one_param _loc "len" exprs (fun e1 -> Expr_len e1)
236 | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
239 | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
242 | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
245 | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
248 | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
249 invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
250 (Loc.to_string _loc) op)
252 | IExpr_app ("reloaded", [IExpr_unit]) ->
255 | IExpr_app ("reloaded", _) ->
256 invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
258 | IExpr_app (op, _) ->
259 invalid_arg (sprintf "%s: unknown operator in expression: %s"
260 (Loc.to_string _loc) op)
262 and two_params _loc op exprs f =
264 | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
266 invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
267 op (Loc.to_string _loc))
269 and one_param _loc op exprs f =
271 | [e1] -> f (expr_of_iexpr _loc e1)
273 invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
274 op (Loc.to_string _loc))
276 let rec string_of_whenexpr = function
278 | Expr_bool b -> sprintf "%b" b
279 | Expr_str s -> sprintf "%S" s
280 | Expr_int i -> sprintf "%s" (string_of_big_int i)
281 | Expr_float f -> sprintf "%f" f
282 | Expr_var v -> sprintf "%s" v
283 | Expr_and (e1, e2) ->
284 sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
285 | Expr_or (e1, e2) ->
286 sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
287 | Expr_lt (e1, e2) ->
288 sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
289 | Expr_le (e1, e2) ->
290 sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
291 | Expr_eq (e1, e2) ->
292 sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
293 | Expr_ge (e1, e2) ->
294 sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
295 | Expr_gt (e1, e2) ->
296 sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
297 | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
298 | Expr_add (e1, e2) ->
299 sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
300 | Expr_sub (e1, e2) ->
301 sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
302 | Expr_mul (e1, e2) ->
303 sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
304 | Expr_div (e1, e2) ->
305 sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
306 | Expr_mod (e1, e2) ->
307 sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
308 | Expr_len e -> sprintf "len %s" (string_of_whenexpr e)
309 | Expr_changes v -> sprintf "changes %s" v
310 | Expr_increases v -> sprintf "increases %s" v
311 | Expr_decreases v -> sprintf "decreases %s" v
312 | Expr_prev v -> sprintf "prev %s" v
313 | Expr_reloaded -> "reloaded ()"
315 let string_of_periodexpr = function
316 | Every_seconds 1 -> "1 second"
317 | Every_seconds i -> sprintf "%d seconds" i
318 | Every_days 1 -> "1 day"
319 | Every_days i -> sprintf "%d days" i
320 | Every_months 1 -> "1 month"
321 | Every_months i -> sprintf "%d months" i
322 | Every_years 1 -> "1 year"
323 | Every_years i -> sprintf "%d years" i
325 let rec dependencies_of_whenexpr = function
343 | Expr_mod (e1, e2) ->
344 dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
347 dependencies_of_whenexpr e
352 | Expr_reloaded -> []
354 let dependencies_of_job = function
355 | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
356 | { job_cond = Every_job _ } -> []
358 let rec eval_whenexpr variables prev_variables onload = function
359 | Expr_unit -> T_unit
360 | Expr_bool b -> T_bool b
361 | Expr_str s -> T_string s
362 | Expr_int i -> T_int i
363 | Expr_float f -> T_float f
366 get_variable variables v
368 | Expr_and (e1, e2) ->
369 if eval_whenexpr_as_bool variables prev_variables onload e1 &&
370 eval_whenexpr_as_bool variables prev_variables onload e2 then
375 | Expr_or (e1, e2) ->
376 if eval_whenexpr_as_bool variables prev_variables onload e1 ||
377 eval_whenexpr_as_bool variables prev_variables onload e2 then
382 | Expr_lt (e1, e2) ->
383 let e1 = eval_whenexpr variables prev_variables onload e1
384 and e2 = eval_whenexpr variables prev_variables onload e2 in
385 if compare_values e1 e2 < 0 then
390 | Expr_le (e1, e2) ->
391 let e1 = eval_whenexpr variables prev_variables onload e1
392 and e2 = eval_whenexpr variables prev_variables onload e2 in
393 if compare_values e1 e2 <= 0 then
398 | Expr_eq (e1, e2) ->
399 let e1 = eval_whenexpr variables prev_variables onload e1
400 and e2 = eval_whenexpr variables prev_variables onload e2 in
401 if compare_values e1 e2 = 0 then
406 | Expr_ge (e1, e2) ->
407 let e1 = eval_whenexpr variables prev_variables onload e1
408 and e2 = eval_whenexpr variables prev_variables onload e2 in
409 if compare_values e1 e2 >= 0 then
414 | Expr_gt (e1, e2) ->
415 let e1 = eval_whenexpr variables prev_variables onload e1
416 and e2 = eval_whenexpr variables prev_variables onload e2 in
417 if compare_values e1 e2 > 0 then
423 if not (eval_whenexpr_as_bool variables prev_variables onload e) then
428 | Expr_add (e1, e2) ->
429 let e1 = eval_whenexpr variables prev_variables onload e1
430 and e2 = eval_whenexpr variables prev_variables onload e2 in
433 | Expr_sub (e1, e2) ->
434 let e1 = eval_whenexpr variables prev_variables onload e1
435 and e2 = eval_whenexpr variables prev_variables onload e2 in
438 | Expr_mul (e1, e2) ->
439 let e1 = eval_whenexpr variables prev_variables onload e1
440 and e2 = eval_whenexpr variables prev_variables onload e2 in
443 | Expr_div (e1, e2) ->
444 let e1 = eval_whenexpr variables prev_variables onload e1
445 and e2 = eval_whenexpr variables prev_variables onload e2 in
448 | Expr_mod (e1, e2) ->
449 let e1 = eval_whenexpr variables prev_variables onload e1
450 and e2 = eval_whenexpr variables prev_variables onload e2 in
454 let e = eval_whenexpr variables prev_variables onload e in
455 let e = string_of_variable e in
456 T_int (big_int_of_int (String.length e))
459 let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
460 if compare_values prev_value curr_value <> 0 then
465 | Expr_increases v ->
466 let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
467 if compare_values prev_value curr_value < 0 then
472 | Expr_decreases v ->
473 let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
474 if compare_values prev_value curr_value > 0 then
480 get_prev_variable prev_variables v
485 and get_prev_curr_value variables prev_variables v =
486 let prev_value = get_prev_variable prev_variables v in
487 let curr_value = get_variable variables v in
488 prev_value, curr_value
490 and get_variable variables v =
491 try StringMap.find v variables with Not_found -> T_string ""
493 and get_prev_variable prev_variables v =
494 match prev_variables with
496 (* Job has never run. XXX Should do better here. *)
498 | Some prev_variables ->
499 get_variable prev_variables v
501 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
502 and eval_whenexpr_as_bool variables prev_variables onload expr =
503 match eval_whenexpr variables prev_variables onload expr with
506 | T_string s -> s <> ""
507 | T_int i -> sign_big_int i <> 0
508 | T_float f -> f <> 0.
510 (* Do a comparison on two typed values and return -1/0/+1. If the
511 * types are different then we compare the values as strings. The user
512 * can avoid this by specifying types.
514 and compare_values value1 value2 =
515 match value1, value2 with
516 | T_bool b1, T_bool b2 -> compare b1 b2
517 | T_string s1, T_string s2 -> compare s1 s2
518 | T_int i1, T_int i2 -> compare_big_int i1 i2
519 | T_float f1, T_float f2 -> compare f1 f2
520 (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
522 let value1 = string_of_variable value1
523 and value2 = string_of_variable value2 in
524 compare value1 value2
526 (* + operator is addition or string concatenation. *)
527 and add_values value1 value2 =
528 match value1, value2 with
529 | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
530 | T_float i1, T_float i2 -> T_float (i1 +. i2)
531 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
532 | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
533 | T_string i1, T_string i2 -> T_string (i1 ^ i2)
536 (sprintf "incompatible types in addition: %s + %s"
537 (printable_string_of_variable value1)
538 (printable_string_of_variable value2))
540 and sub_values value1 value2 =
541 match value1, value2 with
542 | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
543 | T_float i1, T_float i2 -> T_float (i1 -. i2)
544 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
545 | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
548 (sprintf "incompatible types in subtraction: %s - %s"
549 (printable_string_of_variable value1)
550 (printable_string_of_variable value2))
552 and mul_values value1 value2 =
553 match value1, value2 with
554 | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
555 | T_float i1, T_float i2 -> T_float (i1 *. i2)
556 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
557 | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
560 (sprintf "incompatible types in multiplication: %s * %s"
561 (printable_string_of_variable value1)
562 (printable_string_of_variable value2))
564 and div_values value1 value2 =
565 match value1, value2 with
566 | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
567 | T_float i1, T_float i2 -> T_float (i1 /. i2)
568 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
569 | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
572 (sprintf "incompatible types in division: %s / %s"
573 (printable_string_of_variable value1)
574 (printable_string_of_variable value2))
576 and mod_values value1 value2 =
577 match value1, value2 with
578 | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
579 | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
580 | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
581 | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
584 (sprintf "incompatible types in modulo: %s mod %s"
585 (printable_string_of_variable value1)
586 (printable_string_of_variable value2))
588 and string_of_variable = function
589 | T_unit -> "" (* for string_of_variable, we don't want () here *)
590 | T_bool b -> string_of_bool b
592 | T_int i -> string_of_big_int i
593 | T_float f -> string_of_float f
595 and printable_string_of_variable = function
597 | T_bool b -> string_of_bool b
598 | T_string s -> sprintf "%S" s
599 | T_int i -> string_of_big_int i
600 | T_float f -> string_of_float f
602 let next_periodexpr =
603 (* Round up 'a' to the next multiple of 'i'. *)
604 let round_up_float a i =
605 let r = mod_float a i in
606 if r = 0. then a +. i else a +. (i -. r)
609 if r = 0 then a + i else a + (i - r)
614 let i = float_of_int i in
620 (* Round 'tm' up to the first day of the next year. *)
621 let year = round_up tm.tm_year i in
622 let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
623 tm_mday = 1; tm_mon = 0; tm_year = year } in
627 let t = Date.from_unixfloat t in
628 let t0 = Date.make 1970 1 1 in
630 (* Number of whole days since Unix Epoch. *)
631 let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
633 let nb_days = round_up nb_days i in
634 let t' = Date.add t0 (Date.Period.day nb_days) in
638 (* Calculate number of whole months since Unix Epoch. *)
640 let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
642 let months = round_up months i in
643 let t0 = Date.make 1970 1 1 in
644 let t' = Date.add t0 (Date.Period.month months) in
647 let check_valid_variable_name name =
648 (* Don't permit certain names. *)
649 if name = "JOBSERIAL" then
650 failwith "JOBSERIAL variable cannot be set";
652 let len = String.length name in
654 failwith "variable name is an empty string";
655 if name.[0] <> '_' && not (isalpha name.[0]) then
656 failwith "variable name must start with alphabetic character or underscore";
660 else if name.[i] <> '_' && not (isalnum name.[i]) then
661 failwith "variable name contains non-alphanumeric non-underscore character"