Commits

Dmitry Grebeniuk  committed d1fc30d

amall: useful functions

  • Participants

Comments (0)

Files changed (28)

+name="amall"
+version="0.1"
+description="AmAll"
+requires="unix, postgresql"
+archive(byte)="amall.cma"
+archive(native)="amall.cmxa"
+PKG=amall
+VERSION=0.1
+
+all :
+	ocamlbuild \
+	   amall.cma amall.cmxa
+
+install : all
+	ocamlfind install \
+	  -patch-version $(VERSION) \
+	  $(PKG) META \
+	  _build/amall.cma _build/amall.cmxa \
+	  _build/am_All.cmi _build/am_Common.cmi _build/am_Ops.cmi \
+	  _build/dbi.cmi _build/dbi_common.cmi _build/dbi_pg.cmi \
+	  _build/extArray.cmi _build/extList.cmi _build/extQueue.cmi \
+	  _build/extStream.cmi _build/extString.cmi _build/extSys.cmi \
+	  _build/filename_new.cmi _build/filew.cmi _build/res.cmi \
+	  _build/sortedArray.cmi _build/sortedArraySet.cmi \
+	  _build/with_comb.cmi
+
+deinstall :
+	ocamlfind remove $(PKG)
+
+reinstall :
+	-$(MAKE) deinstall
+	$(MAKE) install
+<*.ml> | <*.mli> : camlp4r, warn_A
+<am_Ops.*> | <filename_new.*> : -camlp4r, camlp4o
+<dbi_pg.*> : pkg_postgresql, pkg_threads
+include Am_Ops;
+module Array = ExtArray.Array;
+module List = ExtList.List;
+module Queue = ExtQueue.Queue;
+module Stream = ExtStream.Stream;
+module String = ExtString.String;
+module Sys = ExtSys.Sys;
+module Filename = Filename_new;
+include Am_Common;
+module Dbi = Dbi.Dbi;
+include Printf;

File am_Common.ml

+open Printf
+;
+
+open Am_Ops
+;
+
+value dbg fmt = Printf.ksprintf (Printf.eprintf "DBG: %s\n%!") fmt
+;
+
+value failwith fmt = Printf.ksprintf failwith fmt
+;
+
+exception Not_implemented of string
+;
+
+value not_impl func = raise (Not_implemented func)
+;
+
+value () = Printexc.register_printer & fun
+  [ Not_implemented func ->
+      some & sprintf "Function %S is not implemented." func
+  | _ -> None
+  ]
+;
+(* not really operations, but.. *)
+let forA arr func = Array.iter func arr
+let forL lst func = List.iter func lst
+let forStream strm func = Stream.iter func strm
+
+
+external extern_identity : 'a -> 'a = "%identity"
+
+let identity = extern_identity
+
+let some x = Some x
+
+(** пропустить значение последовательно через функции:
+    123 >> string_of_int >> print_string
+*)
+let ( >> ) x f = f x
+
+(** применить значение к функции:
+    print_string & string_of_int & 123
+
+    NB: оператор "&" является ключевым словом в jocaml
+
+    Если попробовать объявить "let ( $ ) f x = f x",
+    то полученный оператор будет левоассоциативным,
+    что нежелательно в данном случае.
+*)
+let ( & ) f x = f x
+
+(** композиция функций:
+    let print_int = print_string % string_of_int
+    let print_int = print_string $ string_of_int
+    let print_int_sum = print_string % string_of_int %% ( + )
+    let print_int_sum = print_string %% (string_of_int %% ( + ) )
+    let for_all pred = not % List.exists (not % pred)
+    let for_all2 pred = not %% List.exists2 (not %% pred)
+
+    Операторы левоассоциативны, у оператора ($) приоритет ниже,
+    чем у (%), и ниже, чем у арифметических операторов.
+*)
+let ( % ) f g = fun x -> f (g x)
+let ( $ ) = ( % )
+let ( %% ) f g = fun x y -> f (g x y)
+let ( %%% ) f g = fun x y z -> f (g x y z)
+
+(** применить инфиксную функцию:
+    123L /* Int64.add */ 234L
+*)
+let ( /* ) x y = y x
+let ( */ ) x y = x y
+
+
+(* Для удобного использования инфиксных операторов
+   существует отличное решение: pa_do
+   ( http://pa-do.forge.ocamlcore.org/ )
+   Если использовать его не можете, то в качестве
+   слабого подобия можно взять нижеследующие модули.
+   Их названия имеют вид "Тип1_as_тип2", и при открытии
+   такого модуля со значениями типа1 можно будет работать
+   теми операторами, которыми обычно работают со значениями
+   типа2.
+   Например,
+   let my_int64 =
+     let module M =
+       struct
+         open Int32_as_int
+         open Int64_as_float
+         let x = (Int64.of_int32 (123l + 234l)) +. 345L
+       end
+     in
+       M.x
+*)
+
+(* Замечание: для консистентности модули "Тип1_as_тип2"
+   всегда должны переопределять одни и те же операторы.
+*)
+
+(* todo: добавить в Int* операции mod, rem, битовые *)
+
+module Int_as_int =
+  struct
+    let ( + ) = Pervasives.( + )
+    let ( - ) = Pervasives.( - )
+    let ( * ) = Pervasives.( * )
+    let ( / ) = Pervasives.( / )
+    let ( ~- ) = Pervasives.( ~- )
+  end
+
+module Float_as_float =
+  struct
+    let ( +. ) = Pervasives.( +. )
+    let ( -. ) = Pervasives.( -. )
+    let ( *. ) = Pervasives.( *. )
+    let ( /. ) = Pervasives.( /. )
+    let ( ~-. ) = Pervasives.( ~-. )
+  end
+
+
+(** TODO core, pa_do, pa_openin *)
+
+module Int32_as_int =
+  struct
+    let ( + ) = Int32.add
+    let ( - ) = Int32.sub
+    let ( * ) = Int32.mul
+    let ( / ) = Int32.div
+    let ( ~- ) = Int32.neg
+  end
+
+module Int64_as_int =
+  struct
+    let ( + ) = Int64.add
+    let ( - ) = Int64.sub
+    let ( * ) = Int64.mul
+    let ( / ) = Int64.div
+    let ( ~- ) = Int64.neg
+  end
+
+module Int_as_float =
+  struct
+    let ( +. ) = Pervasives.( + )
+    let ( -. ) = Pervasives.( - )
+    let ( *. ) = Pervasives.( * )
+    let ( /. ) = Pervasives.( / )
+    let ( ~-. ) = Pervasives.( ~- )
+  end
+
+module Float_as_int =
+  struct
+    let ( + ) = Pervasives.( +. )
+    let ( - ) = Pervasives.( -. )
+    let ( * ) = Pervasives.( *. )
+    let ( / ) = Pervasives.( /. )
+    let ( ~- ) = Pervasives.( ~-. )
+  end
+
+module Int32_as_float =
+  struct
+    let ( +. ) = Int32.add
+    let ( -. ) = Int32.sub
+    let ( *. ) = Int32.mul
+    let ( /. ) = Int32.div
+    let ( ~-. ) = Int32.neg
+  end
+
+module Int64_as_float =
+  struct
+    let ( +. ) = Int64.add
+    let ( -. ) = Int64.sub
+    let ( *. ) = Int64.mul
+    let ( /. ) = Int64.div
+    let ( ~-. ) = Int64.neg
+  end
+
+module Int_as_int_overflow =
+  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
+  struct
+    exception Overflow
+
+    let ( + ) a b =
+      let c = a + b in
+      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
+
+    let ( - ) a b =
+      let c = a - b in
+      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
+
+    let ( * ) a b =
+      let c = a * b in
+      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
+      then c else raise Overflow
+
+    let ( / ) a b =
+      if a = min_int && b = -1 then raise Overflow else a / b
+
+    let ( ~- ) x =
+      if x <> min_int then -x else raise Overflow
+
+  end
+Am_All
+Am_Common
+Am_Ops
+Dbi_common
+Dbi
+Dbi_pg
+ExtArray
+ExtList
+ExtQueue
+ExtStream
+ExtString
+ExtSys
+Filename_new
+Filew
+Res
+SortedArray
+SortedArraySet
+With_comb
+module Dbi
+ =
+  struct
+
+    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
+    ;
+
+    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 ['v] =
+      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
+    ;
+
+
+    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
+    ;
+
+
+    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;
+
+(*
+    value connect (_conn_info : conn_info) : res connection dbi_error =
+      raise Exit
+    ;
+
+    value bind_connection conn_info func =
+      Res.bind func & connect conn_info
+    ;
+*)
+
+    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)#status with
+      [ `Ok `Cmd -> ()
+      | `Ok `Data -> error "data returned"
+      | `Error e -> error & sprintf "occured a %s" & string_of_exn e
+      ]
+    ;
+
+  end
+;

File dbi_common.ml

+value failwith fmt = Printf.ksprintf failwith fmt
+;
+open Dbi;
+open Dbi_common;
+
+open Am_All;
+
+(*
+value dbg fmt = Am_Common.dbg fmt
+;
+*)
+
+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
+;
+
+
+module P = Postgresql
+;
+
+
+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
+;
+
+(*
+added:
+type sql_t = [= Dbi.sql_t | `Mysupertypeforextensibility ]
+;
+*)
+
+type sql_u =
+  [= `Null
+  |  `String of string
+  |  `Binary of string
+  ]
+;
+
+
+type sql_t =
+  [= sql_u
+
+  |  `Bool of bool
+  |  `Int of int      (* smallint *)
+  |  `Int32 of int32  (* int *)
+  |  `Int64 of int64  (* bigint *)
+  |  `Num of Num.num  (* numeric/decimal *)
+
+  |  `Date of string
+  |  `Time of string
+  |  `TimeTZ of string
+  |  `Timestamp of string
+  |  `TimestampTZ of string
+  ]
+;
+
+
+(* засёк, 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" (Num.string_of_num 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
+;
+
+
+(*
+class cl x =
+  if x = 0
+  then
+    object method x = 0; end
+  else
+    object method x = 1; end
+;
+*)
+
+
+(*
+value entype_u ftype ~isnull x : sql_u =
+  if isnull
+  then `Null
+  else if ftype = P.BYTEA
+  then `Binary x
+  else `String x
+;
+*)
+
+value entype_t ftype ~isnull x : sql_t =
+  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)
+    | 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.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 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 =
+  match v with
+  [ (`Binary _) | (`String _) | `Null
+      as v -> v
+
+  | ( `Date x | `Time x | `Timestamp x
+    | `TimestampTZ x | `TimeTZ x
+    )
+      -> `String x
+
+  | `Int64 i -> `String (Int64.to_string i)
+  | `Int i -> `String (string_of_int i)
+  | `Int32 i -> `String (Int32.to_string i)
+  | `Num _ ->
+      failwith "don't know how to convert Num to string while the \
+                precision is not known"
+  | `Bool b -> if b then `String "t" else `String "f"
+  ]
+;
+
+
+(*
+value detype_u v = v
+;
+*)
+
+
+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
+    ]
+;
+
+
+class result
+  ['v]
+  (entype : P.ftype -> ~isnull:bool -> string -> 'v)
+  (detype : 'v -> sql_u)
+  (presult : P.result) =
+  let r_status =
+      (match presult#status with
+       [ P.Command_ok -> `Ok `Cmd
+       | P.Tuples_ok -> `Ok `Data
+       | ( 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)
+       ]
+      )
+  in
+  let memd_row = memo_last presult#get_tuple in
+  let memd_nulls = memo_last
+    (fun r -> Array.init presult#nfields (fun i -> presult#getisnull r i)
+    ) in
+  let col_ftypes_lazy = lazy
+      ( Array.init presult#nfields
+          (fun i -> presult#ftype i
+          )
+      )
+  in
+  let memd_row_typed = memo_last
+      (fun r ->
+        let str_arr = memd_row r in
+        let isnull = memd_nulls r in
+        Array.mapi2
+          (fun i ftype v ->
+             entype ftype ~isnull:isnull.(i) v
+          )
+          (Lazy.force col_ftypes_lazy)
+          str_arr
+      )
+  in
+  object (self)
+    inherit Dbi.result ['v];
+
+    value names_lazy = lazy presult#get_fnames;
+
+    value mutable v_current_nrow = 0;
+
+    method nrows = Some presult#ntuples;
+    method names = Lazy.force names_lazy;
+    method ncols = presult#nfields;
+    method status = r_status;
+
+    method affected = presult#cmd_tuples;
+
+    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 fetchall_array () : array (array sql_t) = [| [|  |] |];
+    method fetchall_list () : list (array sql_t) = [ [| |] ];
+    method fetchrow sql_t = [| |];
+*)
+
+  end
+;
+
+
+type fresult 'v =
+  [= `Ok of [= `Command | `Query of result 'v ]
+  |  `Error of exn
+  ]
+;
+
+
+value cmd_ok r =
+  match r#status with
+  [ `Ok `Cmd -> ()
+  | `Ok `Data -> failwith "cmd_ok: unexpected data result"
+  | `Error e -> raise e
+  ]
+;
+
+
+value convert_in_params
+~detype
+(params : array 'a) =
+  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 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)
+;
+
+
+class connection_gen entype detype conn_info =
+  object (self)
+    inherit Dbi.connection
+      [sql_t, sql_t, statement sql_t sql_t (result sql_t), result sql_t]
+      (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 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
+      )
+    ;
+
+    (* typed *)
+    method prepare sql = self#with_con & fun pcon ->
+      let stm_name = next_stm_name () in
+      let presult = pcon#prepare stm_name sql in
+(*
+      failwith & sprintf "pres = %s / %s" (P.result_status
+             presult#status)
+         (presult#error)
+*)
+      if presult#status <> P.Command_ok
+      then
+        raise & prepare_error presult#error
+      else
+        new statement entype detype stm_name self#with_con
+    ;
+
+    (* _p = positional bindings, typed results *)
+    method execute_p sql params = self#with_con & fun pcon ->
+      let (string_params, binary_params) =
+        convert_in_params ~detype:detype_t params in
+      new result entype detype (pcon#exec
+        ~params:string_params ~binary_params sql)
+    ;
+
+    (* no bindings, typed results *)
+    method execute sql = self#with_con & fun pcon ->
+      new result entype_t detype_t (pcon#exec sql)
+    ;
+
+    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 ['v, 'p, 'res]
+entype
+detype
+(stm_name : string) meth_with_con =
+  object
+    constraint 'res = #result 'v;
+
+    inherit Dbi.statement ['v, 'p, 'res];
+
+    method execute () =
+      ( (meth_with_con : (P.connection -> 'q) -> 'q) & fun pcon ->
+           new result entype detype (pcon#exec_prepared stm_name)
+      )
+    ;
+
+    (* execute prepared statement with "_p"ositional parameters *)
+    method execute_p params =
+      ( meth_with_con & fun pcon ->
+          let (string_params, binary_params) =
+            convert_in_params ~detype:detype_t params in
+          new result entype detype (pcon#exec_prepared
+            ~params:string_params ~binary_params stm_name)
+      )
+    ;
+
+  end
+;
+
+
+class connection conn_info =
+  connection_gen entype_t detype_t 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)
+  ]
+;
+
+
+value pgpass_escape field =
+  let buf = Buffer.create 8 in
+  ( for i = 0 to String.length field - 1
+    do
+      let c = field.[i] in
+      ( if c = ':' || c = '\\'
+        then Buffer.add_char buf '\\'
+        else ()
+      ; Buffer.add_char buf c
+      )
+    done
+  ; Buffer.contents buf
+  )
+;
+
+
+exception Pgpass of string
+;
+
+
+open Res
+;
+
+
+value pgpass_line conn_info =
+  let f title opt_val =
+    match opt_val with
+    [ None -> fail & sprintf "field %S not defined" title
+    | Some x -> return x
+    ]
+  and fany opt_val =
+    return &
+    match opt_val with
+    [ None -> "*"
+    | Some x -> x
+    ]
+  in
+  catch (fun () ->
+    f "host" conn_info#host >>= fun host ->
+    f "port" conn_info#port >>= fun port ->
+    fany conn_info#dbname >>= fun dbname ->
+    f "user" conn_info#user >>= fun user ->
+    f "password" conn_info#password >>= fun password ->
+    let e () str = pgpass_escape str in
+      return &
+        sprintf "%a:%a:%a:%a:%a"
+          e host e port e dbname e user e password
+  )
+  (fun e -> fail &
+     sprintf "can't make .pgpass-line: %s" e
+  )
+;
+
+
+value pgpass_fname () =
+  match Sys.os_type with
+  [ "Unix" ->
+      return &
+      ( Filename.concat
+          (Sys.getenv "HOME")
+          ".pgpass"
+      , None
+      )
+  | "Win32" ->
+      return &
+        let dir =
+          Filename.concat
+            (Sys.getenv "APPDATA")
+            "postgresql"
+        in
+        let fn = Filename.concat dir "pgpass.conf" in
+        (fn, Some dir)
+  | o ->
+      fail (Pgpass (sprintf "pgpass_fname: os_type %S not supported" o))
+  ]  
+;
+
+
+value append_to_pgpass_line line =
+  pgpass_fname () >>= fun (fname, opt_dir) ->
+  res_exn & fun () ->
+    ( match opt_dir with
+      [ None -> ()
+      | Some dir ->
+          match 
+            try some & Sys.is_directory dir with [ Sys_error _ -> None ]
+          with
+          [ None ->  (* no file / no dir *)
+              Unix.mkdir dir 0o600
+          | Some True ->  (* directory *)
+              ()
+          | Some False ->  (* file *)
+              failwith "%S shouldn't be a file" dir
+          ]
+      ]
+    ;
+      Filew.with_file_out_gen
+        [Open_append; Open_creat; Open_binary] 0o600 fname &
+      fun outch ->
+        fprintf outch "%s\n%!" line
+    )
+;
+
+
+value append_to_pgpass (conn_info : conn_info) =
+  map_err (fun msg -> Pgpass msg)
+  (pgpass_line conn_info)
+  >>= fun line ->
+  append_to_pgpass_line line
+;

File example_tags

+<*.ml> | <*.mli> : camlp4r, warn_A
+
+<ops.ml> | <lexer_*.ml> : -camlp4r, camlp4o
+<dbi_pg.*> | <{nala,setup}.{byte,native}> : pkg_postgresql
+<*> : thread
+
+<test_sp.{ml,byte,native}> : pkg_postgresql
+
+<log_format.{byte,native}> : use_str, use_unix
+<test_uri_chars.{byte,native}> : use_unix
+
+
+
+
+<nala.{byte,native}> : use_str
+
+<ocaml-iteratees/it_Lwt_IO.ml> : pkg_lwt
+<macroexp.*> : pkg_lwt, pkg_lwt.unix, pkg_extlib
+module Array =
+  struct
+    include Array;
+
+    value map_filter func arr =
+      inner [] (Array.length arr - 1)
+      where rec inner acc i =
+        if i < 0
+        then
+          Array.of_list acc
+        else
+          match func arr.(i) with
+          [ None -> inner acc (i - 1)
+          | Some x -> inner [x :: acc] (i - 1)
+          ]
+    ;
+
+
+    value findi_opt pred arr =
+      inner 0
+      where rec inner i =
+        if i = Array.length arr
+        then None
+        else
+          if pred arr.(i)
+          then Some (i, arr.(i))
+          else inner (i + 1)
+    ;
+
+
+    value eqlen funcname a1 a2 =
+      let len = Array.length a1 in
+      if len <> Array.length a2
+      then invalid_arg ("ExtArray." ^ funcname
+        ^ ": arrays must have equal length")
+      else
+        len
+    ;
+
+
+    value map2 f a1 a2 =
+      let len = eqlen "map2" a1 a2 in
+      Array.init len
+        (fun i -> f a1.(i) a2.(i)
+        )
+    ;
+
+
+    value mapi2 f a1 a2 =
+      let len = eqlen "mapi2" a1 a2 in
+      Array.init len
+        (fun i -> f i a1.(i) a2.(i)
+        )
+    ;
+
+
+    value iter2 f a1 a2 =
+      let len = eqlen "iter2" a1 a2 in
+      for i = 0 to len-1
+      do
+        ( f a1.(i) a2.(i) )
+      done
+    ;
+
+
+  end
+;
+module List
+ =
+  struct
+
+    include List;
+
+    value find_opt pred lst =
+      try
+        Some (List.find pred lst)
+      with
+      [ Not_found -> None ]
+    ;
+
+    value rec drop_while pred lst =
+      match lst with
+      [ [] -> []
+      | [ hd :: tl ] ->
+          if pred hd
+          then drop_while pred tl
+          else lst
+      ]
+    ;
+
+    value last lst =
+      match lst with
+      [ [] -> failwith "ExtList.last"
+      | [h :: t] ->
+          inner h t
+          where rec inner prev lst =
+            match lst with
+            [ [] -> prev
+            | [h :: t] -> inner h t
+            ]
+      ]
+    ;
+
+    value concat_with between lol =
+      match lol with
+      [ [] -> []
+      | [first :: rest] ->
+          inner (List.rev first) rest
+          where rec inner rev_acc lol =
+            match lol with
+            [ [] -> List.rev rev_acc
+            | [h :: t] ->
+                inner
+                  (List.rev_append
+                     h
+                     (List.rev_append between rev_acc)
+                  )
+                  t
+            ]
+      ]
+    ;
+
+
+    (* returns: ([pre], [this], [rest]) or ([pre], [], []) *)
+
+    value split_by_first pred lst =
+      inner [] lst
+      where rec inner rev_acc lst =
+        match lst with
+        [ [] -> (List.rev rev_acc, [], [])
+        | [h :: t] ->
+            if pred h
+            then (List.rev rev_acc, [h], t)
+            else inner [h :: rev_acc] t
+        ]
+    ;
+
+    value split_by pred lst =
+      loop [] lst
+      where rec loop rev_acc lst =
+        if lst = []
+        then List.rev rev_acc
+        else
+          let (pre, _delim, rest) = split_by_first pred lst in
+          loop [pre :: rev_acc] rest
+    ;
+
+
+    value map_filter func lst =
+      inner [] lst
+      where rec inner rev_acc lst =
+        match lst with
+        [ [] -> List.rev rev_acc
+        | [h :: t] ->
+            match func h with
+            [ None -> inner rev_acc t
+            | Some x -> inner [x :: rev_acc] t
+            ]
+        ]
+    ;
+
+
+    value assoc_count ?(cmp=Pervasives.compare) k t =
+      inner 0 t
+      where rec inner n t =
+        match t with
+        [ [] -> n
+        | [(hk,_hv)::t] ->
+            inner (if cmp k hk = 0 then (n+1) else n) t
+        ]
+    ;
+
+    value assoc_opt ?(cmp=Pervasives.compare) k t =
+      inner t
+      where rec inner t =
+        match t with
+        [ [] -> None
+        | [(hk, hv) :: t] ->
+            if cmp k hk = 0
+            then Some hv
+            else inner t
+        ]
+    ;
+
+
+    (* non tail-rec, GC-wise (does not recreate cons cells without need) *)
+
+    value rec assoc_remove ?(cmp=Pervasives.compare) k t =
+      let rec inner left t =
+        if left = 0
+        then t
+        else loop left t
+      and loop left t =
+        match t with
+        [ [] -> assert False
+        | [((hk,_hv) as h) :: t] ->
+            if cmp k hk = 0
+            then inner (left - 1) t
+            else [h :: loop left t]
+        ]
+      in
+        inner (assoc_count ~cmp k t) t
+    ;
+
+
+    value rec assoc_replace ?(cmp=Pervasives.compare) k v t =
+      [(k, v) :: assoc_remove ~cmp k t]
+    ;
+
+
+    value reduce_left mapfunc reducefunc lst =
+      match lst with
+      [ [] -> invalid_arg "ExtList.reduce_left: empty input list"
+      | [h :: t] ->
+          inner ~acc:(mapfunc h) t
+          where rec inner ~acc lst =
+            match lst with
+            [ [] -> acc
+            | [h :: t] ->
+                inner t ~acc:(reducefunc acc (mapfunc h))
+            ]
+      ]
+    ;
+
+    value get_single lst =
+      let fail reason = failwith ("ExtList.get_single: " ^ reason) in
+      match lst with
+      [ [] -> fail "empty list"
+      | [x :: []] -> x
+      | [_ :: [_ :: _]] -> fail "more than one element"
+      ]
+    ;
+
+    value get_pair lst =
+      let fail reason = failwith
+        ("ExtList.get_pair: expected list of two elements, got " ^ reason) in
+      match lst with
+      [ [] -> fail "empty list"
+      | [_ ::[]] -> fail "list of one element"
+      | [x :: [y :: []]] -> (x, y)
+      | _ -> fail "list of more than two elements"
+      ]
+    ;
+
+  end
+;
+module Queue
+ =
+  struct
+
+    include Queue;
+
+    value copy_to_array q =
+      Array.of_list
+        (List.rev
+           (Queue.fold (fun acc elem -> [elem :: acc]) [] q)
+        )
+    ;
+
+  end
+;

File extStream.ml

+module Stream
+ =
+  struct
+
+    include Stream;
+
+    value input_line_opt in_ch =
+      try Some (input_line in_ch) with
+      [ End_of_file -> None ]
+    ;
+
+(*
+    value lines_of_channel in_ch =
+      from
+        (fun _ ->
+           input_line_opt in_ch
+        )
+    ;
+*)
+
+    value next_opt s =
+      match peek s with
+      [ None -> None
+      | (Some _) as some_x ->
+          ( Stream.junk s
+          ; some_x
+          )
+      ]
+    ;
+
+    value map f s = Stream.from (fun _ ->
+      match next_opt s with
+      [ None -> None
+      | Some x -> Some (f x)
+      ]
+     )
+    ;
+
+    value is_empty s =
+      try (Stream.empty s; True)
+      with [ Stream.Failure -> False ]
+    ;
+
+    value rec njunk n s =
+      if n <= 0
+      then ()
+      else (junk s; njunk (n - 1) s)
+    ;
+
+
+    (* leave no more than n last items of stream s, junk others. *)
+
+    value keep_last n s =
+      if n < 1 then invalid_arg "ExtStream.last" else
+      loop ()
+      where rec loop () =
+        let l = List.length (npeek (n + 1) s) in
+        if l <= n
+        then ()
+        else (junk s; loop ())
+    ;
+
+    value to_list s =
+      inner []
+      where rec inner rev_acc =
+        match next_opt s with
+        [ None -> List.rev rev_acc
+        | Some x -> inner [x :: rev_acc]
+        ]
+    ;
+
+    value pervasives_eq a b = (Pervasives.compare a b = 0)
+    ;
+
+    value is_prefix ?(eq=pervasives_eq) ~prefix stream =
+      let pref_len = List.length prefix in
+      let spref = npeek pref_len stream in
+         List.length spref = pref_len
+      && List.for_all2 eq prefix spref
+    ;
+
+  end
+;

File extString.ml

+module String
+ =
+  struct
+
+    include String
+    ;
+
+    value is_prefix ~string ~prefix =
+      let str_len = String.length string
+      and pref_len = String.length prefix in
+      pref_len <= str_len
+      && String.sub string 0 pref_len = prefix
+    ;
+
+    value chop_prefix ~string ~prefix =
+      let pref_len = String.length prefix in
+      if is_prefix ~string ~prefix
+      then String.sub string pref_len (String.length string - pref_len)
+      else string
+    ;
+
+    value is_suffix ~string ~suffix =
+      let str_len = String.length string
+      and suf_len = String.length suffix in
+      suf_len <= str_len &&
+      String.sub string (str_len - suf_len) suf_len = suffix
+    ;
+
+    value chop_suffix ~string ~suffix =
+      let suf_len = String.length suffix in
+      if is_suffix ~string ~suffix
+      then String.sub string 0 (String.length string - suf_len)
+      else string
+    ;
+
+    value trim_count pred s =
+      let len = String.length s in
+      let first_skipping =
+        inner 0
+        where rec inner i =
+          if i = len || not (pred s.[i])
+          then i
+          else inner (i + 1)
+      in
+        if first_skipping = len
+        then (len, "", 0)
+        else
+          let last_leaving =
+            inner (len - 1)
+            where rec inner i =
+              let () = assert (i >= first_skipping) in
+              if pred s.[i]
+              then inner (i - 1)
+              else i
+          in
+            let new_len = last_leaving - first_skipping + 1 in
+            ( first_skipping
+            , if new_len = len
+              then s
+              else String.sub s first_skipping new_len
+            , len - last_leaving - 1
+            )
+    ;
+
+    value trim pred s =
+      let (_firsts, res, _lasts) = trim_count pred s in
+      res
+    ;
+
+    value split_by_first pred s =
+      let len = String.length s in
+      let i =
+        inner 0
+        where rec inner i =
+          if i = len || pred s.[i]
+          then i
+          else inner (i + 1)
+      in
+        if i = len
+        then (s, "", "")
+        else
+          ( String.sub s 0 i
+          , String.sub s i 1
+          , String.sub s (i + 1) (len - i - 1)
+          )
+    ;
+
+
+    (* [split_exact ((=) '.') ".asd..sdf." = ["";"asd";"";"sdf";""]] *)
+    value split_exact pred s =
+      let len = String.length s in
+
+      let rec rev_delimiters rev_acc i =  (* including -1 and len *)
+        if i = len
+        then [len :: rev_acc]
+        else
+        if pred s.[i]
+        then
+          rev_delimiters [i :: rev_acc] (i + 1)
+        else
+          rev_delimiters rev_acc (i + 1)
+      in
+      let rev_dels = rev_delimiters [-1] 0 in
+      let rec inner acc rev_dels =
+        match rev_dels with
+        [ [] -> assert False
+        | [ _ :: [] ] -> acc
+        | [next :: ([this :: _] as tl)] ->
+            inner
+              [(String.sub s (this+1) (next - this - 1)) :: acc]
+              tl
+        ]
+      in
+        inner [] rev_dels
+    ;
+
+
+(*
+    value () =
+      if split_exact ((=) '.') ".asd..sdf." = ["";"asd";"";"sdf";""]
+         && split_exact ((=) '.') "" = [""]
+         && split_exact ((=) '.') "asd" = ["asd"]
+      then failwith "ok"
+      else failwith "bad"
+    ;
+*)
+
+
+    (* todo: more effective implementation. *)
+
+    value split pred s =
+      List.filter ((<>) "") (split_exact pred s)
+    ;
+
+
+    value decode_hex_opt ch =
+      let c = Char.code ch in
+      if ch >= '0' && ch <= '9'
+      then Some (c - (Char.code '0'))
+      else if ch >= 'A' && ch <= 'F'
+      then Some (c - (Char.code 'A') + 10)
+      else if ch >= 'a' && ch <= 'f'
+      then Some (c - (Char.code 'a') + 10)
+      else None
+    ;
+
+
+    value urldecode s =
+      let len = String.length s in
+      let buf = Buffer.create (len / 3) in
+      loop 0
+      where rec loop i =
+        if i = len
+        then Buffer.contents buf
+        else
+          let out ch adv =
+            (Buffer.add_char buf ch; loop (i + adv))
+          in
+          match s.[i] with
+          [ '+' -> out '\x20' 1
+          | '%' as c0 ->
+              if i + 2 >= len
+              then out c0 1
+              else
+                let c1 = s.[i + 1]
+                and c2 = s.[i + 2] in
+                match (decode_hex_opt c1, decode_hex_opt c2) with
+                [ (Some d1, Some d2) ->
+                    out (Char.chr (16*d1 + d2)) 3
+                | _ -> out c0 1
+                ]
+          | c -> out c 1
+          ]
+    ;
+
+
+    (* todo: more effective implementation *)
+
+    value concat_array sep str_arr =
+      String.concat sep (Array.to_list str_arr)
+    ;
+
+
+    value explode str =
+      inner [] (String.length str - 1)
+      where rec inner acc i =
+        if i < 0
+        then acc
+        else inner [str.[i] :: acc] (i - 1)
+    ;
+
+
+    value compare_nocase_latin1 s1 s2 =
+      let len1 = String.length s1 in
+      let len2 = String.length s2 in
+      let bound = min len1 len2 in
+      loop 0
+      where rec loop i =
+        if i = bound
+        then
+          Pervasives.compare len1 len2
+        else
+          match Pervasives.compare
+            (Char.uppercase s1.[i]) (Char.uppercase s2.[i])
+          with
+          [ 0 -> loop (i + 1)
+          | r -> r
+          ]
+    ;
+
+
+  end
+;
+module Sys
+ =
+  struct
+
+    include Sys;
+
+    value names_of_signals =
+      [ (sigabrt, "sigabrt")
+      ; (sigalrm, "sigalrm")
+      ; (sigfpe, "sigfpe")
+      ; (sighup, "sighup")
+      ; (sigill, "sigill")
+      ; (sigint, "sigint")
+      ; (sigkill, "sigkill")
+      ; (sigpipe, "sigpipe")
+      ; (sigquit, "sigquit")
+      ; (sigsegv, "sigsegv")
+      ; (sigterm, "sigterm")
+      ; (sigusr1, "sigusr1")
+      ; (sigusr2, "sigusr2")
+      ; (sigchld, "sigchld")
+      ; (sigcont, "sigcont")
+      ; (sigstop, "sigstop")
+      ; (sigtstp, "sigtstp")
+      ; (sigttin, "sigttin")
+      ; (sigttou, "sigttou")
+      ; (sigvtalrm, "sigvtalrm")
+      ; (sigprof, "sigprof")
+      ]
+    ;
+
+    value name_of_signal n =
+      try
+        List.assoc n names_of_signals
+      with
+      [ Not_found -> Printf.sprintf "signal %i" n]
+    ;
+
+  end
+;

File filename_new.ml

+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+let generic_quote quotequote s =
+  let l = String.length s in
+  let b = Buffer.create (l + 20) in
+  Buffer.add_char b '\'';
+  for i = 0 to l - 1 do
+    if s.[i] = '\''
+    then Buffer.add_string b quotequote
+    else Buffer.add_char b  s.[i]
+  done;
+  Buffer.add_char b '\'';
+  Buffer.contents b
+
+let generic_basename rindex_dir_sep current_dir_name name =
+  let raw_name =
+    try
+      let p = rindex_dir_sep name + 1 in
+      String.sub name p (String.length name - p)
+    with Not_found ->
+      name
+  in
+  if raw_name = "" then current_dir_name else raw_name
+
+let generic_dirname rindex_dir_sep current_dir_name dir_sep name =
+  try
+    match rindex_dir_sep name with
+      0 -> dir_sep
+    | n -> String.sub name 0 n
+  with Not_found ->
+    current_dir_name
+
+module Unix = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "/"
+  let is_dir_sep s i = s.[i] = '/'
+  let rindex_dir_sep s = String.rindex s '/'
+  let is_relative n = String.length n < 1 || n.[0] <> '/';;
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+  let check_suffix name suff =
+    String.length name >= String.length suff &&
+    String.sub name (String.length name - String.length suff)
+                    (String.length suff) = suff
+  let temp_dir_name =
+    try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
+  let quote = generic_quote "'\\''"
+  let basename = generic_basename rindex_dir_sep current_dir_name
+  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+end
+
+module Win32 = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "\\"
+  let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
+  let rindex_dir_sep s =
+    let rec pos i =
+      if i < 0 then raise Not_found
+      else if is_dir_sep s i then i
+      else pos (i - 1)
+    in pos (String.length s - 1)
+  let is_relative n =
+    (String.length n < 1 || n.[0] <> '/')
+    && (String.length n < 1 || n.[0] <> '\\')
+    && (String.length n < 2 || n.[1] <> ':')
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 2 || String.sub n 0 2 <> ".\\")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+    && (String.length n < 3 || String.sub n 0 3 <> "..\\")
+  let check_suffix name suff =
+   String.length name >= String.length suff &&
+   (let s = String.sub name (String.length name - String.length suff)
+                            (String.length suff) in
+    String.lowercase s = String.lowercase suff)
+  let temp_dir_name =
+    try Sys.getenv "TEMP" with Not_found -> "."
+  let quote s =
+    let l = String.length s in
+    let b = Buffer.create (l + 20) in
+    Buffer.add_char b '\"';
+    let rec loop i =
+      if i = l then Buffer.add_char b '\"' else
+      match s.[i] with
+      | '\"' -> loop_bs 0 i;
+      | '\\' -> loop_bs 0 i;
+      | c    -> Buffer.add_char b c; loop (i+1);
+    and loop_bs n i =
+      if i = l then begin
+        Buffer.add_char b '\"';
+        add_bs n;
+      end else begin
+        match s.[i] with
+        | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1);
+        | '\\' -> loop_bs (n+1) (i+1);
+        | _c    -> add_bs n; loop i
+      end
+    and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done
+    in
+    loop 0;
+    Buffer.contents b
+  let has_drive s =
+    let is_letter = function
+      | 'A' .. 'Z' | 'a' .. 'z' -> true
+      | _ -> false
+    in
+    String.length s >= 2 && is_letter s.[0] && s.[1] = ':'
+  let drive_and_path s =
+    if has_drive s
+    then (String.sub s 0 2, String.sub s 2 (String.length s - 2))
+    else ("", s)
+  let dirname s =
+    let (drive, path) = drive_and_path s in
+    let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in
+    drive ^ dir
+  let basename s =
+    let (_drive, path) = drive_and_path s in
+    generic_basename rindex_dir_sep current_dir_name path
+end
+
+module Cygwin = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let dir_sep = "/"
+  let is_dir_sep = Win32.is_dir_sep
+  let rindex_dir_sep = Win32.rindex_dir_sep
+  let is_relative = Win32.is_relative
+  let is_implicit = Win32.is_implicit
+  let check_suffix = Win32.check_suffix
+  let temp_dir_name = Unix.temp_dir_name
+  let quote = Unix.quote
+  let basename = generic_basename rindex_dir_sep current_dir_name
+  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+end
+
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+     is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
+     dirname) =
+  match Sys.os_type with
+    "Unix" ->
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+       Unix.is_dir_sep, Unix.rindex_dir_sep,
+       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
+  | "Win32" ->
+      (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
+       Win32.is_dir_sep, Win32.rindex_dir_sep,
+       Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
+       Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
+  | "Cygwin" ->
+      (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
+       Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
+       Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
+       Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
+  | _ -> assert false
+
+let concat dirname filename =
+  let l = String.length dirname in
+  if l = 0 || is_dir_sep dirname (l-1)
+  then dirname ^ filename
+  else dirname ^ dir_sep ^ filename
+
+let chop_suffix name suff =
+  let n = String.length name - String.length suff in
+  if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
+
+let chop_extension name =
+  let rec search_dot i =
+    if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension"
+    else if name.[i] = '.' then String.sub name 0 i
+    else search_dot (i - 1) in
+  search_dot (String.length name - 1)
+
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external close_desc: int -> unit = "caml_sys_close"
+
+let prng = Random.State.make_self_init ();;
+
+let temp_file_name temp_dir prefix suffix =
+  let rnd = (Random.State.bits prng) land 0xFFFFFF in
+  concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
+;;
+
+let temp_file ?(temp_dir=temp_dir_name) prefix suffix =
+  let rec try_name counter =
+    let name = temp_file_name temp_dir prefix suffix in
+    try
+      close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
+      name
+    with Sys_error _ as e ->
+      if counter >= 1000 then raise e else try_name (counter + 1)
+  in try_name 0
+
+let open_temp_file ?(mode = [Open_text]) ?(temp_dir=temp_dir_name) prefix suffix =
+  let rec try_name counter =
+    let name = temp_file_name temp_dir prefix suffix in
+    try
+      (name,
+       open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name)
+    with Sys_error _ as e ->
+      if counter >= 1000 then raise e else try_name (counter + 1)
+  in try_name 0

File filename_new.mli

+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Operations on file names. *)
+
+val current_dir_name : string
+(** The conventional name for the current directory (e.g. [.] in Unix). *)
+
+val parent_dir_name : string
+(** The conventional name for the parent of the current directory
+   (e.g. [..] in Unix). *)
+
+val dir_sep : string
+(** The directory separator (e.g. [/] in Unix). @since 3.11.2 *)
+
+val concat : string -> string -> string
+(** [concat dir file] returns a file name that designates file
+   [file] in directory [dir]. *)
+
+val is_relative : string -> bool
+(** Return [true] if the file name is relative to the current
+   directory, [false] if it is absolute (i.e. in Unix, starts
+   with [/]). *)
+
+val is_implicit : string -> bool
+(** Return [true] if the file name is relative and does not start
+   with an explicit reference to the current directory ([./] or
+   [../] in Unix), [false] if it starts with an explicit reference
+   to the root directory or the current directory. *)
+
+val check_suffix : string -> string -> bool
+(** [check_suffix name suff] returns [true] if the filename [name]
+   ends with the suffix [suff]. *)
+
+val chop_suffix : string -> string -> string
+(** [chop_suffix name suff] removes the suffix [suff] from
+   the filename [name]. The behavior is undefined if [name] does not
+   end with the suffix [suff]. *)
+
+val chop_extension : string -> string
+(** Return the given file name without its extension. The extension
+   is the shortest suffix starting with a period and not including
+   a directory separator, [.xyz] for instance.
+
+   Raise [Invalid_argument] if the given name does not contain
+   an extension. *)