File: prompt_gtk.ml

package info (click to toggle)
postgresql-ocaml 1.5.4-2%2Betch1
  • links: PTS
  • area: main
  • in suites: etch
  • size: 320 kB
  • ctags: 536
  • sloc: ml: 1,143; ansic: 524; sh: 118; makefile: 99
file content (169 lines) | stat: -rw-r--r-- 5,263 bytes parent folder | download | duplicates (3)
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
(*
   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#get_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:(vbox#pack ~from:`END) () 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 =
    GEdit.text
      ~packing:hbox#add
      ~vadjustment:sbv#adjustment
      ~hadjustment:sbh#adjustment
      () in

  conn#copy_out (fun s -> txt#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 = GEdit.text ~editable:false ~packing:vbox#add () in
  let text = GEdit.text ~editable:true ~packing:vbox#add ~height:50 () in
  let print s = ignore (result#insert_text s ~pos:result#length) in

  let rec dump_res () =
    match conn#get_result with
    | Some res ->
        (match res#status with
        | Tuples_ok -> show_tuples res
        | Copy_out -> 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 stop = text#length in
    let s = text#get_chars ~start:0 ~stop in
    print "-> "; print s; print "\n";
    text#delete_text ~start:0 ~stop;
    text#set_position 0;
    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 ~height:40 () 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 (msg, pid) ->
        let _ = clist#append [string_of_int pid; msg] 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)