blob: 97063eb00c7efba628ee33a9ce450aa3b508db10 (
plain)
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
|
type debuglog_type = [`read | `write | `status]
class mainwin () =
(* main window layout *)
let g_win = GWindow.window ~wm_name:"Serika" ~wm_class:"serika" ~position:`CENTER () in
let _ = g_win#connect#destroy GMain.Main.quit in
let _ = g_win#set_default_width 640 and _ = g_win#set_default_height 480 in
let g_vbox = GPack.vbox ~packing:g_win#add () in
let g_tabs = GPack.notebook ~packing:g_vbox#add () in
(* debug tab *)
let g_debug_tbl = GPack.table ~rows:2 ~columns:2 () in
let g_debug_scroll = GBin.scrolled_window ~vpolicy:`ALWAYS ~hpolicy:`AUTOMATIC ~packing:(g_debug_tbl#attach ~left:0 ~top:0 ~right:2 ~expand:`BOTH) () in
let g_debug = GText.view ~editable:false ~wrap_mode:`CHAR ~packing:g_debug_scroll#add () in
let g_debug_cmd = GEdit.entry ~activates_default:true ~packing:(g_debug_tbl#attach ~left:0 ~top:1 ~expand:`X) () in
let g_debug_send = GButton.button ~label:"_Send command" ~use_mnemonic:true ~packing:(g_debug_tbl#attach ~left:1 ~top:1 ~expand:`NONE) () in
let _ = g_tabs#append_page ~tab_label:((GMisc.label ~text:"Debug" ())#coerce) g_debug_tbl#coerce in
let _ = g_debug_cmd#connect#activate (fun () -> ignore (g_debug_send#misc#activate ())) in
(* status bar *)
let g_status = GMisc.statusbar ~packing:(g_vbox#pack ~expand:false) () in
let g_statuscontext = g_status#new_context ~name:"Meh" in
let g_bandwidth = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:70 ~text:"0.0 kB" () in
let g_cmd_count = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:25 ~text:"0" () in
(* coloring and marking for the debug textview *)
let _ = g_debug#buffer#create_tag ~name:"read" [`FOREGROUND "#cc6666"] in
let _ = g_debug#buffer#create_tag ~name:"write" [`FOREGROUND "#6666cc"] in
let _ = g_debug#buffer#create_tag ~name:"prefix" [`WEIGHT `LIGHT] in
let _ = g_debug#buffer#create_mark ~name:"end" ~left_gravity:false g_debug#buffer#end_iter in
(* the object *)
object (self)
val mutable bandwidth = 0
val mutable cmd_count = 0
val mutable laststatusmsg = g_statuscontext#push "Welcome to Serika!"
method show = g_win#show ()
method set_debug_docmd f =
ignore (g_debug_send#connect#clicked (fun () ->
f (g_debug_cmd#text)
))
method statusmsg str =
let msg = g_statuscontext#push str in
g_statuscontext#remove laststatusmsg;
laststatusmsg <- msg;
self#add_debuglog `status str
method add_bandwidth s =
bandwidth <- bandwidth+s;
g_bandwidth#set_text (Printf.sprintf "%.1f kB" ((float bandwidth) /. 1024.0))
method incr_cmd_count =
cmd_count <- cmd_count+1;
g_cmd_count#set_text (string_of_int cmd_count)
method add_debuglog (t : debuglog_type) str =
let tm = Unix.localtime (Unix.time ()) in
let time = Printf.sprintf "[%02d:%02d:%02d] " tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
let tags, prefix = match t with
| `read -> (["read"], "< ")
| `write -> (["write"], "> ")
| `status -> ([], "= ") in
let buf = g_debug#buffer in
buf#insert ~iter:buf#end_iter ~tag_names:["prefix"] (time ^ prefix);
buf#insert ~iter:buf#end_iter ~tag_names:tags str;
buf#insert ~iter:buf#end_iter "\n";
g_debug#scroll_mark_onscreen (`NAME "end")
method set_throttled sec (cb : (unit -> unit)) =
let togo = ref sec in
g_debug_send#misc#set_sensitive false;
let secfunc () =
togo := !togo - 1;
if !togo < 1 then (
g_debug_send#misc#set_sensitive true;
cb ();
false
) else (
g_statuscontext#flash ~delay:1000 ("Throttled. Waiting "
^(string_of_int !togo)^" seconds before continuing...");
true
)
in
ignore (GMain.Timeout.add ~ms:1000 ~callback:secfunc)
end
|
