1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
|
(***********************************************************************)
(* ehandlers.ml - functions for constructing event handlers for use *)
(* with [Eventloop] module *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(* 2011, 2012, 2013 Yaron Minsky and Contributors *)
(* *)
(* This file is part of SKS. SKS is free software; you can *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>. *)
(***********************************************************************)
open StdLabels
open MoreLabels
open Printf
open Common
open Eventloop
module Unix = UnixLabels
(** Repeat callback ~request with a gap of redo_timeout, until
either (test ()) is true or full_timeout has expired.
In the former case, invoke success, int the latter, failure.
Callbacks can return a list of events, which will be placed
on the queue upon their completion.
*)
let repeat_until ~redo_timeout ~full_timeout ~test
~init ~request ~success ~failure =
init ();
let start = Unix.gettimeofday () in
let rec loop () =
let now = Unix.gettimeofday () in
if test ()
then success ()
else if now > start +. full_timeout
then failure ()
else
(request ()) @
[ Event (now +. redo_timeout, Callback loop) ]
in
let now = Unix.gettimeofday () in
[ Event (now, Callback loop) ]
(** returns smallest floating point number larger than the argument *)
let float_incr x = x +. x *. epsilon_float
let float_decr x = x -. x *. epsilon_float
let strftime time =
let tm = Unix.localtime time in
sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
(** repeat provided callback forever, with one invocation occuring timeout
seconds after the last one completed. *)
let repeat_forever ?(jitter=0.0) ?start timeout callback =
let rec loop () =
let delay = timeout +. (Random.float jitter -. jitter /. 2.) *. timeout in
let next_time = Unix.gettimeofday () +. delay in
[ Event (next_time, callback);
Event (float_incr next_time, Callback loop);
]
in
let start = match start with
None -> Unix.gettimeofday ()
| Some time -> time
in
[ Event (start, Callback loop); ]
let repeat_forever_simple timeout callback =
repeat_forever timeout (Callback (fun () -> callback (); []))
let incr_day time =
let tm = Unix.localtime time in
let tm = {tm with Unix.tm_mday = tm.Unix.tm_mday + 1; } in
let (time,tm) = Unix.mktime tm in
time
let set_hour time hour =
let tm = Unix.localtime time in
let tm = {tm with
Unix.tm_sec = 0;
Unix.tm_min = 0;
Unix.tm_hour = hour;
Unix.tm_mday = tm.Unix.tm_mday +
if hour < tm.Unix.tm_hour then 1 else 0
}
in
let (time,tm) = Unix.mktime tm in
time
let repeat_at_hour hour callback =
let rec loop oldtime () =
let newtime = incr_day oldtime in
[ Event (oldtime, Callback callback);
Event (newtime, Callback (loop newtime)) ]
in
let start = set_hour (Unix.gettimeofday ()) hour in
[Event (start, Callback (loop start)) ]
|