1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
open Tk
open Protocol
let active_cb _ =
let cnter = ref 0 in
Hashtblc.iter
(fun w id ->
incr cnter;
Printf.fprintf stdout "%s %s %b\n"
(Widget.name w) (string_of_cbid id) (Winfo.exists w))
callback_memo_table;
Printf.fprintf stdout "Memo cb: %d\n" !cnter;
cnter := 0;
Hashtblc.iter (fun _ _ -> incr cnter) callback_naming_table;
Printf.fprintf stdout "Active cb: %d\n" !cnter;
flush stdout
let init () =
Frx_rpc.register "cb" active_cb;
Frx_rpc.register "cache"
(fun _ -> Cache.postmortem(); Gcache.postmortem(); flush stderr);
Frx_rpc.register "images" (fun _ -> Img.ImageData.dump(); flush stderr);
Frx_rpc.register "camltkdb" (fun _ -> Protocol.debug := not !Protocol.debug)
|
