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
|
(* A graphical frontend (handles backend notifications, copy_in, copy_out,
presentation of "select" result in tables)
To build prompt_gtk you need lablgtk 1.2 *)
open Printf
open GMain
open! Postgresql
let () =
if Array.length Sys.argv <> 2 then (
eprintf "Usage: %s conninfo\n" Sys.argv.(0);
exit 1)
let conninfo = Sys.argv.(1)
let file_dialog title =
let name = ref "" in
let sel = GWindow.file_selection ~title ~modal:true () in
let cancel_callback () =
sel#destroy ();
Main.quit ()
in
let ok_callback () =
name := sel#filename;
cancel_callback ()
in
let _ = sel#ok_button#connect#clicked ~callback:ok_callback in
let _ = sel#cancel_button#connect#clicked ~callback:cancel_callback in
sel#show ();
Main.main ();
!name
let make_window title =
let window = GWindow.window ~title ~width:300 ~height:300 () in
let vbox = GPack.vbox ~packing:window#add () in
let button =
GButton.button ~label:"Close"
~packing:(fun widget -> vbox#pack ~from:`END widget)
()
in
let _ = button#connect#clicked ~callback:window#destroy in
let hbox = GPack.hbox ~packing:vbox#add () in
let sbv = GRange.scrollbar `VERTICAL ~packing:(hbox#pack ~from:`END) () in
let sbh = GRange.scrollbar `HORIZONTAL ~packing:(vbox#pack ~from:`END) () in
(window, hbox, sbv, sbh)
let show_tuples res =
let window, hbox, sbv, sbh = make_window "Result (tuples)" in
let cl =
GList.clist ~titles:res#get_fnames_lst ~shadow_type:`OUT ~packing:hbox#add
~vadjustment:sbv#adjustment ~hadjustment:sbh#adjustment ()
in
for tuple = 0 to res#ntuples - 1 do
ignore (cl#append (res#get_tuple_lst tuple))
done;
cl#columns_autosize ();
window#show ()
let show_copy_out conn =
let window, hbox, _sbv, _sbh = make_window "Result (copy_out)" in
let txt = GText.view ~packing:hbox#add () in
let buf = txt#buffer in
conn#copy_out (fun s -> buf#insert (s ^ "\n"));
window#show ()
let main () =
let conn = new connection ~conninfo () in
let window = GWindow.window ~title:"Queries" ~width:300 ~height:300 () in
let _ = window#connect#destroy ~callback:Main.quit in
let vbox = GPack.vbox ~border_width:5 ~spacing:10 ~packing:window#add () in
let result = GText.view ~editable:false ~packing:vbox#add () in
let res_buf = result#buffer in
let text = GText.view ~editable:true ~packing:vbox#add ~height:50 () in
let print s = ignore (res_buf#insert s) in
let rec dump_res () =
match conn#get_result with
| Some res ->
(match res#status with
| Tuples_ok | Single_tuple -> show_tuples res
| Copy_out -> show_copy_out conn
| Copy_both -> show_copy_out conn
| Copy_in ->
let name = file_dialog "Choose file to send" in
if name = "" then (
conn#putline "\\.\n";
conn#endcopy)
else
let ic = open_in name in
conn#copy_in_channel ic;
close_in ic
| Empty_query -> print "Empty query\n"
| Command_ok -> print (sprintf "Command ok [%s]\n" res#cmd_status)
| Bad_response ->
print (sprintf "Bad response : %s\n" res#error);
conn#reset
| Nonfatal_error -> print (sprintf "Non fatal error : %s\n" res#error)
| Fatal_error -> print (sprintf "Fatal error : %s\n" res#error));
dump_res ()
| None -> ()
in
let query () =
let buf = text#buffer in
let s = buf#get_text () in
print "-> ";
print s;
print "\n";
buf#delete ~start:buf#start_iter ~stop:buf#end_iter;
conn#send_query s;
dump_res ();
print "======\n";
flush stdout
in
let key_press k =
if GdkEvent.Key.keyval k = GdkKeysyms._KP_Enter then (
query ();
true)
else false
in
let _ = text#event#connect#key_press ~callback:key_press in
let button = GButton.button ~label:"Exec" ~packing:vbox#add () in
let _ = button#connect#clicked ~callback:query in
window#show ();
let window =
GWindow.window ~title:"Backend notifications" ~width:300 ~height:150 ()
in
let _ = window#connect#destroy ~callback:Main.quit in
let vbox = GPack.vbox ~border_width:5 ~packing:window#add () in
let hbox = GPack.hbox ~packing:vbox#add () in
let sb = GRange.scrollbar `VERTICAL ~packing:(hbox#pack ~from:`END) () in
let clist =
GList.clist
~titles:[ "Backend PID"; "Notification" ]
~shadow_type:`OUT ~packing:hbox#add ~vadjustment:sb#adjustment ()
in
let hbox = GPack.hbox ~packing:vbox#pack () in
let button_clear = GButton.button ~label:"Clear" ~packing:hbox#add () in
let _ = button_clear#connect#clicked ~callback:clist#clear in
let button_clear = GButton.button ~label:"Hide" ~packing:hbox#add () in
let _ = button_clear#connect#clicked ~callback:window#misc#hide in
let rec dump_notification () =
match conn#notifies with
| Some { Notification.name; pid; extra } ->
let _ = clist#append [ string_of_int pid; name; extra ] in
window#show ();
dump_notification ()
| None -> ()
in
let _ =
Timeout.add ~ms:100 ~callback:(fun () ->
conn#consume_input;
dump_notification ();
true)
in
Main.main ()
let _ =
try main () with
| Error e -> prerr_endline (string_of_error e)
| e -> prerr_endline (Printexc.to_string e)
|
