diff --git a/sqlexpr_sqlite.ml b/sqlexpr_sqlite.ml index 4668de8..6d46199 100644 --- a/sqlexpr_sqlite.ml +++ b/sqlexpr_sqlite.ml @@ -2,7 +2,7 @@ open Printf open ExtList -exception Error of exn +exception Error of string * exn exception Sqlite_error of string * Sqlite3.Rc.t let curr_thread_id () = Thread.id (Thread.self ()) @@ -17,7 +17,7 @@ let raise_thread_error ?msg expected = expected actual (Option.map_default ((^) " ") "" msg) - in raise (Error (Failure s)) + in raise (Error (s, (Failure s))) module Stmt = struct @@ -53,9 +53,8 @@ include Types let () = Printexc.register_printer (function - | Error exn -> - Some (sprintf "Sqlexpr_sqlite.Error %s" - (Printexc.to_string exn)) + | Error (s, exn) -> + Some (sprintf "Sqlexpr_sqlite.Error (%S, %s)" s (Printexc.to_string exn)) | Sqlite_error (s, rc) -> Some (sprintf "Sqlexpr_sqlite.Sqlite_error (%S, %s)" s (Sqlite3.Rc.to_string rc)) @@ -254,8 +253,8 @@ let () = module Error(M : THREAD) = struct - let raise_exn exn = M.fail (Error exn) - let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (Failure s))) fmt + let raise_exn ?(msg="") exn = M.fail (Error (msg, exn)) + let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (s, Failure s))) fmt end module Profile(Lwt : Sqlexpr_concurrency.THREAD) = @@ -394,7 +393,7 @@ struct None | Some [] -> msg | Some params -> sprintf "%s with params %s" msg (string_of_params (List.rev params)) - in M.fail (Error (Sqlite_error (msg, errcode))) + in M.fail (Error (msg, Sqlite_error (msg, errcode))) let rec run ?stmt ?sql ?params db f x = match f x with Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r @@ -437,7 +436,9 @@ struct WT.add db.stmts stmt; return stmt) with e -> - failwithfmt "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) in + let msg = + sprintf "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) + in raise_exn ~msg e in let rec iteri ?(i = 0) f = function [] -> return () | hd :: tl -> f i hd >> iteri ~i:(i + 1) f tl @@ -495,7 +496,7 @@ sig type db - exception Error of exn + exception Error of string * exn exception Sqlite_error of string * Sqlite3.Rc.t val open_db : ?init:(Sqlite3.db -> unit) -> string -> db diff --git a/sqlexpr_sqlite.mli b/sqlexpr_sqlite.mli index bd72ff1..e758366 100644 --- a/sqlexpr_sqlite.mli +++ b/sqlexpr_sqlite.mli @@ -11,11 +11,11 @@ type st = Types.st (** All the exceptions raised by the code in {Sqlexpr_sqlite} are wrapped in Error except when indicated otherwise. *) -exception Error of exn +exception Error of string * exn (** Errors reported by SQLite are converted into [Sqlite_error _] exceptions, so they can be matched with - [try ... with Sqlexpr.Error (Sqlexpr.sqlite_error _)] *) + [try ... with Sqlexpr.Error (_, Sqlexpr.sqlite_error _)] *) exception Sqlite_error of string * Sqlite3.Rc.t (** *) @@ -44,7 +44,7 @@ sig (** Exception identical to the toplevel [Error], provided for convenience. Note that [Sqlexpr_sqlite.Error _] matches this exception. *) - exception Error of exn + exception Error of string * exn (** Exception identical to the toplevel [Sqlite_error], provided for convenience. Note that [Sqlexpr_sqlite.Sqlite_error _] matches this diff --git a/sqlexpr_sqlite_lwt.ml b/sqlexpr_sqlite_lwt.ml index 736f37d..c3130af 100644 --- a/sqlexpr_sqlite_lwt.ml +++ b/sqlexpr_sqlite_lwt.ml @@ -53,7 +53,8 @@ struct let close_db db = db.max_threads <- 0; db.db_finished <- true; - let e = Error (Failure (sprintf "Handle closed for DB %S" db.file)) in + let msg = sprintf "Handle closed for DB %S" db.file in + let e = Error (msg, Failure msg) in Lwt_sequence.iter_l (fun u -> wakeup_exn u e) db.waiters; Queue.iter (fun worker -> @@ -187,7 +188,7 @@ struct None | Some [] -> msg | Some params -> sprintf "%s with params %s" msg (string_of_params (List.rev params)) - in raise (Error (Sqlite_error (msg, errcode))) + in raise (Error (msg, Sqlite_error (msg, errcode))) let raise_error worker ?sql ?params ?errmsg errcode = lwt errmsg = match errmsg with @@ -241,7 +242,8 @@ struct return stmt) with e -> add_worker db worker; - failwithfmt "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) + let s = sprintf "Error with SQL statement %s" sql in + raise_lwt (Error (s, e)) in (* the list of params is reversed *) detach worker