summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-06-28 16:22:17 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-06-28 16:22:17 -0400
commit566f9f69e1abbed1891e5eec4a94325c79572f16 (patch)
treea60c8ed4fb8703fb61d9844d7b02129464c2c6be
parent5a877e7f69430dbb6c5b1398b15a7b64916c39a8 (diff)
Moved dml code into Settings
-rw-r--r--src/cjr_print.sml85
-rw-r--r--src/mysql.sml6
-rw-r--r--src/postgres.sml85
-rw-r--r--src/settings.sig5
-rw-r--r--src/settings.sml9
5 files changed, 110 insertions, 80 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 92e15b51..ee9011b7 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1696,16 +1696,16 @@ fun p_exp' par env (e, loc) =
| EDml {dml, prepared} =>
box [string "(uw_begin_region(ctx), ({",
newline,
- string "PGconn *conn = uw_get_db(ctx);",
- newline,
case prepared of
NONE => box [string "char *dml = ",
p_exp env dml,
string ";",
- newline]
- | SOME _ =>
+ newline,
+ newline,
+ #dml (Settings.currentDbms ()) loc]
+ | SOME (id, dml') =>
let
- val ets = getPargs dml
+ val inputs = getPargs dml
in
box [p_list_sepi newline
(fn i => fn (e, t) =>
@@ -1718,83 +1718,18 @@ fun p_exp' par env (e, loc) =
space,
p_exp env e,
string ";"])
- ets,
+ inputs,
newline,
newline,
- string "const int paramFormats[] = { ",
- p_list_sep (box [string ",", space])
- (fn (_, t) => if isBlob t then string "1" else string "0") ets,
- string " };",
- newline,
- string "const int paramLengths[] = { ",
- p_list_sepi (box [string ",", space])
- (fn i => fn (_, Blob) => string ("arg" ^ Int.toString (i + 1) ^ ".size")
- | (_, Nullable Blob) => string ("arg" ^ Int.toString (i + 1)
- ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
- | _ => string "0") ets,
- string " };",
- newline,
- string "const char *paramValues[] = { ",
- p_list_sepi (box [string ",", space])
- (fn i => fn (_, t) => p_ensql t (box [string "arg",
- string (Int.toString (i + 1))]))
- ets,
- string " };",
- newline,
- newline]
+ #dmlPrepared (Settings.currentDbms ()) {loc = loc,
+ id = id,
+ dml = dml',
+ inputs = map #2 inputs}]
end,
newline,
newline,
- string "PGresult *res = ",
- case prepared of
- NONE => string "PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
- | SOME (n, s) =>
- if #persistent (Settings.currentProtocol ()) then
- box [string "PQexecPrepared(conn, \"uw",
- string (Int.toString n),
- string "\", ",
- string (Int.toString (length (getPargs dml))),
- string ", paramValues, paramLengths, paramFormats, 0);"]
- else
- box [string "PQexecParams(conn, \"",
- string (String.toString s),
- string "\", ",
- string (Int.toString (length (getPargs dml))),
- string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
- newline,
- newline,
-
- string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
- newline,
- newline,
- string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- newline,
- box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
- box [newline,
- string "PQclear(res);",
- newline,
- string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
- newline],
- string "}",
- newline,
- string "PQclear(res);",
- newline,
- string "uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": DML failed:\\n%s\\n%s\", ",
- case prepared of
- NONE => string "dml"
- | SOME _ => p_exp env dml,
- string ", PQerrorMessage(conn));",
- newline],
- string "}",
- newline,
- newline,
-
- string "PQclear(res);",
- newline,
string "uw_end_region(ctx);",
newline,
string "uw_unit_v;",
diff --git a/src/mysql.sml b/src/mysql.sml
index 976fefef..27b4ca77 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -255,6 +255,8 @@ fun init (dbstring, ss) =
fun query _ = raise Fail "MySQL query"
fun queryPrepared _ = raise Fail "MySQL queryPrepared"
+fun dml _ = raise Fail "MySQL dml"
+fun dmlPrepared _ = raise Fail "MySQL dmlPrepared"
val () = addDbms {name = "mysql",
header = "mysql/mysql.h",
@@ -273,6 +275,8 @@ val () = addDbms {name = "mysql",
newline],
init = init,
query = query,
- queryPrepared = queryPrepared}
+ queryPrepared = queryPrepared,
+ dml = dml,
+ dmlPrepared = dmlPrepared}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index 8239ec93..01777843 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -391,6 +391,87 @@ fun queryPrepared {loc, id, query, inputs, numCols, doCols} =
string (String.toString query),
string "\""]}]
+fun dmlCommon {loc, dml} =
+ box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
+ newline,
+ newline,
+
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ newline,
+ box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
+ box [newline,
+ string "PQclear(res);",
+ newline,
+ string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": DML failed:\\n%s\\n%s\", ",
+ dml,
+ string ", PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "PQclear(res);",
+ newline]
+
+fun dml loc =
+ box [string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
+ newline,
+ newline,
+ dmlCommon {loc = loc, dml = string "dml"}]
+
+fun dmlPrepared {loc, id, dml, inputs} =
+ box [string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "const int paramFormats[] = { ",
+ p_list_sep (box [string ",", space])
+ (fn t => if isBlob t then string "1" else string "0") inputs,
+ string " };",
+ newline,
+ string "const int paramLengths[] = { ",
+ p_list_sepi (box [string ",", space])
+ (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
+ | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
+ ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
+ | _ => string "0") inputs,
+ string " };",
+ newline,
+ string "const char *paramValues[] = { ",
+ p_list_sepi (box [string ",", space])
+ (fn i => fn t => p_ensql t (box [string "arg",
+ string (Int.toString (i + 1))]))
+ inputs,
+ string " };",
+ newline,
+ newline,
+ string "PGresult *res = ",
+ if #persistent (Settings.currentProtocol ()) then
+ box [string "PQexecPrepared(conn, \"uw",
+ string (Int.toString id),
+ string "\", ",
+ string (Int.toString (length inputs)),
+ string ", paramValues, paramLengths, paramFormats, 0);"]
+ else
+ box [string "PQexecParams(conn, \"",
+ string (String.toString dml),
+ string "\", ",
+ string (Int.toString (length inputs)),
+ string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
+ newline,
+ newline,
+ dmlCommon {loc = loc, dml = box [string "\"",
+ string (String.toString dml),
+ string "\""]}]
+
val () = addDbms {name = "postgres",
header = "postgresql/libpq-fe.h",
link = "-lpq",
@@ -398,7 +479,9 @@ val () = addDbms {name = "postgres",
newline],
init = init,
query = query,
- queryPrepared = queryPrepared}
+ queryPrepared = queryPrepared,
+ dml = dml,
+ dmlPrepared = dmlPrepared}
val () = setDbms "postgres"
end
diff --git a/src/settings.sig b/src/settings.sig
index 536f6a1f..9912b0e1 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -135,7 +135,10 @@ signature SETTINGS = sig
inputs : sql_type list, numCols : int,
doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
-> Print.PD.pp_desc}
- -> Print.PD.pp_desc
+ -> Print.PD.pp_desc,
+ dml : ErrorMsg.span -> Print.PD.pp_desc,
+ dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
+ inputs : sql_type list} -> Print.PD.pp_desc
}
val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 2e0a5ac8..86d8afa9 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -321,7 +321,10 @@ type dbms = {
inputs : sql_type list, numCols : int,
doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
-> Print.PD.pp_desc}
- -> Print.PD.pp_desc
+ -> Print.PD.pp_desc,
+ dml : ErrorMsg.span -> Print.PD.pp_desc,
+ dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
+ inputs : sql_type list} -> Print.PD.pp_desc
}
val dbmses = ref ([] : dbms list)
@@ -331,7 +334,9 @@ val curDb = ref ({name = "",
global_init = Print.box [],
init = fn _ => Print.box [],
query = fn _ => Print.box [],
- queryPrepared = fn _ => Print.box []} : dbms)
+ queryPrepared = fn _ => Print.box [],
+ dml = fn _ => Print.box [],
+ dmlPrepared = fn _ => Print.box []} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =