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 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
|
(* $Id$ *)
open Equeue
open Unixqueue
#ifdef GTK1
type event_id = GMain.Io.event_source
#else
type event_id = GMain.Io.id
#endif
type gtk_file_handler_rec =
{ gtk_fd : Unix.file_descr;
mutable gtk_event_source_in : (event_id * bool ref) option;
mutable gtk_event_source_out : (event_id * bool ref) option;
mutable gtk_event_source_pri : (event_id * bool ref) option;
mutable gtk_event_source_err : (event_id * bool ref) option;
mutable gtk_event_source_hup : (event_id * bool ref) option;
}
type runner =
event_system -> (unit -> unit) -> unit
class gtk_event_system ?(run : runner option) () =
object (self)
inherit Unixqueue_select.select_based_event_system() as super
val mutable gtk_attaching = false
val mutable gtk_run_soon = false
val mutable gtk_is_running = false
val mutable gtk_last_timer = (None : GMain.Timeout.id option)
val mutable gtk_last_file_handlers =
(Hashtbl.create 1 :
(Unix.file_descr, gtk_file_handler_rec) Hashtbl.t)
val mutable gtk_watch_tuple = ([], [], [], -1.0)
method private gtk_attach ?(run_soon=false) () =
(* Creates an idle callback to reschedule events the next time the
* event loop is entered. This step can be omitted when this method
* is called from a Unixqueue callback (it is ensured gtk_setup
* will be invoked soon).
*
* run_soon: if true, the Unixqueue is run once from the idle
* callback. This can be used to process additional, non-file events.
*)
if not gtk_is_running then (
(* prerr_endline "ATTACH!"; *)
if not gtk_attaching then (
gtk_attaching <- true;
( match gtk_last_timer with
Some th -> GMain.Timeout.remove th; gtk_last_timer <- None
| None -> ()
);
gtk_last_timer <- Some (GMain.Timeout.add
~ms:0
~callback:
(fun () ->
self#gtk_setup();
gtk_run_soon && (
gtk_run_soon <- false;
self#gtk_safe_handler false ([],[],[]) ()
)
));
);
gtk_run_soon <- gtk_run_soon || run_soon;
)
(* else prerr_endline "(no attach)"; *)
method private gtk_setup() =
let (infiles, outfiles, oobfiles, time) as watch_tuple = super#setup() in
gtk_watch_tuple <- watch_tuple;
let ht = Hashtbl.create 50 (* n *) in (* 50 should be enough *)
(* Fill ht, the new hash table of file handlers: *)
List.iter
(fun fd ->
Hashtbl.replace ht fd (true,false,false))
infiles;
List.iter
(fun fd ->
let (i,_,_) =
try Hashtbl.find ht fd
with Not_found -> (false,true,false)
in
Hashtbl.replace ht fd (i,true,false))
outfiles;
List.iter
(fun fd ->
let (i,o,_) =
try Hashtbl.find ht fd
with Not_found -> (false,false,true)
in
Hashtbl.replace ht fd (i,o,true))
oobfiles;
let dest_handler (gh, is_active) =
is_active := false;
#ifdef GTK1
ignore(GMain.Io.remove_source gh);
#else
(* GTK2 *)
ignore(GMain.Io.remove gh);
#endif
in
(* Update GTK file handlers: *)
Hashtbl.iter
(fun fd (i,o,x) ->
let mk_handler cond il ol xl =
let is_active = ref true in
(* Note: prio=150 has slightly lower priority than resize/redraw
* operations, but higher priority than idle callbacks
*)
let gh =
GMain.Io.add_watch
~prio:150
~cond:(
#ifdef GTK2_IO_ADD_WATCH_SUPPORTS_LISTS
[cond]
#else
cond
#endif
)
~callback:(
fun _ ->
!is_active &&
self#gtk_safe_handler true (il,ol,xl) ())
(GMain.Io.channel_of_descr fd) in
(gh, is_active) in
let g =
try Hashtbl.find gtk_last_file_handlers fd
with Not_found ->
{ gtk_fd = fd;
gtk_event_source_in = None;
gtk_event_source_out = None;
gtk_event_source_pri = None;
gtk_event_source_err = None;
gtk_event_source_hup = None; } in
( match g.gtk_event_source_in with
None when i ->
g.gtk_event_source_in <- Some(mk_handler Uq_gtk_helper._in [fd] [] []);
| Some s when not i ->
dest_handler s;
g.gtk_event_source_in <- None
| _ ->
()
);
( match g.gtk_event_source_out with
None when o ->
g.gtk_event_source_out <- Some(mk_handler `OUT [] [fd] []);
| Some s when not o ->
dest_handler s;
g.gtk_event_source_out <- None
| _ ->
()
);
( match g.gtk_event_source_pri with
None when x ->
g.gtk_event_source_pri <- Some(mk_handler `PRI [] [] [fd]);
| Some s when not x ->
dest_handler s;
g.gtk_event_source_pri <- None
| _ ->
()
);
( match g.gtk_event_source_err with
None when i || o || x ->
let il = if i then [fd] else [] in
let ol = if o then [fd] else [] in
let xl = if x then [fd] else [] in
g.gtk_event_source_err <- Some(mk_handler `ERR il ol xl);
| Some s when not (i || o || x) ->
dest_handler s;
g.gtk_event_source_err <- None
| _ ->
()
);
( match g.gtk_event_source_hup with
None when i || o || x ->
let il = if i then [fd] else [] in
let ol = if o then [fd] else [] in
let xl = if x then [fd] else [] in
g.gtk_event_source_hup <- Some(mk_handler `HUP il ol xl);
| Some s when not (i || o || x) ->
dest_handler s;
g.gtk_event_source_hup <- None
| _ ->
()
);
Hashtbl.replace gtk_last_file_handlers fd g
)
ht;
Hashtbl.iter
(fun fd g ->
if not (Hashtbl.mem ht fd) then (
( match g.gtk_event_source_in with
Some s ->
dest_handler s;
g.gtk_event_source_in <- None
| _ -> ()
);
( match g.gtk_event_source_out with
Some s ->
dest_handler s;
g.gtk_event_source_out <- None
| _ -> ()
);
( match g.gtk_event_source_pri with
Some s ->
dest_handler s;
g.gtk_event_source_pri <- None
| _ -> ()
);
( match g.gtk_event_source_err with
Some s ->
dest_handler s;
g.gtk_event_source_err <- None
| _ -> ()
);
( match g.gtk_event_source_hup with
Some s ->
dest_handler s;
g.gtk_event_source_hup <- None
| _ -> ()
);
)
)
gtk_last_file_handlers;
let watching_files = infiles <> [] ||
outfiles <> [] ||
oobfiles <> [] in
(* Remove the old timer, if any. *)
begin match gtk_last_timer with
None -> ()
| Some th ->
GMain.Timeout.remove th;
gtk_last_timer <- None;
end;
gtk_attaching <- false;
(* Set the new timer, if necessary *)
if time >= 0.0 then begin
(* prerr_endline ("Timeout: " ^ string_of_float time); *)
gtk_last_timer <- Some (GMain.Timeout.add
~ms:(int_of_float (time *. 1E3 +. 0.5))
~callback:(self#gtk_safe_handler false ([],[],[])));
end;
(* If no handler is active, detach. *)
(*
if gtk_last_timer = None && not watching_files then begin
gtk_attached <- false;
(* prerr_endline "Detached!"; *)
end;
*)
method private gtk_safe_handler keep watch_tuple () =
try
self#gtk_handler watch_tuple ();
keep
with
any ->
prerr_endline("Uq_gtk: Internal uncaught exception: " ^
Netexn.to_string any);
raise any;
keep
method private gtk_handler watch_tuple () =
(* IMPORTANT:
* It is possible that this is a "ghost event". We need to test whether
* there is a resource for the event or not.
*)
(* Do now a 'select' with zero timeout to test the file descriptors. *)
let (infiles,outfiles,oobfiles) = watch_tuple in
let (infiles', outfiles', oobfiles') as actual_tuple =
(* (infiles', outfiles', oobfiles'): Lists of file descriptors that
* can be handled
*)
Unix.select infiles outfiles oobfiles 0.0
(* Because of the timeout value 0.0, this "select" call cannot block,
* and it cannot raise EINTR.
*)
in
(* Now we have in infiles', outfiles', oobfiles' the actually happened
* file descriptor events.
* Furthermore, pure timeout events may have happened, but this is not
* indicated specially.
*)
ignore(self#queue_events actual_tuple);
(* Now run the queue (without source). *)
begin try
gtk_is_running <- true;
match run with
None -> super#run()
| Some r -> r (self : #event_system :> event_system) super#run;
with
any ->
prerr_endline ("Uq_gtk: Uncaught exception: " ^
Netexn.to_string any
);
end;
gtk_is_running <- false;
(* Set up for the next round. *)
self#gtk_setup ();
(**********************************************************************)
(* Overriden methods *)
(**********************************************************************)
method private source _ =
(* Override this method: All events are coming from the glib loop,
* so disable this source of events
*)
()
(* After certain method invocations, we must ensure we are attached: *)
method add_resource g (op,t) =
super # add_resource g (op,t);
self # gtk_attach()
method remove_resource g op =
super # remove_resource g op;
self # gtk_attach()
method add_event e =
super # add_event e;
self # gtk_attach ~run_soon:true ()
method run() =
(* Calling this method is an error! *)
failwith "gtk_event_system#run: This method is disabled. Run the Glib event loop instead!"
end
;;
|