impl/sqlgg_mysql.ml

   1 (**
   2   Mysql OCaml traits for sqlgg
   3   by ygrek
   4   2015-07-09
   5
   6   This is free and unencumbered software released into the public domain.
   7
   8   Anyone is free to copy, modify, publish, use, compile, sell, or
   9   distribute this software, either in source code form or as a compiled
  10   binary, for any purpose, commercial or non-commercial, and by any
  11   means.
  12
  13   For more information, please refer to <http://unlicense.org/>
  14 *)
  15
  16 open Printf
  17
  18 module P = Mysql.Prepared
  19
  20 module Make(Number : sig type t val of_string : string -> t val to_string : t -> string end) = struct
  21
  22 type statement = P.stmt
  23 type connection = Mysql.dbd
  24 type params = statement * string array
  25 type row = string option array
  26 type result = P.stmt_result
  27
  28 type num = Number.t
  29 type text = string
  30 type any = string
  31 type datetime = float
  32
  33 exception Oops of string
  34 let oops fmt = ksprintf (fun s -> raise (Oops s)) fmt
  35
  36 let get_column_ty name conv row index =
  37   try
  38     conv (match row.(index) with None -> failwith "no value" | Some (x:string) -> x)
  39   with
  40     e -> oops "get_column_%s %i (%s)" name index (Printexc.to_string e)
  41
  42 let get_column_Bool = get_column_ty "Bool" (fun s -> s <> "0")
  43 let get_column_Int = get_column_ty "Int" Number.of_string
  44 let get_column_Text = get_column_ty "Text" (fun x -> x)
  45 let get_column_Float = get_column_ty "Float" float_of_string
  46 let get_column_Datetime = get_column_ty "Datetime" float_of_string
  47 let get_column_Any = get_column_Text
  48
  49 let bind_param data (_,params) index =
  50   match data with
  51   | Some s -> params.(index) <- s
  52   | None -> oops "bind_param None -- not implemented"
  53
  54 let start_params stmt n = (stmt,Array.make n "")
  55 let finish_params (stmt,params) = P.execute stmt params
  56
  57 let set_param_Text stmt index v = bind_param (Some v) stmt index
  58 let set_param_null stmt index = bind_param None stmt index
  59 let set_param_Any = set_param_Text
  60 let set_param_Bool stmt index v = bind_param (Some (if v then "1" else "0")) stmt index
  61 let set_param_Int stmt index v = bind_param (Some (Number.to_string v)) stmt index
  62 let set_param_Float stmt index v = bind_param (Some (string_of_float v)) stmt index
  63 let set_param_Datetime = set_param_Float
  64
  65 let no_params stmt = P.execute stmt [||]
  66
  67 let try_finally final f x =
  68   let r =
  69     try f x with exn -> final (); raise exn
  70   in
  71     final ();
  72     r
  73
  74 let bracket res dtor k = try_finally (fun () -> dtor res) k res
  75 let with_stmt db sql = bracket (P.create db sql) P.close
  76
  77 let select db sql set_params callback =
  78   with_stmt db sql (fun stmt ->
  79     let r = set_params stmt in
  80     let rec loop () =
  81       match P.fetch r with
  82       | Some row -> callback row; loop ()
  83       | None -> ()
  84     in
  85     loop ())
  86
  87 let execute db sql set_params =
  88   with_stmt db sql (fun stmt ->
  89     let _ = set_params stmt in
  90     if 0 <> P.real_status stmt then oops "execute : %s" sql;
  91     P.affected stmt)
  92
  93 let select1 db sql set_params callback =
  94   with_stmt db sql (fun stmt ->
  95     match P.fetch (set_params stmt) with
  96     | Some row -> Some (callback row)
  97     | None -> None)
  98
  99 end