← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to .pc/0001-Camlp4-workarounds.patch/src/equeue-gtk1/uq_gtk.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/0001-Camlp4-workarounds.patch/src/equeue-gtk1/uq_gtk.ml
1
 
(* $Id: uq_gtk.ml 924 2006-06-19 16:57:05Z gerd $ *)
2
 
 
3
 
open Equeue
4
 
open Unixqueue
5
 
 
6
 
IFDEF GTK1 THEN
7
 
  type event_id = GMain.Io.event_source
8
 
ELSE
9
 
  type event_id = GMain.Io.id
10
 
END
11
 
 
12
 
type gtk_file_handler_rec = 
13
 
    { gtk_fd : Unix.file_descr;
14
 
      mutable gtk_event_source_in  : (event_id * bool ref) option;
15
 
      mutable gtk_event_source_out : (event_id * bool ref) option;
16
 
      mutable gtk_event_source_pri : (event_id * bool ref) option;
17
 
      mutable gtk_event_source_err : (event_id * bool ref) option;
18
 
      mutable gtk_event_source_hup : (event_id * bool ref) option;
19
 
    }
20
 
 
21
 
 
22
 
type runner =
23
 
    event_system -> (unit -> unit) -> unit
24
 
 
25
 
 
26
 
class gtk_event_system ?(run : runner option) () =
27
 
object (self)
28
 
  inherit unix_event_system() as super
29
 
 
30
 
  val mutable gtk_attaching = false
31
 
  val mutable gtk_run_soon = false
32
 
  val mutable gtk_is_running = false
33
 
 
34
 
  val mutable gtk_last_timer = (None : GMain.Timeout.id option)
35
 
 
36
 
  val mutable gtk_last_file_handlers =
37
 
                (Hashtbl.create 1 :
38
 
                   (Unix.file_descr, gtk_file_handler_rec) Hashtbl.t)
39
 
 
40
 
  val mutable gtk_watch_tuple = ([], [], [], -1.0)
41
 
 
42
 
  method private gtk_attach ?(run_soon=false) () =
43
 
    (* Creates an idle callback to reschedule events the next time the
44
 
     * event loop is entered. This step can be omitted when this method
45
 
     * is called from a Unixqueue callback (it is ensured gtk_setup
46
 
     * will be invoked soon).
47
 
     *
48
 
     * run_soon: if true, the Unixqueue is run once from the idle
49
 
     * callback. This can be used to process additional, non-file events.
50
 
     *)
51
 
    if not gtk_is_running then (
52
 
      (* prerr_endline "ATTACH!"; *)
53
 
      if not gtk_attaching then (
54
 
        gtk_attaching <- true;
55
 
        ( match gtk_last_timer with
56
 
              Some th -> GMain.Timeout.remove th; gtk_last_timer <- None
57
 
            | None    -> ()
58
 
        );
59
 
        gtk_last_timer <- Some (GMain.Timeout.add
60
 
                                  ~ms:0
61
 
                                  ~callback:
62
 
                                  (fun () ->
63
 
                                     self#gtk_setup();
64
 
                                     gtk_run_soon && (
65
 
                                       gtk_run_soon <- false;
66
 
                                       self#gtk_safe_handler false ([],[],[]) ()
67
 
                                     )
68
 
                                  ));
69
 
      );
70
 
      gtk_run_soon <- gtk_run_soon || run_soon;
71
 
    )
72
 
    (* else prerr_endline "(no attach)"; *)
73
 
 
74
 
 
75
 
  method private gtk_setup() =
76
 
    let (infiles, outfiles, oobfiles, time) as watch_tuple = super#setup() in
77
 
 
78
 
    gtk_watch_tuple <- watch_tuple;
79
 
 
80
 
    let ht = Hashtbl.create 50 (* n *) in   (* 50 should be enough *)
81
 
 
82
 
    (* Fill ht, the new hash table of file handlers: *)
83
 
    List.iter
84
 
      (fun fd ->
85
 
         Hashtbl.replace ht fd (true,false,false))
86
 
      infiles;
87
 
    
88
 
    List.iter
89
 
      (fun fd ->
90
 
         let (i,_,_) =
91
 
           try Hashtbl.find ht fd
92
 
           with Not_found -> (false,true,false)
93
 
         in
94
 
         Hashtbl.replace ht fd (i,true,false))
95
 
      outfiles;
96
 
    
97
 
    List.iter
98
 
      (fun fd ->
99
 
         let (i,o,_) =
100
 
           try Hashtbl.find ht fd
101
 
           with Not_found -> (false,false,true)
102
 
         in
103
 
         Hashtbl.replace ht fd (i,o,true))
104
 
      oobfiles;
105
 
 
106
 
    let dest_handler (gh, is_active) =
107
 
      is_active := false;
108
 
      IFDEF GTK1 THEN
109
 
        ignore(GMain.Io.remove_source gh);
110
 
      ELSE
111
 
        (* GTK2 *)
112
 
        ignore(GMain.Io.remove gh);
113
 
      END
114
 
    in
115
 
 
116
 
    (* Update GTK file handlers: *)
117
 
    Hashtbl.iter
118
 
      (fun fd (i,o,x) ->
119
 
         let mk_handler cond il ol xl =
120
 
           let is_active = ref true in
121
 
           (* Note: prio=150 has slightly lower priority than resize/redraw
122
 
            * operations, but higher priority than idle callbacks
123
 
            *)
124
 
           let gh =
125
 
             GMain.Io.add_watch 
126
 
               ~prio:150
127
 
               ~cond:(
128
 
                 IFDEF GTK2_IO_ADD_WATCH_SUPPORTS_LISTS THEN
129
 
                   [cond]
130
 
                 ELSE
131
 
                   cond
132
 
                 END)
133
 
               ~callback:(
134
 
                 fun _ ->
135
 
                   !is_active &&
136
 
                     self#gtk_safe_handler true (il,ol,xl) ())
137
 
               (GMain.Io.channel_of_descr fd) in
138
 
           (gh, is_active) in
139
 
         let g = 
140
 
           try Hashtbl.find gtk_last_file_handlers fd 
141
 
           with Not_found ->
142
 
             { gtk_fd = fd;
143
 
               gtk_event_source_in = None;
144
 
               gtk_event_source_out = None;
145
 
               gtk_event_source_pri = None;
146
 
               gtk_event_source_err = None;
147
 
               gtk_event_source_hup = None; } in
148
 
         ( match g.gtk_event_source_in with
149
 
               None when i ->
150
 
                 g.gtk_event_source_in <- Some(mk_handler `IN [fd] [] []);
151
 
             | Some s when not i ->
152
 
                 dest_handler s;
153
 
                 g.gtk_event_source_in <- None
154
 
             | _ ->
155
 
                 ()
156
 
         );
157
 
         ( match g.gtk_event_source_out with
158
 
               None when o ->
159
 
                 g.gtk_event_source_out <- Some(mk_handler `OUT [] [fd] []);
160
 
             | Some s when not o ->
161
 
                 dest_handler s;
162
 
                 g.gtk_event_source_out <- None
163
 
             | _ ->
164
 
                 ()
165
 
         );
166
 
         ( match g.gtk_event_source_pri with
167
 
               None when x ->
168
 
                 g.gtk_event_source_pri <- Some(mk_handler `PRI [] [] [fd]);
169
 
             | Some s when not x ->
170
 
                 dest_handler s;
171
 
                 g.gtk_event_source_pri <- None
172
 
             | _ ->
173
 
                 ()
174
 
         );
175
 
         ( match g.gtk_event_source_err with
176
 
               None when i || o || x ->
177
 
                 let il = if i then [fd] else [] in
178
 
                 let ol = if o then [fd] else [] in
179
 
                 let xl = if x then [fd] else [] in
180
 
                 g.gtk_event_source_err <- Some(mk_handler `ERR il ol xl);
181
 
             | Some s when not (i || o || x) ->
182
 
                 dest_handler s;
183
 
                 g.gtk_event_source_err <- None
184
 
             | _ ->
185
 
                 ()
186
 
         );
187
 
         ( match g.gtk_event_source_hup with
188
 
               None when i || o || x ->
189
 
                 let il = if i then [fd] else [] in
190
 
                 let ol = if o then [fd] else [] in
191
 
                 let xl = if x then [fd] else [] in
192
 
                 g.gtk_event_source_hup <- Some(mk_handler `HUP il ol xl);
193
 
             | Some s when not (i || o || x) ->
194
 
                 dest_handler s;
195
 
                 g.gtk_event_source_hup <- None
196
 
             | _ ->
197
 
                 ()
198
 
         );
199
 
         Hashtbl.replace gtk_last_file_handlers fd g
200
 
      )
201
 
      ht;
202
 
 
203
 
    Hashtbl.iter
204
 
      (fun fd g ->
205
 
         if not (Hashtbl.mem ht fd) then (
206
 
           ( match g.gtk_event_source_in with
207
 
                 Some s ->
208
 
                   dest_handler s;
209
 
                   g.gtk_event_source_in <- None
210
 
               | _ -> ()
211
 
           );
212
 
           ( match g.gtk_event_source_out with
213
 
                 Some s ->
214
 
                   dest_handler s;
215
 
                   g.gtk_event_source_out <- None
216
 
               | _ -> ()
217
 
           );
218
 
           ( match g.gtk_event_source_pri with
219
 
                 Some s ->
220
 
                   dest_handler s;
221
 
                   g.gtk_event_source_pri <- None
222
 
               | _ -> ()
223
 
           );
224
 
           ( match g.gtk_event_source_err with
225
 
                 Some s ->
226
 
                   dest_handler s;
227
 
                   g.gtk_event_source_err <- None
228
 
               | _ -> ()
229
 
           );
230
 
           ( match g.gtk_event_source_hup with
231
 
                 Some s ->
232
 
                   dest_handler s;
233
 
                   g.gtk_event_source_hup <- None
234
 
               | _ -> ()
235
 
           );
236
 
         )
237
 
      )
238
 
      gtk_last_file_handlers;
239
 
 
240
 
    let watching_files = infiles <> [] || 
241
 
                         outfiles <> [] || 
242
 
                         oobfiles <> [] in
243
 
    
244
 
 
245
 
    (* Remove the old timer, if any. *)
246
 
    begin match gtk_last_timer with
247
 
        None -> ()
248
 
      | Some th -> 
249
 
          GMain.Timeout.remove th;
250
 
          gtk_last_timer <- None;
251
 
    end;
252
 
    gtk_attaching <- false;
253
 
 
254
 
    (* Set the new timer, if necessary *)
255
 
    if time >= 0.0 then begin
256
 
      (* prerr_endline ("Timeout: " ^ string_of_float time); *)
257
 
      gtk_last_timer <- Some (GMain.Timeout.add
258
 
                                ~ms:(int_of_float (time *. 1E3 +. 0.5))
259
 
                                ~callback:(self#gtk_safe_handler false ([],[],[])));
260
 
    end;
261
 
 
262
 
    (* If no handler is active, detach. *)
263
 
    (*
264
 
    if gtk_last_timer = None && not watching_files then begin
265
 
      gtk_attached <- false;
266
 
      (* prerr_endline "Detached!"; *)
267
 
    end;
268
 
    *)
269
 
 
270
 
  method private gtk_safe_handler keep watch_tuple () =
271
 
    try
272
 
      self#gtk_handler watch_tuple ();
273
 
      keep
274
 
    with
275
 
        any ->
276
 
          prerr_endline("Uq_gtk: Internal uncaught exception: " ^
277
 
                        Printexc.to_string any);
278
 
          raise any;
279
 
          keep
280
 
 
281
 
  method private gtk_handler watch_tuple () =
282
 
 
283
 
    (* IMPORTANT:
284
 
     * It is possible that this is a "ghost event". We need to test whether
285
 
     * there is a resource for the event or not.
286
 
     *)
287
 
 
288
 
    (* Do now a 'select' with zero timeout to test the file descriptors. *)
289
 
 
290
 
    let (infiles,outfiles,oobfiles) = watch_tuple in
291
 
 
292
 
    let (infiles', outfiles', oobfiles') as actual_tuple =
293
 
      (* (infiles', outfiles', oobfiles'): Lists of file descriptors that
294
 
       * can be handled
295
 
       *)
296
 
      Unix.select infiles outfiles oobfiles 0.0
297
 
        (* Because of the timeout value 0.0, this "select" call cannot block,
298
 
         * and it cannot raise EINTR.
299
 
         *)
300
 
    in
301
 
 
302
 
    (* Now we have in infiles', outfiles', oobfiles' the actually happened
303
 
     * file descriptor events.
304
 
     * Furthermore, pure timeout events may have happened, but this is not
305
 
     * indicated specially.
306
 
     *)
307
 
    ignore(self#queue_events actual_tuple);
308
 
 
309
 
    (* Now run the queue (without source). *)
310
 
    begin try
311
 
      gtk_is_running <- true;
312
 
      match run with
313
 
          None   -> super#run()
314
 
        | Some r -> r (self : #event_system :> event_system) super#run;
315
 
    with
316
 
        any ->
317
 
          prerr_endline ("Uq_gtk: Uncaught exception: " ^
318
 
                         Printexc.to_string any
319
 
                        );
320
 
    end;
321
 
    gtk_is_running <- false;
322
 
    
323
 
    (* Set up for the next round. *)
324
 
    self#gtk_setup ();
325
 
 
326
 
  (**********************************************************************)
327
 
  (* Overriden methods                                                  *)
328
 
  (**********************************************************************)
329
 
 
330
 
  method private source _ =
331
 
    (* Override this method: All events are coming from the glib loop,
332
 
     * so disable this source of events
333
 
     *)
334
 
    ()
335
 
 
336
 
  (* After certain method invocations, we must ensure we are attached: *)
337
 
 
338
 
  method add_resource g (op,t) =
339
 
    super # add_resource g (op,t);
340
 
    self # gtk_attach()
341
 
 
342
 
  method remove_resource g op =
343
 
    super # remove_resource g op;
344
 
    self # gtk_attach()
345
 
 
346
 
  method add_event e =
347
 
    super # add_event e;
348
 
    self # gtk_attach ~run_soon:true ()
349
 
 
350
 
 
351
 
  method run() =
352
 
    (* Calling this method is an error! *)
353
 
    failwith "gtk_event_system#run: This method is disabled. Run the Glib event loop instead!"
354
 
 
355
 
end
356
 
;;