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