diff --git a/src/letsqlite.ml b/src/letsqlite.ml index a74097c..83bf0c6 100644 --- a/src/letsqlite.ml +++ b/src/letsqlite.ml @@ -1,11 +1,12 @@ module S = Sqlite3 module Rc = S.Rc +type stmt_wrap = bool * S.stmt type 'a stmt_m = | Failed of Rc.t -| Norm of ('a * S.stmt) +| Norm of ('a * stmt_wrap) -type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m +type ('a,'b) monad_fun = ('a * stmt_wrap) -> 'b stmt_m type rowdata = (string, Sqlite3.Data.t) Hashtbl.t (* Monad definitions *) let (>>$) s f = match s with @@ -13,6 +14,7 @@ let (>>$) s f = match s with | Norm (x,s) -> f (x,s) let (let$) = (>>$) + let (>-$) s f = match s with | Failed r -> Failed r | Norm (x,s) -> (match f (x,s) with @@ -21,13 +23,17 @@ let (>-$) s f = match s with ) let (@>$) s f = fun x -> s x >>$ f +let gs (_,s) = s + (* Helper definitions *) let transform f (v,s) = Norm ((f v),s) let inject v = transform (fun _ -> v) -let fail er (_,s) = - let er2 = S.finalize s - in if Rc.is_success er then Failed er2 - else Failed er +let fail er (_,(b,s)) = + if b then Failed er else ( + let er2 = S.finalize s + in if Rc.is_success er then Failed er2 + else Failed er + ) let stmtfail er s = fail er ((),s) let lift_err e tp = if Rc.is_success e then Norm tp @@ -39,32 +45,34 @@ let arr_to_tbl tbl keys vals = Array.iteri (fun i x -> Hashtbl.add tbl x vals.(i)) keys let create_rowtbl s rowdata = - let keys = S.row_names s + let keys = S.row_names (gs s) in let tbl = Hashtbl.create (Array.length keys) in arr_to_tbl tbl keys rowdata; tbl (* Monadic functions *) -let prepare db stmt v = - try Norm (v,(S.prepare db stmt)) with +let prepare_keep keep db stmt v = + try Norm (v,(keep, S.prepare db stmt)) with _ -> Failed Rc.ERROR -let reprepare db stmt (v,s) = - let x = S.finalize s +let prepare db s v = prepare_keep false db s v +let reprepare db stmt (v,(b,s)) = + let x = if not b then S.finalize s + else Rc.OK in if Rc.is_success x then prepare db stmt v else Failed x -let reset (v,s) = lift_err (S.reset s) (v,s) -let step (v,s) = lift_err (S.step s) (v,s) -let bind_values l (v,s) = lift_err (S.bind_values s l) (v,s) -let clear_bindings (v,s) = lift_err (S.clear_bindings s) (v,s) +let reset (v,s) = lift_err (S.reset (gs s)) (v,s) +let step (v,s) = lift_err (S.step (gs s)) (v,s) +let bind_values l (v,s) = lift_err (S.bind_values (gs s) l) (v,s) +let clear_bindings (v,s) = lift_err (S.clear_bindings (gs s)) (v,s) -let execif r v = if Rc.is_success r then Norm v else Failed r +let execif r v = if Rc.is_success r then Norm v else fail r v let rowfold f (init,s) = let rec fold acc ((),s) = - let r = S.step s + let r = S.step (gs s) in if r = Rc.ROW then - match f acc (create_rowtbl s (S.row_data s)) with + match f acc (create_rowtbl s (S.row_data (gs s))) with | Error r -> stmtfail r s | Ok x -> fold x ((),s) else execif r (acc,s) @@ -81,7 +89,7 @@ let map f l (ival,s) = | [] -> Norm (b,s) | h::t -> let$ v,s = f h (ival,s) - in map t (v::b,s) + in map t (v::b, s) in let$ (v,s) = map l ([],s) in Norm (List.rev v, s) @@ -90,11 +98,11 @@ let rec fold f l (v,s) = match l with | h::t -> f h (v,s) >>$ fold f t let get_exactly_one_row (_,s) = - let r = S.step s + let r = S.step (gs s) in match r with - | Rc.ROW -> if S.data_count s = 0 then stmtfail Rc.NOTFOUND s - else let tbl = create_rowtbl s (S.row_data s) - in let r = S.step s + | Rc.ROW -> if S.data_count (gs s) = 0 then stmtfail Rc.NOTFOUND s + else let tbl = create_rowtbl s (S.row_data (gs s)) + in let r = S.step (gs s) in if Rc.is_success r then reset (((),tbl),s) else stmtfail r s @@ -113,7 +121,9 @@ let extract name conv tu = let finalize = function | Failed e -> raise (S.SqliteError (Rc.to_string e)) -| Norm (v,s) -> Rc.check (S.finalize s); v +| Norm (v,(b,s)) -> if b then v else ( + Rc.check (S.finalize s); v + ) let exec db s = prepare db s () >>$ step let reexec db s = reprepare db s @>$ step diff --git a/src/letsqlite.mli b/src/letsqlite.mli index c0ecc45..1449f31 100644 --- a/src/letsqlite.mli +++ b/src/letsqlite.mli @@ -5,9 +5,11 @@ Types used for monad composition. *) +type stmt_wrap = bool * Sqlite3.stmt + type 'a stmt_m = | Failed of Sqlite3.Rc.t -| Norm of ('a * Sqlite3.stmt) +| Norm of ('a * stmt_wrap) (** The ['a] value in the [stmt_m] is referred to as the bundled value. A function may "fail with [e]", in which it returns [Failed e], @@ -17,11 +19,15 @@ type 'a stmt_m = The bundled {!Sqlite.stmt} value is refered to as [S], and the value bundled is refered to as [V]. + The boolean value is the {i preserve on failure} flag. When true, + monadic functions will not call {!Sqlite3.finalize} on the contained + statement. {b This will cause a memory leak if not handled correctly.} + {i Never directly use [Failed].} You run the likelihood of leaking - memory. + memory or causing a crash. *) -type ('a,'b) monad_fun = ('a * Sqlite3.stmt) -> 'b stmt_m +type ('a,'b) monad_fun = ('a * stmt_wrap) -> 'b stmt_m type rowdata = (string, Sqlite3.Data.t) Hashtbl.t @@ -49,6 +55,9 @@ val (>-$) : 'a stmt_m -> ('a,'b) monad_fun -> 'a stmt_m passes the original [V] through. *) +val gs : stmt_wrap -> Sqlite3.stmt +(** [gs s] returns the statment in an instance of [stmt_wrap]. *) + (** {1 Non-Execution Functions} These functions do not execute any SQL queries. They exist to make dealing @@ -67,7 +76,7 @@ val fail : Sqlite3.Rc.t -> ('a,'b) monad_fun of {!Sqlite3.finalize} otherwise. *) -val stmtfail : Sqlite3.Rc.t -> Sqlite3.stmt -> unit stmt_m +val stmtfail : Sqlite3.Rc.t -> stmt_wrap -> unit stmt_m (** [stmtfail e s] is equivalent to [fail] except it assembles a statement with unit type. *) @@ -93,6 +102,11 @@ val prepare : Sqlite3.db -> string -> 'a -> 'a stmt_m the statement in [s]. *) +val prepare_keep : bool -> Sqlite3.db -> string -> 'a -> 'a stmt_m +(** [prepare_keep b] is like [prepare], but [b] is the preserve-on-failure + file. +*) + val reprepare : Sqlite3.db -> string -> ('a,'a) monad_fun (** [reprepare db stmt] finalizes [S] and prepares [stmt] in its place. *)