Commits

Anonymous committed a5aa059

mono prob

Comments (0)

Files changed (4)

src/dbi/amall-dbi.mllib

 Dbi_common
 Dbi_pg
 # OASIS_STOP
+Decimal

src/dbi/dbi_common.ml

     value (run2 : af2 'x 'y 'a -> 'x -> 'y -> 'a) af2 x y = af2 x y;
   end
 ;
-
-
-type dbtypecomb 'a = Af2.af2 rectype record
-;
-
-type record_type =
-;

src/dbi/dbi_pg.ml

 при умножении-делении округлять до максимальной точности аргументов.
 
 
+
+todo: в entype передавать P.result + row + col
+
+
 *)
 
 
 ;
 
 
+type typer 'a 'r = Postgresql.ftype -> bool -> string -> ('a -> 'r) -> 'r
+;
+
+
 (* строгий, чоткий, кидает исключения: *)
 module Typer
+ :
+  sig
+    value string : typer string 'a;
+  end
  =
   struct
 
-
     value do_check_error ~nullable ~want_ftype ~msg =
       failwith "Dbi_pg.Typer: %s%s expected, %s found"
-          (if nullable then "optional " else "")
-          want_ftype
+        (if nullable then "optional " else "")
+        want_ftype
+        msg
     ;
 
 
-    value do_check ~nullable ~check_ftype ~want_ftype =
+    value do_check ~nullable ~check_ftype ~want_ftype ~ftype =
       if check_ftype ftype
       then ()
-      else do_check_error ~nullable ~want_ftype (P.string_of_ftype ftype)
+      else do_check_error ~nullable ~want_ftype ~msg:(P.string_of_ftype ftype)
     ;
 
     value convert_error ~want_ftype exn =
     ;
 
 
+    type typer2 'a 'r = (typer 'a 'r * typer (option 'a) 'r)
+    ;
+
     (* returns (notnull, nullable) *)
 
-    value common ~want_ftype ~check_ftype ~convert =
+    value common ~want_ftype ~check_ftype ~convert : typer2 _ _ =
       ( fun ftype isnull untyped func ->
-          ( do_check ~nullable:False ~check_ftype ~want_ftype
+          ( do_check ~nullable:False ~check_ftype ~want_ftype ~ftype
           ; if isnull
             then
               do_check_error ~nullable:False ~want_ftype
             with [e -> convert_error ~want_ftype e]
           )
       , fun ftype isnull untyped func ->
-          ( do_check ~nullable:True ~check_ftype ~want_ftype
+          ( do_check ~nullable:True ~check_ftype ~want_ftype ~ftype
           ; try
               func (if isnull then None else Some (convert untyped))
             with [e -> convert_error ~want_ftype e]
       ]
     ;
 
-    value (string, string_opt) = common
+    value (string, string_opt) : typer2 string _ = common
       ~want_ftype:"string (char, text, name, varchar)"
       ~check_ftype:string_check
       ~convert:identity
     ;
 
-    value (binary, binary_opt) = common
+    value (binary, binary_opt) : typer2 string _ = common
       ~want_ftype:"bytea"
       ~check_ftype:((=) P.BYTEA)
       ~convert:identity
 
 
 
-todo: в entype передавать P.result + row + col
-
 
 value entype_t ftype ~isnull x : sql_t =
   try
 ;
 
 
+type ident = string
+;
+
+
 type record_signature = 
   { rs_names : array ident
-  ; rs_types : array ftype
+  ; rs_types : array Postgresql.ftype
   }
 ;
 
           str_arr
       )
   in
+  let names_lazy = lazy presult#get_fnames
+  in
   let record_signature_lazy = lazy
     { rs_names = Lazy.force names_lazy
     ; rs_types = Lazy.force col_ftypes_lazy
   object (self)
     inherit Dbi.result ['v];
 
-    value names_lazy = lazy presult#get_fnames;
-
     value mutable v_current_nrow = 0;
 
     method record_signature = Lazy.force record_signature_lazy;
   struct
     open Af2;
 
-    type record_processor = af2 record_signature record -- видимо sql_u?;
+    type record_processor 'a = af2 record_signature (array string) 'a;
 
   end
 ;

src/dbi/decimal.ml

+open Am_All
+;
+
+type t = private
+  { num : Num.t
+  ; scale : int
+  }
+;
+
+open Num
+;
+
+value make ~num ~scale = { num = num; scale = scale }
+;
+
+
+value is_decimal_point = fun [ '.' -> True | _ -> False ]
+;
+
+
+value get_scale s =
+  inner ~scale:0 ~found:False 0
+  where rec inner ~scale ~found i =
+    if i = String.length s
+    then a
+    else
+      let c = s.[i] in
+      match (found, scale, is_decimal_point c) with
+      [ (False, _, True) -> inner ~scale:0 ~found:True (i + 1)
+      | (True, _, True) -> failwith
+          "Decimal.get_scale: more than one decimal point"
+      | (False, _, False) -> inner ~scale ~found (i + 1)
+      | (True, scale, False) -> inner ~scale:(scale + 1) ~found (i + 1)
+      ]
+;
+
+
+value of_string s =
+  let n =
+    try
+      num_of_string s
+    with
+    [ e -> invalid_arg "Decimal.of_string %S: %s" s (Printexc.to_string e) ]
+  in
+  let scale = get_scale s
+  in
+    make ~num ~scale
+;
+
+
+value maxscale op = fun a b ->
+  make ~num: (op a b) ~scale: (max a.scale b.scale)
+;
+
+
+value add = maxscale add_num
+  and sub = maxscale sub_num
+;
+