Permalink
Browse files

Sqlexpr_sqlite, pa_sql: recover polymorphism in sqlc"..." expressions…

…/stmts.
  • Loading branch information...
1 parent 61b2c77 commit 6090e678eb8ced1bc0bd2e84ead36ef0e151c502 @mfp committed Nov 1, 2010
Showing with 66 additions and 41 deletions.
  1. +1 −1 example.ml
  2. +21 −8 pa_sql.ml
  3. +32 −21 sqlexpr_sqlite.ml
  4. +12 −11 sqlexpr_sqlite.mli
View
@@ -13,7 +13,7 @@ let init_db db =
);"
let fold_users db f acc =
- S.fold db f acc sql"SELECT @s{login}, @s{password}, @s?{email} FROM users"
+ S.fold db f acc sqlc"SELECT @s{login}, @s{password}, @s?{email} FROM users"
let insert_user db ~login ~password ?name ?email () =
S.insert db
View
@@ -140,11 +140,21 @@ let create_sql_statement _loc ~cacheable sql_elms =
let exp =
List.fold_right
(fun dir e -> <:expr< $directive_expr dir$ $e$ >>) sql_elms <:expr< $lid:k$ >> in
- let cacheable = if cacheable then <:expr< True >> else <:expr< False >> in
+ let id =
+ let signature =
+ sprintf "%d-%f-%d-%S"
+ (Unix.getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF)
+ (sql_statement sql_elms)
+ in Digest.to_hex (Digest.string signature) in
+ let stmt_id =
+ if cacheable then <:expr< Some $str:id$ >> else <:expr< None >>
+ in
<:expr<
- Sqlexpr.make_statement ~cacheable:$cacheable$
- $str:sql_statement sql_elms$
- (fun [$lid:k$ -> fun [$lid:st$ -> $exp$ $lid:st$]]) >>
+ {
+ Sqlexpr.sql_statement = $str:sql_statement sql_elms$;
+ stmt_id = $stmt_id$;
+ directive = (fun [$lid:k$ -> fun [$lid:st$ -> $exp$ $lid:st$]])
+ } >>
let create_sql_expression _loc ~cacheable (sql_elms : sql_element list) =
let statement = create_sql_statement _loc ~cacheable sql_elms in
@@ -182,10 +192,12 @@ let create_sql_expression _loc ~cacheable (sql_elms : sql_element list) =
in <:expr< fun [$lid:id$ -> $e$] >>
in
<:expr<
- Sqlexpr.make_expression
- $statement$
- $int:string_of_int (List.length conv_exprs)$
- $tuple_func$ >>
+ {
+ Sqlexpr.statement = $statement$;
+ get_data = ($int:string_of_int (List.length conv_exprs)$,
+ $tuple_func$);
+ }
+ >>
let expand_sql_literal ?(is_init = false) ~cacheable ctx _loc str =
let sql_elms = parse (unescape _loc str) in
@@ -261,6 +273,7 @@ let expand_sqlite_check_functions ctx _loc =
>>
let _ =
+ Random.self_init ();
register_expr_specifier "sql"
(fun ctx _loc str -> expand_sql_literal ~cacheable:false ctx _loc str);
register_expr_specifier "sqlinit"
View
@@ -22,7 +22,7 @@ type db =
db : Sqlite3.db;
id : int;
stmts : WT.t;
- mutable stmt_caches : Sqlite3.stmt IH.t list;
+ mutable cached_stmts : string list;
}
let () =
@@ -40,18 +40,28 @@ let new_id =
let n = ref 0 in
fun () -> incr n; !n
+let global_stmt_cache = Hashtbl.create 13
+
let open_db fname =
{
db = Sqlite3.db_open fname; id = new_id (); stmts = WT.create 13;
- stmt_caches = [];
+ cached_stmts = [];
}
let close_db db =
try
WT.iter
(fun stmt -> ignore (Sqlite3.finalize stmt))
db.stmts;
- List.iter (fun cache -> IH.remove cache db.id) db.stmt_caches;
+ List.iter
+ (fun id ->
+ try
+ let key = (db.id, id) in
+ let stmt = Hashtbl.find global_stmt_cache key in
+ ignore (Sqlite3.finalize stmt);
+ Hashtbl.remove global_stmt_cache key
+ with Not_found -> ())
+ db.cached_stmts;
ignore (Sqlite3.db_close db.db)
with Sqlite3.Error _ -> () (* FIXME: raise? *)
@@ -103,12 +113,13 @@ module Directives =
struct
module D = Sqlite3.Data
- type st = (Sqlite3.Data.t list * int * string * Sqlite3.stmt IH.t option)
+ (* (params, nparams, sql, stmt_id) *)
+ type st = (Sqlite3.Data.t list * int * string * string option)
and ('a, 'b) statement =
{
sql_statement : string;
- stmt_cache : Sqlite3.stmt IH.t option;
+ stmt_id : string option;
directive : ('a, 'b) directive
}
@@ -284,7 +295,12 @@ struct
open Directives
- type ('a, 'b) statement = ('a, 'b) Directives.statement
+ type ('a, 'b) statement = ('a, 'b) Directives.statement =
+ {
+ sql_statement : string;
+ stmt_id : string option;
+ directive : ('a, 'b) directive
+ }
type ('a, 'b, 'c) expression = {
statement : ('a, 'c) statement;
@@ -301,15 +317,6 @@ struct
let close_db = close_db
let sqlite_db = sqlite_db
- let make_statement ~cacheable sql directive =
- {
- sql_statement = sql;
- stmt_cache = if cacheable then Some (IH.create 13) else None;
- directive = directive;
- }
-
- let make_expression stmt n f = { statement = stmt; get_data = (n, f) }
-
let rec check_ok ?stmt ?sql ?params db f x = match f x with
Sqlite3.Rc.OK | Sqlite3.Rc.DONE -> return ()
| Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED ->
@@ -321,24 +328,28 @@ struct
let maybe_not_found f x = try Some (f x) with Not_found -> None
- let prepare db f (params, nparams, sql, cache) =
+ let prepare db f (params, nparams, sql, stmt_id) =
lwt stmt =
try_lwt
- match cache with
+ match stmt_id with
None ->
profile_prepare_stmt sql
(fun () ->
let stmt = Sqlite3.prepare db.db sql in
WT.add db.stmts stmt;
return stmt)
- | Some cache -> match maybe_not_found (IH.find cache) db.id with
+ | Some id ->
+ match maybe_not_found
+ (Hashtbl.find global_stmt_cache)
+ (db.id, id)
+ with
Some stmt -> check_ok ~stmt db Sqlite3.reset stmt >> return stmt
| None ->
profile_prepare_stmt sql
(fun () ->
let stmt = Sqlite3.prepare db.db sql in
- IH.add cache db.id stmt;
- db.stmt_caches <- cache :: db.stmt_caches;
+ Hashtbl.add global_stmt_cache (db.id, id) stmt;
+ db.cached_stmts <- id :: db.cached_stmts;
WT.add db.stmts stmt;
return stmt)
with e ->
@@ -354,7 +365,7 @@ struct
profile_execute_sql sql ~params (fun () -> f stmt sql params)
let do_select f db p =
- p.directive (prepare db f) ([], 0, p.sql_statement, p.stmt_cache)
+ p.directive (prepare db f) ([], 0, p.sql_statement, p.stmt_id)
let execute db (p : ('a, unit M.t) statement) =
do_select (fun stmt sql params ->
View
@@ -62,17 +62,18 @@ sig
val maybe_bool : Sqlite3.Data.t -> bool option M.t
end
- type ('a, 'b) statement
-
- type ('a, 'b, 'c) expression
-
- val make_statement :
- cacheable:bool -> string ->
- ('a, 'b) Directives.directive -> ('a, 'b) statement
-
- val make_expression :
- ('a, 'c) statement -> int -> (Sqlite3.Data.t array -> 'b) ->
- ('a, 'b, 'c) expression
+ type ('a, 'b) statement =
+ {
+ sql_statement : string;
+ stmt_id : string option;
+ directive : ('a, 'b) Directives.directive;
+ }
+
+ type ('a, 'b, 'c) expression =
+ {
+ statement : ('a, 'c) statement;
+ get_data : int * (Sqlite3.Data.t array -> 'b);
+ }
val execute : db -> ('a, unit M.t) statement -> 'a
val insert : db -> ('a, int64 M.t) statement -> 'a

0 comments on commit 6090e67

Please sign in to comment.