Commits

Anonymous committed 0fef2aa

moved dbi to amall_dbi library; OCaml 4 compatibility; removed garbage

Comments (0)

Files changed (20)

 (* OASIS_START *)
-(* DO NOT EDIT (digest: 35a954f005f3dec92c035dc30cf6b8b6) *)
+(* DO NOT EDIT (digest: 0e930458ffa103625477b4f5d707a0f4) *)
 
 This is the INSTALL file for the amall distribution.
 
   executable test_websocket_client, executable test_websocket_service
 * iteratees for library amall, executable test_http_service,
   executable test_websocket_client, executable test_websocket_service
-* cadastr for library amall, executable test_http_service,
-  executable test_uri, executable test_websocket_client,
-  executable test_websocket_service
+* cadastr
 * cryptokit for library amall, executable test_http_service,
   executable test_websocket_client, executable test_websocket_service
-* postgresql for library amall_dbi
 
 Installing
 ==========
 (* OASIS_START *)
-(* DO NOT EDIT (digest: fb5bd0c248ddc466cdcfcfb53dcc61ae) *)
+(* DO NOT EDIT (digest: 3addca232f23ee5de9dbe5b7fdba3ace) *)
 
 amall - Amatei OCaml library.
 =============================
 
-Amatei OCaml library with stdlib extensions, database interface, http server
-and websocket client+server implementations based on Iteratees,
-with-combinators (monadic too), module for simple work with files (Filew) and
-so on. Commits made by Dmitry Grebeniuk before July 2013 are sponsored by
-Amatei.
+Amatei OCaml library with stdlib extensions, http server and websocket
+client+server implementations based on Iteratees, with-combinators (monadic
+too), module for simple work with files (Filew) and so on. Commits made by
+Dmitry Grebeniuk before July 2013 are sponsored by Amatei.
 
 See the file [INSTALL.txt](INSTALL.txt) for building and installation
 instructions.
 Plugins: DevFiles (0.2), META (0.2), StdFiles (0.2)
 BuildTools: ocamlbuild
 Description:
-  Amatei OCaml library with stdlib extensions, database interface,
-  http server and websocket client+server implementations based on Iteratees,
-  with-combinators (monadic too), module for simple work with files (Filew)
-  and so on.
+  Amatei OCaml library with stdlib extensions, http server and websocket
+  client+server implementations based on Iteratees, with-combinators
+  (monadic too), module for simple work with files (Filew) and so on.
   Commits made by Dmitry Grebeniuk before July 2013 are sponsored by Amatei.
 
-Flag dbi
-  Description: DBI support
-  Default: true
-
 Library "amall"
   Path: src
   Modules:
     Amall_http_client_common
   BuildDepends: unix, monad_io, monad_io.lwt, iteratees, cadastr, cryptokit
   XMETADescription: Amall library (core)
-
-Library "amall_dbi"
-  Build$: flag(dbi)
-  Install$: flag(dbi)
-  FindlibName: dbi
-  FindlibParent: amall
-  Path: src/dbi
-  Modules:
-    Dbi,
-    Dbi_common,
-    Dbi_pg,
-    Decimal
-  BuildDepends: amall, unix, postgresql, threads
-  XMETADescription: Amall dbi
+  NativeOpt:       -w A-44
+  ByteOpt:         -w A-44
 
 Executable test_uri
   Path: tests
   CompiledObject: best
   MainIs: test_uri.ml
   BuildDepends: cadastr
+  NativeOpt:       -w A-44
+  ByteOpt:         -w A-44
 
 Executable test_http_service
   Path: tests
   CompiledObject: best
   MainIs: test_http_service.ml
   BuildDepends: iteratees, monad_io.lwt, cadastr, cryptokit
+  NativeOpt:       -w A-44
+  ByteOpt:         -w A-44
 
 Executable test_websocket_service
   Path: tests
   CompiledObject: best
   MainIs: test_websocket_service.ml
   BuildDepends: iteratees, monad_io.lwt, cadastr, cryptokit, cadastr.json
+  NativeOpt:       -w A-44
+  ByteOpt:         -w A-44
 
 Executable test_websocket_client
   Path: tests
   CompiledObject: best
   MainIs: test_websocket_client.ml
   BuildDepends: iteratees, monad_io.lwt, cadastr, cryptokit, cadastr.json
+  NativeOpt:       -w A-44
+  ByteOpt:         -w A-44
 
 
 SourceRepository head
 # OASIS_START
-# DO NOT EDIT (digest: e33995d661c9b0e5d16445b4f98c7929)
+# DO NOT EDIT (digest: 824795765414f161233af7f461e84444)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
 "_darcs": not_hygienic
 # Library amall
 "src/amall.cmxs": use_amall
+<src/amall.{cma,cmxa}>: oasis_library_amall_byte
+<src/*.ml{,i}>: oasis_library_amall_byte
+<src/amall.{cma,cmxa}>: oasis_library_amall_native
+<src/*.ml{,i}>: oasis_library_amall_native
 <src/*.ml{,i}>: pkg_cadastr
 <src/*.ml{,i}>: pkg_cryptokit
 <src/*.ml{,i}>: pkg_iteratees
 <src/*.ml{,i}>: pkg_monad_io
 <src/*.ml{,i}>: pkg_monad_io.lwt
 <src/*.ml{,i}>: pkg_unix
-# Library amall_dbi
-"src/dbi/amall_dbi.cmxs": use_amall_dbi
-<src/dbi/*.ml{,i}>: pkg_cadastr
-<src/dbi/*.ml{,i}>: pkg_cryptokit
-<src/dbi/*.ml{,i}>: pkg_iteratees
-<src/dbi/*.ml{,i}>: pkg_monad_io
-<src/dbi/*.ml{,i}>: pkg_monad_io.lwt
-<src/dbi/*.ml{,i}>: pkg_postgresql
-<src/dbi/*.ml{,i}>: pkg_threads
-<src/dbi/*.ml{,i}>: pkg_unix
-<src/dbi/*.ml{,i}>: use_amall
 # Executable test_uri
+<tests/test_uri.{native,byte}>: oasis_executable_test_uri_byte
+<tests/*.ml{,i}>: oasis_executable_test_uri_byte
+<tests/test_uri.{native,byte}>: oasis_executable_test_uri_native
+<tests/*.ml{,i}>: oasis_executable_test_uri_native
 <tests/test_uri.{native,byte}>: pkg_cadastr
 # Executable test_http_service
+<tests/test_http_service.{native,byte}>: oasis_executable_test_http_service_byte
+<tests/*.ml{,i}>: oasis_executable_test_http_service_byte
+<tests/test_http_service.{native,byte}>: oasis_executable_test_http_service_native
+<tests/*.ml{,i}>: oasis_executable_test_http_service_native
 <tests/test_http_service.{native,byte}>: pkg_cadastr
 <tests/test_http_service.{native,byte}>: pkg_cryptokit
 <tests/test_http_service.{native,byte}>: pkg_iteratees
 <tests/test_http_service.{native,byte}>: pkg_monad_io.lwt
 # Executable test_websocket_service
+<tests/test_websocket_service.{native,byte}>: oasis_executable_test_websocket_service_byte
+<tests/*.ml{,i}>: oasis_executable_test_websocket_service_byte
+<tests/test_websocket_service.{native,byte}>: oasis_executable_test_websocket_service_native
+<tests/*.ml{,i}>: oasis_executable_test_websocket_service_native
 <tests/test_websocket_service.{native,byte}>: pkg_cadastr
 <tests/test_websocket_service.{native,byte}>: pkg_cadastr.json
 <tests/test_websocket_service.{native,byte}>: pkg_cryptokit
 <tests/test_websocket_service.{native,byte}>: pkg_iteratees
 <tests/test_websocket_service.{native,byte}>: pkg_monad_io.lwt
 # Executable test_websocket_client
+<tests/test_websocket_client.{native,byte}>: oasis_executable_test_websocket_client_byte
+<tests/*.ml{,i}>: oasis_executable_test_websocket_client_byte
+<tests/test_websocket_client.{native,byte}>: oasis_executable_test_websocket_client_native
+<tests/*.ml{,i}>: oasis_executable_test_websocket_client_native
 <tests/test_websocket_client.{native,byte}>: pkg_cadastr
 <tests/test_websocket_client.{native,byte}>: pkg_cadastr.json
 <tests/test_websocket_client.{native,byte}>: pkg_cryptokit
 <tests/*.ml> : camlp4r
 <src/am_Ops.*> | <src/filename_new.*> | <src/urilex.ml> : -camlp4r, camlp4o
 <src/dbi/decimal.*> : pkg_num
-<**/*> : warn_A
-
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 6b6b139c2f79e8231bd9b4e0c2d193f9) *)
+(* DO NOT EDIT (digest: 632b42edc5b57ea9bdbe9dcd5c176735) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
 open Ocamlbuild_plugin;;
 let package_default =
   {
-     MyOCamlbuildBase.lib_ocaml =
-       [("amall", ["src"], []); ("amall_dbi", ["src/dbi"], [])];
+     MyOCamlbuildBase.lib_ocaml = [("amall", ["src"], [])];
      lib_c = [];
-     flags = [];
-     includes = [("src/dbi", ["src"])]
+     flags =
+       [
+          (["oasis_library_amall_byte"; "ocaml"; "link"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_library_amall_native"; "ocaml"; "link"; "native"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_library_amall_byte"; "ocaml"; "ocamldep"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_library_amall_native"; "ocaml"; "ocamldep"; "native"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_library_amall_byte"; "ocaml"; "compile"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_library_amall_native"; "ocaml"; "compile"; "native"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_byte"; "ocaml"; "link"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_native"; "ocaml"; "link"; "native"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_byte"; "ocaml"; "ocamldep"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_native"; "ocaml"; "ocamldep"; "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_byte"; "ocaml"; "compile"; "byte"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          (["oasis_executable_test_uri_native"; "ocaml"; "compile"; "native"],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_byte";
+              "ocaml";
+              "link";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_native";
+              "ocaml";
+              "link";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_byte";
+              "ocaml";
+              "ocamldep";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_native";
+              "ocaml";
+              "ocamldep";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_byte";
+              "ocaml";
+              "compile";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_http_service_native";
+              "ocaml";
+              "compile";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_byte";
+              "ocaml";
+              "link";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_native";
+              "ocaml";
+              "link";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_byte";
+              "ocaml";
+              "ocamldep";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_native";
+              "ocaml";
+              "ocamldep";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_byte";
+              "ocaml";
+              "compile";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_service_native";
+              "ocaml";
+              "compile";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_byte";
+              "ocaml";
+              "link";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_native";
+              "ocaml";
+              "link";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_byte";
+              "ocaml";
+              "ocamldep";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_native";
+              "ocaml";
+              "ocamldep";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_byte";
+              "ocaml";
+              "compile";
+              "byte"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])]);
+          ([
+              "oasis_executable_test_websocket_client_native";
+              "ocaml";
+              "compile";
+              "native"
+           ],
+            [(OASISExpr.EBool true, S [A "-w"; A "A-44"])])
+       ];
+     includes = []
   }
   ;;
 
 let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
 
-# 609 "myocamlbuild.ml"
+# 761 "myocamlbuild.ml"
 (* OASIS_STOP *)
 Ocamlbuild_plugin.dispatch dispatch_default;;
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: c14a9d64fd77c9476ef5e73b4af6c7cc) *)
+(* DO NOT EDIT (digest: ef13d15e9515bf4c8c4dec9d985926d1) *)
 (*
    Regenerated by OASIS v0.4.4
    Visit http://oasis.forge.ocamlcore.org for more information and
             Some
               [
                  OASISText.Para
-                   "Amatei OCaml library with stdlib extensions, database interface, http server and websocket client+server implementations based on Iteratees, with-combinators (monadic too), module for simple work with files (Filew) and so on. Commits made by Dmitry Grebeniuk before July 2013 are sponsored by Amatei."
+                   "Amatei OCaml library with stdlib extensions, http server and websocket client+server implementations based on Iteratees, with-combinators (monadic too), module for simple work with files (Filew) and so on. Commits made by Dmitry Grebeniuk before July 2013 are sponsored by Amatei."
               ];
           categories = [];
           conf_type = (`Configure, "internal", Some "0.4");
           files_ab = [];
           sections =
             [
-               Flag
-                 ({
-                     cs_name = "dbi";
-                     cs_data = PropList.Data.create ();
-                     cs_plugin_data = []
-                  },
-                   {
-                      flag_description = Some "DBI support";
-                      flag_default = [(OASISExpr.EBool true, true)]
-                   });
                Library
                  ({
                      cs_name = "amall";
                       bs_cclib = [(OASISExpr.EBool true, [])];
                       bs_dlllib = [(OASISExpr.EBool true, [])];
                       bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                      bs_byteopt = [(OASISExpr.EBool true, ["-w"; "A-44"])];
+                      bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "A-44"])]
                    },
                    {
                       lib_modules =
                       lib_findlib_name = None;
                       lib_findlib_containers = []
                    });
-               Library
-                 ({
-                     cs_name = "amall_dbi";
-                     cs_data = PropList.Data.create ();
-                     cs_plugin_data = []
-                  },
-                   {
-                      bs_build =
-                        [
-                           (OASISExpr.EBool true, false);
-                           (OASISExpr.EFlag "dbi", true)
-                        ];
-                      bs_install =
-                        [
-                           (OASISExpr.EBool true, false);
-                           (OASISExpr.EFlag "dbi", true)
-                        ];
-                      bs_path = "src/dbi";
-                      bs_compiled_object = Best;
-                      bs_build_depends =
-                        [
-                           InternalLibrary "amall";
-                           FindlibPackage ("unix", None);
-                           FindlibPackage ("postgresql", None);
-                           FindlibPackage ("threads", None)
-                        ];
-                      bs_build_tools = [ExternalTool "ocamlbuild"];
-                      bs_c_sources = [];
-                      bs_data_files = [];
-                      bs_ccopt = [(OASISExpr.EBool true, [])];
-                      bs_cclib = [(OASISExpr.EBool true, [])];
-                      bs_dlllib = [(OASISExpr.EBool true, [])];
-                      bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
-                   },
-                   {
-                      lib_modules = ["Dbi"; "Dbi_common"; "Dbi_pg"; "Decimal"];
-                      lib_pack = false;
-                      lib_internal_modules = [];
-                      lib_findlib_parent = Some "amall";
-                      lib_findlib_name = Some "dbi";
-                      lib_findlib_containers = []
-                   });
                Executable
                  ({
                      cs_name = "test_uri";
                       bs_cclib = [(OASISExpr.EBool true, [])];
                       bs_dlllib = [(OASISExpr.EBool true, [])];
                       bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                      bs_byteopt = [(OASISExpr.EBool true, ["-w"; "A-44"])];
+                      bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "A-44"])]
                    },
                    {exec_custom = false; exec_main_is = "test_uri.ml"});
                Executable
                       bs_cclib = [(OASISExpr.EBool true, [])];
                       bs_dlllib = [(OASISExpr.EBool true, [])];
                       bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                      bs_byteopt = [(OASISExpr.EBool true, ["-w"; "A-44"])];
+                      bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "A-44"])]
                    },
                    {
                       exec_custom = false;
                       bs_cclib = [(OASISExpr.EBool true, [])];
                       bs_dlllib = [(OASISExpr.EBool true, [])];
                       bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                      bs_byteopt = [(OASISExpr.EBool true, ["-w"; "A-44"])];
+                      bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "A-44"])]
                    },
                    {
                       exec_custom = false;
                       bs_cclib = [(OASISExpr.EBool true, [])];
                       bs_dlllib = [(OASISExpr.EBool true, [])];
                       bs_dllpath = [(OASISExpr.EBool true, [])];
-                      bs_byteopt = [(OASISExpr.EBool true, [])];
-                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                      bs_byteopt = [(OASISExpr.EBool true, ["-w"; "A-44"])];
+                      bs_nativeopt = [(OASISExpr.EBool true, ["-w"; "A-44"])]
                    },
                    {
                       exec_custom = false;
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.4";
-     oasis_digest = Some "\131\150\131S\012$\214)\204\017\167\r>\018y\141";
+     oasis_digest =
+       Some "\224\174\028E\139\185\148G\022\219\015B2\236\255\188";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 6980 "setup.ml"
+# 6927 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;
 # OASIS_START
-# DO NOT EDIT (digest: 886b505849c8f90b9154643b9cb3ea94)
+# DO NOT EDIT (digest: 0b9c0aeefe59a0ea8daae9ebebe923a2)
 version = "0.1.0"
 description = "Amall library (core)"
 requires = "unix monad_io monad_io.lwt iteratees cadastr cryptokit"
 archive(native) = "amall.cmxa"
 archive(native, plugin) = "amall.cmxs"
 exists_if = "amall.cma"
-package "dbi" (
- version = "0.1.0"
- description = "Amall dbi"
- requires = "amall unix postgresql threads"
- archive(byte) = "amall_dbi.cma"
- archive(byte, plugin) = "amall_dbi.cma"
- archive(native) = "amall_dbi.cmxa"
- archive(native, plugin) = "amall_dbi.cmxs"
- exists_if = "amall_dbi.cma"
-)
 # OASIS_STOP
 

src/amall_http_server.ml

 open Amall_types;
-open Am_Ops;
-open Printf;
 open Amall_http;
 open Cd_All;
 open Strings.Latin1;
 type http_server_func = request -> I.iteratee char response
 ;
 
-value (runA : IO.m (I.iteratee 'el 'a) -> It_Types.res 'a) i =
-  IO.runIO (i >>% I.run)
-;
-
-value rec printexc e =
-  match e with
-  [ I.Iteratees_err_msg e -> printexc e
-  | _ -> Printexc.to_string e
-  ]
-;
-
 (*
 value _dump_chars_chunks title =
   I.ie_cont step

src/amall_http_service.ml

       root_http_disp_level
       root_ws_disp_level
     = fun rq ->
-      let open Amall_http in
       let uri = rq.rq_uri in
       match uri.scheme with
       [ None -> invalid_arg "S.server_func: no scheme in uri"

src/dbi/amall_dbi.mldylib

-# OASIS_START
-# DO NOT EDIT (digest: cede494cbb17f4c02b999af468fdd7f8)
-Dbi
-Dbi_common
-Dbi_pg
-Decimal
-# OASIS_STOP

src/dbi/amall_dbi.mllib

-# OASIS_START
-# DO NOT EDIT (digest: cede494cbb17f4c02b999af468fdd7f8)
-Dbi
-Dbi_common
-Dbi_pg
-Decimal
-# OASIS_STOP

src/dbi/dbi.ml

-    open Am_Ops
-    ;
-
-    type sql_t =
-      [= `Null
-      |  `String of string
-      |  `Binary of string
-      ]
-    ;
-
-    type dbd_error = exn
-    ;
-
-    type dbi_error = (dbd_error * (dbd_error -> string))
-    ;
-
-    exception Edbi of dbi_error
-    ;
-
-    exception EGeneric of string
-    ;
-
-    exception Ecolumn of string
-    ;
-
-    exception Econnection_closed of string
-    ;
-
-    value (string_of_dbi_error : dbi_error -> string) (dbd_error, to_string) =
-      to_string dbd_error
-    ;
-
-    value () = Printexc.register_printer
-      (fun [ Edbi (err, to_string) -> Some ("Edbi: " ^ to_string err)
-           | _ -> None
-           ])
-    ;
-
-    exception End_of_result
-    ;
-
-    open Printf
-    ;
-
-    value string_of_exn = fun
-      [ Edbi e -> sprintf "database error: %s" &
-          string_of_dbi_error e
-      | e -> sprintf "non-database error: %s" &
-          Printexc.to_string e
-      ]
-    ;
-
-    value (error : dbi_error -> 'a) e =
-      raise & Edbi e
-    ;
-
-    value error_gen msg =
-      error &
-      ( EGeneric msg
-      , fun [ EGeneric msg -> msg | _ -> assert False ]
-      )
-    ;
-
-    value error_eor () =
-      error &
-      ( End_of_result
-      , fun [ End_of_result -> "end of result set" | _ -> assert False ]
-      )
-    ;
-
-    value error_column msg =
-      error &
-      ( Ecolumn msg
-      , fun [ Ecolumn msg -> msg | _ -> assert False ]
-      )
-    ;
-
-    value error_connection_closed backend =
-      error &
-      ( Econnection_closed backend
-      , fun [ Econnection_closed b -> sprintf
-                "connection to database is closed (backend: %s)"
-                b
-            | _ -> assert False
-            ]
-      )
-    ;
-
-
-    class virtual conn_info ?host ?port ?dbname ?user ?password () =
-      object
-        method host : option string = host;
-        method port : option string = port;
-        method dbname : option string = dbname;
-        method user : option string = user;
-        method password : option string = password;
-      end
-    ;
-
-
-(* pg's:
-    type result_status =
-      [ Empty_query     (** (err) String sent to the backend was empty *)
-      | Command_ok      (** (ok) Successful completion of a command returning no data *)
-      | Tuples_ok       (** (ok) The query successfully executed *)
-      | Copy_out        (** (err) Copy Out (from server) data transfer started *)
-      | Copy_in         (** (err) Copy In (to server) data transfer started *)
-      | Bad_response    (** (err) The server's response was not understood *)
-      | Err Nonfatal_error  (* (err) *)
-      | Err Fatal_error     (* (err) *)
-      ]
-    ;
-*)
-
-    (* result_status compatible with Res.res *)
-    type result_status =
-      [= `Ok of ok_result_status
-      |  `Error of exn
-      ]
-    and ok_result_status =
-      [= `Cmd
-      |  `Data
-      ]
-    ;
-
-
-    (* no {co,contra}variances because of arrays of 'v and 'p. *)
-
-    class virtual result_data =
-      object (_self)
-        method virtual status : result_status;
-
-        method virtual ncols : int;
-        method virtual names : array string;
-        method virtual nrows : option int;  (* None for stream-fetching  *)
-        method virtual affected : string;  (* for >2^30 rows maybe? *)
-
-(*
-        method fetchrow_array () : array 'v =
-          Array.of_list (self#fetchrow_list ());
-        method fetchrow_list () : list 'v =
-          Array.to_list (self#fetchrow_array ());
-
-        method virtual current_nrow : int;
-        method virtual is_eor : bool;
-
-        (* true if there is a next row *)
-        method virtual next_row : unit -> bool;
-
-        method fetchrow_array_opt () : option (array 'v) =
-          try Some (self#fetchrow_array ())
-          with [ End_of_result -> None ]
-        ;
-
-        method fetchall_list_of_lists : list (list 'v) =
-        method fetchall_array_of_lists : array (list 'v) =
-        method fetchall_list_of_arrays : list (array 'v) =
-        method fetchall_array_of_arrays : array (array 'v) =
-
-        method fold_row_arrays
-          : ! 'a . ('a -> array 'v -> 'a) -> 'a -> 'a
-          = fun func init ->
-            if self#is_eor
-            then init
-            else
-              inner init
-              where rec inner acc =
-                match self#fetchrow_array_opt () with
-                [ None -> acc
-                | Some row -> inner (func acc row)
-                ]
-        ;
-*)
-
-      end
-    ;
-
-
-    class virtual result_cmd =
-      object (_self)
-        method virtual affected : string;
-      end
-    ;
-
-
-(*
-    type result =
-      [= `Error of exn
-      |  `Data of #result_data
-      |  `Cmd of #result_cmd
-      ]
-    ;
-*)
-
-    value fold_result func init res =
-      if res#is_eor
-      then init
-      else
-        inner init
-        where rec inner init =
-          (* let () = Printf.printf "fold_res: row=%i\n" res#current_nrow in *)
-          let new_acc = func init res in
-          if res#next_row ()
-          then
-            inner new_acc
-          else
-            new_acc
-    ;
-
-
-(*
-    use res#map_to_list
-
-    value map_result_to_list func res =
-      List.rev &
-      fold_result
-        (fun rev_acc res ->
-           [(func res) :: rev_acc]
-        )
-        []
-        res
-    ;
-*)
-
-
-(*
-    class virtual connection ['v, 'p, 'stmt, 'res] (conn_info : conn_info)
-     =
-      object (self)
-
-        constraint 'res = #result 'v;
-        constraint 'stmt = #statement 'v 'p (#result 'v);
-
-
-        method virtual disconnect : unit -> unit;
-
-        method virtual start : unit -> unit;
-        method virtual commit : unit -> unit;
-        method virtual rollback : unit -> unit;
-
-        method virtual prepare : string -> 'stmt;
-
-        (* there could be "execute without prepare": *)
-        method execute
-          (sql : string)
-          : 'res
-          =
-            (self#prepare sql)#execute ()
-        ;
-
-        (* there could be "execute_p without prepare": *)
-        method execute_p
-          (sql : string)
-          (params : array 'p)
-          : 'res
-          =
-            (self#prepare sql)#execute_p params
-        ;
-
-        method virtual quote : string -> string;
-        method virtual quote_ident : string -> string;
-
-        (* . *)
-
-        (* method ping () = (); *)
-      end
-
-    and virtual statement ['v, 'p, 'res] =
-      object
-
-        constraint 'res = #result 'v;
-
-
-        method virtual execute : unit -> 'res;
-
-        method virtual execute_p : array 'p -> 'res;
-
-      end
-    ;
-*)
-
-
-    open Res;
-
-
-    exception Execute_ok of string
-    ;
-
-    value execute_ok conn cmd =
-      let error msg = error_gen &
-        sprintf "expected success while executing %S, but %s" cmd msg
-      in
-      match conn#execute cmd with
-      [ `Cmd _ -> ()
-      | `Data _ -> error "data returned"
-      | `Error e -> error & sprintf "occured a %s" & string_of_exn e
-      ]
-    ;

src/dbi/dbi_common.ml

-value failwith fmt = Printf.ksprintf failwith fmt
-;
-
-external identity : 'a -> 'a = "%identity"
-;
-
-
-module Af
- =
-  struct
-    type af 'x 'a = 'x -> 'a;
-    value pure = fun _ -> identity;
-    value ( <*> ) fab fa = fun x -> (fab x) (fa x);
-    value ( <$> ) ab fa = (pure ab) <*> fa;
-    value run af x = af x;
-  end
-;
-
-module Af2
- =
-  struct
-    open Af;
-    type af2 'x 'y 'a = af 'x (af 'y 'a);
-    value pure x : af2 _ _ _ = fun _ -> fun _ -> x;
-    value (( <*> ) : af2 'x 'y ('a -> 'b) -> af2 'x 'y 'a -> af2 'x 'y 'b)
-      ffab ffa =
-        fun x ->
-          let fab = ffab x
-          and fa = ffa x in
-          fun y ->
-            (fab y) (fa y)
-    ;
-    value ( <$> ) ab fa = (pure ab) <*> fa;
-    value (run1 : af2 'x 'y 'a -> 'x -> af 'y 'a) af2 x = af2 x;
-    value (run2 : af2 'x 'y 'a -> 'x -> 'y -> 'a) af2 x y = af2 x y;
-  end
-;

src/dbi/dbi_pg.ml

-open Am_All;
-open Dbi_common;
-
-module P = Postgresql;
-
-
-
-type sql_u =
-  [= `Null
-  |  `String of string
-  |  `Binary of string
-  ]
-;
-
-
-type timestamptz = string
-;
-
-
-type sql_t =
-  [= sql_u
-
-  |  `Void
-
-  |  `Bool of bool
-  |  `Int of int      (* smallint *)
-  |  `Int32 of int32  (* int, serial *)
-  |  `Int64 of int64  (* bigint, bigserial *)
-  |  `Num of Decimal.t  (* numeric, decimal *)
-
-  |  `Date of string
-  |  `Time of string
-  |  `TimeTZ of string
-  |  `Timestamp of string
-  |  `TimestampTZ of timestamptz
-  ]
-;
-
-
-type ident = string
-;
-
-type colnum = int
-;
-
-type rownum = int
-;
-
-type record =
-  { rres : P.result
-  ; rrow : rownum
-  }
-;
-
-type record_type = P.result
-;
-
-type field_type = P.ftype
-;
-
-exception Efield of string
-;
-
-(* Etype of "expected type" and "got (type|null)" *)
-exception Etype of string and string
-;
-
-type uncomp_getter 'a = Af2.af2 record_type record 'a
-;
-
-type comp_getter 'a = Af.af record 'a
-;
-
-type comp_typer 'a = int -> comp_getter 'a
-;
-
-type c_typeerror_wanted = [ CTW_Null | CTW_Not_null ]
-;
-
-type comp_typer2 'a =
-  { c_notnull : comp_typer 'a
-  ; c_nullable : comp_typer (option 'a)
-  ; c_typeerror : c_typeerror_wanted -> ~got:string -> unit
-  }
-;
-
-(*
-type result_status =
-  [= `Ok of [= `Cmd | `Data ]
-  |  `Error of exn
-  ]
-;
-*)
-
-
-module G
- =
-  struct
-
-    value string x = x
-    ;
-
-    value number pres ~col =
-      let fmod = pres#fmod col in
-      if fmod = -1 then failwith "number: fmod = -1  =>  heeeelp!" else
-      let (* _total_digits = (fmod lsr 16) land 0xFFFF
-      and *) after_point_digits_4 = fmod land 0xFFFF in
-      let scale = after_point_digits_4 - 4 in
-      (* let () = failwith "WC.number: str=%S, scale=%i" str scale in *)
-      fun str -> Decimal.of_string_scale str scale
-    ;
-
-    value int64 str =
-      try
-        Int64.of_string str
-      with
-      [ Failure "int_of_string" -> raise (Etype "int64" str)
-      ]
-    ;
-
-    value int32 str =
-      try
-        Int32.of_string str
-      with
-      [ Failure "int_of_string" -> raise (Etype "int32" str)
-      ]
-    ;
-
-    value int ty str =
-      try
-        int_of_string str
-      with
-      [ Failure "int_of_string" -> raise (Etype ty str)
-      ]
-    ;
-
-    value bool str =
-      match str with
-      [ "t" -> True
-      | "f" -> False
-      | _ -> failwith "Dbi_pg: expected bool (t/f), found %S" str
-      ]
-    ;
-
-  end
-;
-
-
-module C
- :
-  sig
-    value string : comp_typer2 string;
-    value number : comp_typer2 Decimal.t;
-    value int64 : comp_typer2 int64;
-    value timestamptz : comp_typer2 timestamptz;
-    value bool : comp_typer2 bool;
-  end
- =
-  struct
-
-    value common get_it ~want_ftype =
-      let want_ftype_notnull = want_ftype ^ " (not null)" in
-      let typeerror ctw ~got =
-        raise
-          (Etype
-             (match ctw with
-              [ CTW_Null -> want_ftype
-              | CTW_Not_null -> want_ftype_notnull
-              ]
-             )
-             got
-          )
-      in
-        { c_notnull = fun col -> fun record ->
-            let pres = record.rres
-            and row = record.rrow in
-            if pres#getisnull row col
-            then
-              typeerror CTW_Not_null ~got:"NULL"
-            else
-              get_it pres ~row ~col
-        ; c_nullable = fun col -> fun record ->
-            let pres = record.rres
-            and row = record.rrow in
-            if pres#getisnull row col
-            then
-              None
-            else
-              Some (get_it pres ~row ~col)
-        ; c_typeerror = typeerror
-        }
-    ;
-
-    value get_as_string pres ~row ~col =
-      G.string (pres#getvalue row col)
-    ;
-
-    value string = common
-      ~want_ftype:"string"
-      get_as_string
-    ;
-
-    value number = common
-      ~want_ftype:"number (numeric, decimal)"
-      (fun pres ~row ~col ->
-         G.number pres ~col (pres#getvalue row col)
-      )
-    ;
-
-    value int64 = common
-      ~want_ftype:"int64 (bigint, bigserial)"
-      (fun pres ~row ~col ->
-         G.int64 (pres#getvalue row col)
-      )
-    ;
-
-    value timestamptz = common
-      ~want_ftype:"timestamp with time zone"
-      get_as_string
-    ;
-
-    value bool = common
-      ~want_ftype:"boolean"
-      (fun pres ~row ~col ->
-         G.bool (pres#getvalue row col)
-      )
-    ;
-
-  end
-;
-
-
-value ( ( <*> ) :
-  uncomp_getter ('a -> 'b) ->
-  uncomp_getter 'a ->
-  uncomp_getter 'b
-  ) = Af2.( ( <*> ) )
-;
-
-value ( ( <$> ) :
-  ('a -> 'b) ->
-  uncomp_getter 'a ->
-  uncomp_getter 'b
-  ) = Af2.( ( <$> ) )
-;
-
-value pure = Af2.pure
-;
-
-
-value get_index record_type ident =
-  try
-    record_type#fnumber ident
-  with
-  [ Not_found ->
-      raise (Efield (sprintf "by name: %s" ident))
-  ]
-;
-
-
-value check_index record_type index =
-  if index < 0 || index >= record_type#nfields
-  then
-    raise (Efield (sprintf "by index: %i" index))
-  else
-    index
-;
-
-
-type uncomp_typer2 'a =
-  { utn : ident -> uncomp_getter 'a
-  ; utno : ident -> uncomp_getter (option 'a)
-  ; uti : int -> uncomp_getter 'a
-  ; utio : int -> uncomp_getter (option 'a)
-  }
-;
-
-value common compiled ~check_ftype =
-  let
-    { c_notnull = c_notnull
-    ; c_nullable = c_nullable
-    ; c_typeerror = c_typeerror
-    } =
-        compiled
-  in
-  let check_ty ctw record_type index =
-    let ty = record_type#ftype index in
-    if not (check_ftype ty)
-    then
-      c_typeerror ctw ~got:(P.string_of_ftype ty)
-    else
-      ()
-  in
-  { utn = fun ident -> fun record_type ->
-      let index = get_index record_type ident in
-      ( check_ty CTW_Not_null record_type index
-      ; c_notnull index
-      )
-  ; utno = fun ident -> fun record_type ->
-      let index = get_index record_type ident in
-      ( check_ty CTW_Null record_type index
-      ; c_nullable index
-      )
-
-  ; uti = fun index -> fun record_type ->
-      let index = check_index record_type index in
-      ( check_ty CTW_Not_null record_type index
-      ; c_notnull index
-      )
-  ; utio = fun index -> fun record_type ->
-      let index = check_index record_type index in
-      ( check_ty CTW_Null record_type index
-      ; c_nullable index
-      )
-  }
-;
-
-value string_check ftype =
-  ftype = P.CHAR || ftype = P.TEXT || ftype = P.NAME || ftype = P.VARCHAR
-(*
-  match ftype with
-  [ P.CHAR | P.TEXT | P.NAME | P.VARCHAR -> True
-  | _ -> False
-  ]
-*)
-;
-
-
-
-(**************************************************************************)
-
-value
-  { utn = nstring ; utno = nstring_opt
-  ; uti = istring ; utio = istring_opt
-  } =
-  common C.string ~check_ftype: string_check
-;
-
-value
-  { utn = nnumber ; utno = nnumber_opt
-  ; uti = inumber ; utio = inumber_opt
-  } =
-  common C.number ~check_ftype: ( (=) P.NUMERIC )
-;
-
-value
-  { utn = nint64 ; utno = nint64_opt
-  ; uti = iint64 ; utio = iint64_opt
-  } =
-  common C.int64 ~check_ftype: ( (=) P.INT8 )
-;
-
-value
-  { utn = ntimestamptz ; utno = ntimestamptz_opt
-  ; uti = itimestamptz ; utio = itimestamptz_opt
-  } =
-  common C.timestamptz ~check_ftype: ( (=) P.TIMESTAMPTZ )
-;
-
-value
-  { utn = nbool ; utno = nbool_opt
-  ; uti = ibool ; utio = ibool_opt
-  } =
-  common C.bool ~check_ftype: ( (=) P.BOOL )
-;
-
-
-
-(*
-value (sql_t : record -> ~col:int -> sql_t) record ~col =
-  let pres = record.rres in
-  let row = record.rrow in
-  if pres#getisnull row col
-  then `Null
-  else
-    match record.rres#ftype col with
-    [ P.CHAR | P.TEXT | P.NAME | P.VARCHAR ->
-        `String (WC.string.c_notnull col record)
-(*
-    | P.BYTEA -> `Binary x
-    | P.INT8 -> `Int64 (Int64.of_string x)
-    | P.INT2 -> `Int (int_of_string x)
-    | P.INT4 -> `Int32 (Int32.of_string x)
-    | P.NUMERIC -> `Num ( (*Num.num_of_string x*) raise Exit )
-    | P.VARCHAR -> `String x
-    | P.DATE -> `Date x
-    | P.TIME -> `Time x
-    | P.TIMESTAMP -> `Timestamp x
-    | P.TIMESTAMPTZ -> `TimestampTZ x
-    | P.TIMETZ -> `TimeTZ x
-    | P.BOOL -> `Bool
-        (match x with
-         [ "t" -> True | "f" -> False
-         | _ -> failwith "bad boolean" ])
-*)
-    | P.BYTEA
-    | P.CHAR
-    | P.INT8
-    | P.INT2
-    | P.INT4
-    | P.TEXT
-    | P.NAME
-    | P.NUMERIC
-    | P.VARCHAR
-    | P.DATE
-    | P.TIME
-    | P.TIMESTAMP
-    | P.TIMESTAMPTZ
-    | P.TIMETZ
-    | P.BOOL
-
-    | P.FLOAT8
-    | P.INT2VECTOR
-    | P.REGPROC
-    | P.OID
-    | P.TID
-    | P.XID
-    | P.CID
-    | P.OIDVECTOR
-    | P.POINT
-    | P.LSEG
-    | P.PATH
-    | P.BOX
-    | P.POLYGON
-    | P.LINE
-    | P.FLOAT4
-    | P.ABSTIME
-    | P.RELTIME
-    | P.TINTERVAL
-    | P.UNKNOWN
-    | P.CIRCLE
-    | P.CASH
-    | P.MACADDR
-    | P.INET
-    | P.CIDR
-    | P.ACLITEM
-    | P.BPCHAR
-    | P.INTERVAL
-    | P.BIT
-    | P.VARBIT
-    | P.ANYELEMENT
-    | P.OPAQUE
-    | P.INTERNAL
-    | P.LANGUAGE_HANDLER
-    | P.TRIGGER
-    | P.VOID
-    | P.ANYARRAY
-    | P.ANY
-    | P.CSTRING
-    | P.RECORD
-    | P.REGTYPE
-    | P.REGCLASS
-    | P.REGOPERATOR
-    | P.REGOPER
-    | P.REGPROCEDURE
-    | P.REFCURSOR
-
-        as ty -> raise (Etype "get_t-supported" (P.string_of_ftype ty))
-    ]
-;
-*)
-
-(**************************************************************************)
-
-
-
-value (compile_getter : record_type -> uncomp_getter 'a -> comp_getter 'a)
-  rt ucg = Af2.run1 ucg rt
-;
-
-
-
-(**********************************************************************)
-
-
-value nvl opt_new old =
-  match opt_new with
-  [ None -> old
-  | Some the_new -> the_new
-  ]
-;
-
-
-class conn_info
-  ?host ?port ?dbname ?user ?password
-  ?options ?requiressl ?tty
-  ?conninfo
-  ()
- =
-  object (self)
-    inherit Dbi.conn_info ?host ?port ?dbname ?user ?password ();
-
-    method options : option string = options;
-    method conninfo : option string = conninfo;
-    method requiressl : option string = requiressl;
-    method tty : option string = tty;
-
-    method copy
-      ?host ?port ?dbname ?user ?password
-      ?options ?requiressl ?tty
-      ?conninfo
-      ()
-     =
-      new conn_info
-        ?host:(nvl host self#host)
-        ?port:(nvl port self#port)
-        ?dbname:(nvl dbname self#dbname)
-        ?user:(nvl user self#user)
-        ?password:(nvl password self#password)
-        ?options:(nvl options self#options)
-        ?requiressl:(nvl requiressl self#requiressl)
-        ?tty:(nvl tty self#tty)
-        ?conninfo:(nvl conninfo self#conninfo)
-        ()
-    ;
-
-  end
-;
-
-
-open Printf
-;
-
-open Am_Ops
-;
-
-exception Edbi = Dbi.Edbi
-;
-
-exception Prepare of string;
-exception Bad_result_status of P.result_status;
-exception Error_status of P.result_status and string;
-exception Type_error of string and string;  (* typename and error *)
-
-value string_of_dbd_error e =
-  match e with
-  [ P.Error error -> P.string_of_error error
-  | Prepare msg -> msg
-  | Bad_result_status rs -> "Bad result_status: " ^ P.result_status rs
-  | Error_status rs msg ->
-      sprintf "Error: %s: %s"
-        (P.result_status rs)
-        msg
-  | Type_error tyname msg ->
-      sprintf "Dbi_pg: error with type %S: %s" tyname msg
-  | e ->   "Not a postgresql exception: "
-         ^ Printexc.to_string e
-         ^ "  (why is it here? possible internal error.)"
-  ]
-;
-
-
-value (error : exn -> exn) e =
-  Dbi.error (e, string_of_dbd_error)
-;
-
-value (perror : P.error -> exn) e = error & P.Error e
-;
-
-value (prepare_error : string -> exn) msg = error & Prepare msg
-;
-
-value (bad_result_status : P.result_status -> exn) rs =
-  error & Bad_result_status rs
-;
-
-value (error_status : P.result_status -> string -> exn) rs msg =
-  error & Error_status rs msg
-;
-
-value error_type tyname msg =
-  error & Type_error tyname msg
-;
-
-value (error_type_not_sup : string -> exn) tyname =
-  error_type tyname "not supported by bindings"
-;
-
-value error_type_conv tyname v msg =
-  error_type tyname & sprintf "can't convert %S to this type: %s" v msg
-;
-
-
-(* засёк, 5 минут времени ровно. *)
-
-value dump_sql_u = fun
-  [  `Null -> "NULL"
-  |  `String x -> sprintf "String %S" x
-  |  `Binary x -> sprintf "Binary %S" x
-  ]
-;
-
-value dump_sql_t = fun
-  [  #sql_u as u -> dump_sql_u u
-  |  `Bool x -> sprintf "Bool %b" x
-  |  `Int x -> sprintf "Int %i" x
-  |  `Int32 x -> sprintf "Int32 %li" x
-  |  `Int64 x -> sprintf "Int64 %Li" x
-  |  `Num x -> sprintf "Num %s" (Decimal.to_string x)
-  |  `Date x -> sprintf "Date %S" x
-  |  `Time x -> sprintf "Time %S" x
-  |  `TimeTZ x -> sprintf "TimeTZ %S" x
-  |  `Timestamp x -> sprintf "Timestamp %S" x
-  |  `TimestampTZ x -> sprintf "TimestampTZ %S" x
-  ]
-;
-
-
-value error_type_get tyname v =
-  error_type tyname & sprintf "can't res#get_%s, column has value %s"
-    tyname (dump_sql_t v)
-;
-
-
-value string_of_dbi_error = Dbi.string_of_dbi_error
-;
-
-
-value ok_cmd = `Ok `Cmd
-  and ok_data = `Ok `Data
-;
-
-
-(*
-type ident = string
-;
-
-
-type record_signature = P.result
-;
-
-
-type record =
-  { rres : P.result
-  ; rrow : int
-  }
-;
-
-
-type colnum = int
-;
-
-
-type typer 'a 'r = record -> colnum -> ('a -> 'r) -> 'r
-;
-*)
-
-
-(*
-value entype_t' _presult _row _col : sql_t =
- let ftype = raise Exit and x = raise Exit and isnull = raise Exit in
-  try
-    let () = dbg "entype: %s = %S (is null = %b)"
-      (P.string_of_ftype ftype) x isnull
-    in
-    if isnull then `Null else
-    match ftype with
-    [ P.BYTEA -> `Binary x
-    | P.CHAR -> `String x
-    | P.INT8 -> `Int64 (Int64.of_string x)
-    | P.INT2 -> `Int (int_of_string x)
-    | P.INT4 -> `Int32 (Int32.of_string x)
-    | P.TEXT -> `String x
-    | P.NAME -> `String x
-    | P.NUMERIC -> `Num ( (*Num.num_of_string x*) raise Exit )
-    | P.VARCHAR -> `String x
-    | P.DATE -> `Date x
-    | P.TIME -> `Time x
-    | P.TIMESTAMP -> `Timestamp x
-    | P.TIMESTAMPTZ -> `TimestampTZ x
-    | P.TIMETZ -> `TimeTZ x
-    | P.BOOL -> `Bool
-        (match x with
-         [ "t" -> True | "f" -> False
-         | _ -> failwith "bad boolean"
-         ]
-        )
-    | P.VOID -> `Void
-
-    | P.FLOAT8
-    | P.INT2VECTOR
-    | P.REGPROC
-    | P.OID
-    | P.TID
-    | P.XID
-    | P.CID
-    | P.OIDVECTOR
-    | P.POINT
-    | P.LSEG
-    | P.PATH
-    | P.BOX
-    | P.POLYGON
-    | P.LINE
-    | P.FLOAT4
-    | P.ABSTIME
-    | P.RELTIME
-    | P.TINTERVAL
-    | P.UNKNOWN
-    | P.CIRCLE
-    | P.CASH
-    | P.MACADDR
-    | P.INET
-    | P.CIDR
-    | P.ACLITEM
-    | P.BPCHAR
-    | P.INTERVAL
-    | P.BIT
-    | P.VARBIT
-    | P.ANYELEMENT
-    | P.OPAQUE
-    | P.INTERNAL
-    | P.LANGUAGE_HANDLER
-    | P.TRIGGER
-    | P.ANYARRAY
-    | P.ANY
-    | P.CSTRING
-    | P.RECORD
-    | P.REGTYPE
-    | P.REGCLASS
-    | P.REGOPERATOR
-    | P.REGOPER
-    | P.REGPROCEDURE
-    | P.REFCURSOR
-        as ftype
-        -> raise & error_type_not_sup & P.string_of_ftype ftype
-    ]
-  with
-  [ (Type_error _ _) as te -> raise te
-  | e -> raise & error_type_conv (P.string_of_ftype ftype) x &
-           Printexc.to_string e
-  ]
-;
-
-
-*)
-
-value detype_t (v : sql_t) : sql_u =
-  match v with
-  [ (`Binary _) | (`String _) | `Null
-      as v -> v
-
-  | ( `Date x | `Time x | `Timestamp x
-    | `TimestampTZ x | `TimeTZ x
-    )
-      -> `String x
-
-  | `Void ->
-      `String ""
-         (* http://comments.gmane.org/gmane.comp.db.postgresql.
-            devel.general/161403 *)
-
-  | `Int64 i -> `String (Int64.to_string i)
-  | `Int i -> `String (string_of_int i)
-  | `Int32 i -> `String (Int32.to_string i)
-  | `Num n -> `String (Decimal.to_string n)
-  | `Bool b -> if b then `String "t" else `String "f"
-  ]
-;
-
-
-
-
-value memo_last ?(cmp=Pervasives.compare) f =
-  let last = ref None in
-  fun x ->
-    let recalc x =
-      let v = f x in
-      ( last.val := Some (x, v)
-      ; v
-      )
-    in
-    match last.val with
-    [ None -> recalc x
-    | Some (last_x, last_res) ->
-        if cmp last_x x = 0
-        then last_res
-        else recalc x
-    ]
-;
-
-
-exception Pg_result_data of P.result
-;
-
-
-class result_data
-  (presult : P.result) =
-  let names_lazy = lazy presult#get_fnames in
-  let nrows = presult#ntuples in
-  let some_nrows = Some nrows in
-  object (self)
-(*
-    inherit Dbi.result ['v];
-*)
-
-    method downcast : unit = raise (Pg_result_data presult);
-
-    value mutable v_current_nrow = 0;
-
-    method nrows = some_nrows;
-    method names = Lazy.force names_lazy;
-    method ncols = presult#nfields;
-
-(*
-    method enum_records it =
-      .
-    ;
-*)
-
-(*
-    method current_nrow = v_current_nrow;
-    method current_row = memd_row v_current_nrow
-    ;
-    method is_eor = (v_current_nrow >= presult#ntuples)
-    ;
-
-(*
-    method next_row () =
-      if self#is_eor
-      then
-        False
-      else
-        ( v_current_nrow := v_current_nrow + 1
-        ; not self#is_eor
-        )
-    ;
-
-    method current_row_typed = memd_row_typed v_current_nrow
-    ;
-
-    method! fetchrow_array () : array 'v =
-      if self#is_eor
-      then
-        Dbi.error_eor ()
-      else
-        let res = self#current_row_typed in
-        let _ : bool = self#next_row () in
-        res
-    ;
-*)
-
-    method private get_t colnum =
-     if self#is_eor
-     then
-      Dbi.error_eor ()
-     else
-      let row = self#current_row_typed in
-      let len = Array.length row in
-      if colnum < 0 || colnum >= len
-      then Dbi.error_column & sprintf
-        "tried to get column %i while there are %i columns"
-        colnum len
-      else row.(colnum)
-    ;
-
-    method get_int64 colnum =
-      match self#get_t colnum with
-      [ `Int64 x -> x
-      | x -> raise & error_type_get "int64" x
-      ]
-    ;
-
-    method get_string colnum =
-      match self#get_t colnum with
-      [ `String x -> x
-      | x -> raise & error_type_get "string" x
-      ]
-    ;
-*)
-
-    method iter_uc ug =
-      let record_type = presult in
-      let cg = compile_getter record_type ug in
-      let ntup = presult#ntuples in
-      let rec inner i =
-        if i = ntup
-        then ()
-        else
-          let record = { rres = presult ; rrow = i } in
-          ( let () = Af.run cg record in inner (i + 1) )
-      in
-        inner 0
-    ;
-
-
-    method map_to_list : !'a. uncomp_getter 'a -> list 'a = fun f ->
-      let rev_acc = ref [] in
-      let () = self#iter_uc
-        ( Af2.(<$>)
-          (fun r -> rev_acc.val := [r :: rev_acc.val])
-          f
-        ) in
-      List.rev rev_acc.val
-    ;
-
-
-    method iter_t : (array sql_t -> unit) -> unit = fun f ->
-      let ntup = presult#ntuples in
-      if ntup = 0
-      then
-        ()
-      else
-        let nfields = presult#nfields in
-        let mappers = Array.init nfields
-          (fun i ->
-             match presult#ftype i with
-             [ P.BYTEA -> fun x -> `Binary x
-             | P.CHAR
-             | P.TEXT
-             | P.NAME
-             | P.VARCHAR
-                 -> fun x -> `String x
-             | P.INT8 -> fun x -> `Int64 (G.int64 x)
-             | P.INT2 -> fun x -> `Int (G.int "int2" x)
-             | P.INT4 -> fun x -> `Int32 (G.int32 x)
-             | P.NUMERIC ->
-                 let f = G.number presult ~col:i
-                 in fun x -> `Num (f x)
-             | P.DATE -> fun x -> `Date x
-             | P.TIME -> fun x -> `Time x
-             | P.TIMESTAMP -> fun x -> `Timestamp x
-             | P.TIMESTAMPTZ -> fun x -> `TimestampTZ x
-             | P.TIMETZ -> fun x -> `TimeTZ x
-             | P.BOOL -> fun x -> `Bool (G.bool x)
-             | P.VOID -> fun _ -> `Void
-
-             | P.FLOAT8
-             | P.INT2VECTOR
-             | P.REGPROC
-             | P.OID
-             | P.TID
-             | P.XID
-             | P.CID
-             | P.OIDVECTOR
-             | P.POINT
-             | P.LSEG
-             | P.PATH
-             | P.BOX
-             | P.POLYGON
-             | P.LINE
-             | P.FLOAT4
-             | P.ABSTIME
-             | P.RELTIME
-             | P.TINTERVAL
-             | P.UNKNOWN
-             | P.CIRCLE
-             | P.CASH
-             | P.MACADDR
-             | P.INET
-             | P.CIDR
-             | P.ACLITEM
-             | P.BPCHAR
-             | P.INTERVAL
-             | P.BIT
-             | P.VARBIT
-             | P.ANYELEMENT
-             | P.OPAQUE
-             | P.INTERNAL
-             | P.LANGUAGE_HANDLER
-             | P.TRIGGER
-             | P.ANYARRAY
-             | P.ANY
-             | P.CSTRING
-             | P.RECORD
-             | P.REGTYPE
-             | P.REGCLASS
-             | P.REGOPERATOR
-             | P.REGOPER
-             | P.REGPROCEDURE
-             | P.REFCURSOR
-                 as ftype
-                 -> raise & error_type_not_sup & P.string_of_ftype ftype
-             ]
-          )
-        in
-        let getvalue = presult#getvalue
-        and getisnull = presult#getisnull
-        in
-        let rec inner i =
-          if i = ntup
-          then ()
-          else
-            let record = Array.mapi
-              (fun j mapper ->
-                 if getisnull i j
-                 then `Null
-                 else mapper (getvalue i j)
-              )
-              mappers
-            in
-            let () = f record in
-            inner (i + 1)
-        in
-          inner 0
-    ;
-
-
-    method map_t_to_list : !'a. (array sql_t -> 'a) -> list 'a = fun f ->
-      let rev_acc = ref [] in
-      let () = self#iter_t
-        (fun row ->
-          rev_acc.val := [(f row) :: rev_acc.val]
-        )
-      in
-      List.rev rev_acc.val
-    ;
-
-
-(*
-    method fetchall_array () : array (array sql_t) = [| [|  |] |];
-    method fetchall_list () : list (array sql_t) = [ [| |] ];
-    method fetchrow sql_t = [| |];
-*)
-
-  end
-;
-
-
-class result_cmd (presult : P.result) =
-  object (_self)
-    method affected = presult#cmd_tuples;
-  end
-;
-
-
-type result =
-  [= `Data of result_data
-  |  `Cmd of result_cmd
-  |  `Error of exn
-  ]
-;
-
-value expect_result_data
- : result -> result_data
- = fun
-  [ `Data d -> d
-  | `Cmd _ -> failwith "Dbi_pg.expect_result_data: result is `Cmd"
-  | `Error e -> raise e
-  ]
-;
-
-
-value make_result presult : result =
-  match presult#status with
-  [ P.Command_ok -> `Cmd (new result_cmd presult)
-  | P.Tuples_ok -> `Data (new result_data presult)
-  | ( P.Fatal_error | P.Nonfatal_error ) as rs ->
-      `Error (error_status rs (presult#error))
-  | ( P.Empty_query | P.Copy_in | P.Copy_out | P.Bad_response
-    ) as rs ->
-      `Error (bad_result_status rs)
-  ]
-;
-
-
-value cmd_ok r =
-  match r with
-  [ `Cmd _ -> ()
-  | `Data _ -> failwith "cmd_ok: unexpected data result"
-  | `Error e -> raise e
-  ]
-;
-
-
-value convert_in_params
-(params : array sql_t) =
-  let len = Array.length params in
-  let string_params = Array.make len ""
-  and binary_params = Array.make len True in
-  let () =
-    for i = 0 to len-1
-    do
-      match detype_t params.(i) with
-      [ `Null ->
-           ( string_params.(i) := P.null
-           ; binary_params.(i) := False
-           )
-      | `String str ->
-           ( string_params.(i) := str
-           ; binary_params.(i) := False
-           )
-      | `Binary str ->
-           ( string_params.(i) := (*pcon#escape_bytea*) str
-           ; binary_params.(i) := True
-           )
-      ]
-    done
-  in
-    (string_params, binary_params)
-;
-
-exception Pg_connection of P.connection
-;
-
-class connection_gen conn_info =
-  object (self)
-(*
-    inherit Dbi.connection
-      [sql_t, sql_t, s-tatement sql_t sql_t result, result]
-      (conn_info :> Dbi.conn_info) as super;
-*)
-
-    value mutable con =
-      try
-        some & new P.connection
-          ?host : conn_info#host
-          ?port : conn_info#port
-          ?dbname : conn_info#dbname
-          ?user : conn_info#user
-          ?password : conn_info#password
-          ?options : conn_info#options
-          ?tty : conn_info#tty
-          ?requiressl : conn_info#requiressl
-          ?conninfo : conn_info#conninfo
-          ()
-      with
-      [ P.Error e -> raise & perror e ]
-    ;
-
-    method private with_con : !'a. (P.connection -> 'a) -> 'a =
-     fun func ->
-      match con with
-      [ None -> Dbi.error_connection_closed "postgresql"
-      | Some con -> func con
-      ]
-    ;
-
-    method downcast : unit = self#with_con & fun pcon ->
-      raise (Pg_connection pcon)
-    ;
-
-    method disconnect () =
-      self#with_con & fun pcon ->
-      try
-        ( pcon#finish
-        ; con := None
-        )
-      with
-      [ P.Error e -> raise & perror e ]
-    ;
-
-    value next_stm_name =
-      let c = ref 0 in fun () ->
-      ( incr c
-      ; Printf.sprintf "stm%i" c.val
-      )
-    ;
-
-    method prepare sql = self#with_con & fun pcon ->
-      let stm_name = next_stm_name () in
-      let presult = pcon#prepare stm_name sql in
-      if presult#status <> P.Command_ok
-      then
-        raise & prepare_error presult#error
-      else
-        new statement stm_name self#with_con
-    ;
-
-    (* _p = positional bindings *)
-    method execute_p sql params =
-      try
-        self#with_con & fun pcon ->
-          let (string_params, binary_params) =
-            convert_in_params params in
-          make_result (pcon#exec
-            ~params:string_params ~binary_params sql)
-      with [ e -> `Error e ]
-    ;
-
-    (* no bindings, typed results *)
-    method execute sql =
-      try
-        self#with_con & fun pcon ->
-          make_result (pcon#exec sql)
-      with [ e -> `Error e ]
-    ;
-
-    method start () = cmd_ok & self#execute "start transaction";
-
-    method commit () = cmd_ok & self#execute "commit";
-
-    method rollback () = cmd_ok & self#execute "rollback";
-
-    method quote str = self#with_con & fun con ->
-      "'" ^ con#escape_string ~pos:0 str ^ "'"
-    ;
-
-    method quote_ident str = self#with_con & fun con ->
-      con#escape_string ~pos:0 str
-    ;
-
-  end
-
-and
-
-statement
-(stm_name : string) meth_with_con =
-  object
-
-(*
-    inherit Dbi.statement ['v, 'p, 'res];
-*)
-
-    method execute () =
-      try
-        (meth_with_con : (P.connection -> 'q) -> 'q) & fun pcon ->
-           make_result (pcon#exec_prepared stm_name)
-      with [ e -> `Error e ]
-    ;
-
-    (* execute prepared statement with "_p"ositional parameters *)
-    method execute_p params =
-      try
-        meth_with_con & fun pcon ->
-          let (string_params, binary_params) =
-            convert_in_params params in
-          make_result (pcon#exec_prepared
-            ~params:string_params ~binary_params stm_name)
-      with [ e -> `Error e ]
-    ;
-
-    (* will be implemented as "cleaning prepared statement"
-       when postgresql-ocaml will provide such functionality. *)
-    method finish () = ()
-    ;
-
-  end
-;
-
-
-class connection conn_info =
-  connection_gen conn_info
-;
-
-
-value with_connection conn_info func =
-  let con = new connection conn_info in
-  let finally () =
-    try con#disconnect () with [ _ -> () ] in
-  try
-    let r = func con in
-    ( finally ()
-    ; r
-    )
-  with
-  [ e -> (finally (); raise e)
-  ]
-;
-
-