open Printf open Perl let eval use DBI class statement dbh sv object s

  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
open Printf
open Perl
let _ = eval "use DBI"
class statement dbh sv =
object (self)
inherit Dbi.statement dbh
method execute args =
let args = List.map (function
`Null ->
sv_undef ()
| `Int i ->
sv_of_int i
| `Float f ->
sv_of_float f
| `String s ->
sv_of_string s
| `Bool b ->
sv_of_bool b
| _ ->
failwith ("Dbi_perl: unknown argument "^
"type in execute")
) args in
call_method_void sv "execute" args
method fetch1 () =
let avref = call_method sv "fetchrow_arrayref" [] in
if sv_is_undef avref then raise Not_found;
prerr_endline "fetch1 - getting fields";
let fields = list_of_av (deref_array avref) in
prerr_endline "fetch1 - decoding types";
let types = list_of_av (deref_array (hv_get (deref_hash sv) "TYPE")) in
prerr_endline "fetch1 - creating row";
let row = List.map2 (fun sv typ ->
let typ = int_of_sv typ in
prerr_endline ("typ = " ^ string_of_int typ);
prerr_endline ("sv = " ^ string_of_sv sv);
`String (string_of_sv sv)
) fields types in
row
method names =
failwith "Dbi_perl.statement#names: NOT IMPLEMENTED" (* FIXXXME *)
method serial seq =
failwith "sth#serial cannot be implemented for Perl DBD drivers"
method finish () =
call_method_void sv "finish" []
end
and connection ?host ?port ?user ?password database =
(* XXX This should be configurable. *)
let attrs =
let hv = hv_empty () in
hv_set hv "PrintError" (sv_of_int 0);
hv_set hv "RaiseError" (sv_of_int 1);
hv_set hv "AutoCommit" (sv_of_int 0);
hv
in
let args = [sv_of_string database;
sv_of_string (match user with
None -> ""
| Some user -> user);
sv_of_string (match password with
None -> ""
| Some password -> password);
hashref attrs] in
let sv = call_class_method "DBI" "connect" args in
object (self)
inherit Dbi.connection ?host ?port ?user ?password database as super
method host = host
method port = port
method user = user
method password = password
method database = database
method database_type = "perl"
(* This is a very literal mapping of DBI methods. In particular we ignore
* the "closed" flag and debugging, because Perl DBI already supports
* that for us. We also use Perl DBI statement caching.
*)
method prepare query =
let stmt_sv = call_method sv "prepare" [sv_of_string query] in
new statement (self : #Dbi.connection :> Dbi.connection) stmt_sv
method prepare_cached query =
let stmt_sv = call_method sv "prepare_cached" [sv_of_string query] in
new statement (self : #Dbi.connection :> Dbi.connection) stmt_sv
method commit () =
super#commit ();
call_method_void sv "commit" []
method rollback () =
call_method_void sv "rollback" [];
super#rollback ()
method close () =
call_method_void sv "disconnect" [];
super#close ()
method ping () =
bool_of_sv (call_method sv "ping" [])
end
let connect ?host ?port ?user ?password database =
new connection ?host ?port ?user ?password database
let close (dbh : connection) = dbh#close ()
let closed (dbh : connection) = dbh#closed
let commit (dbh : connection) = dbh#commit ()
let ping (dbh : connection) = dbh#ping ()
let rollback (dbh : connection) = dbh#rollback ()