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

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 ()