summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml74
-rw-r--r--src/mysql.sml6
-rw-r--r--src/postgres.sml73
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml8
5 files changed, 94 insertions, 71 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index ee9011b7..a5a67401 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1751,81 +1751,23 @@ fun p_exp' par env (e, loc) =
box [string "(uw_begin_region(ctx), ",
string "({",
newline,
- string "PGconn *conn = uw_get_db(ctx);",
+ string "uw_Basis_int n;",
newline,
+
case prepared of
NONE => box [string "char *query = ",
p_exp env query,
string ";",
- newline]
- | SOME _ =>
- box [],
- newline,
- string "PGresult *res = ",
- case prepared of
- NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
- | SOME (n, s) =>
- if #persistent (Settings.currentProtocol ()) then
- box [string "PQexecPrepared(conn, \"uw",
- string (Int.toString n),
- string "\", 0, NULL, NULL, NULL, 0);"]
- else
- box [string "PQexecParams(conn, \"uw",
- string (Int.toString n),
- string "\", 0, NULL, NULL, NULL, NULL, 0);"],
- newline,
- string "uw_Basis_int n;",
- newline,
- newline,
-
- string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
- newline,
- newline,
-
- string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
- newline,
- box [string "PQclear(res);",
- newline,
- string "uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Query failed:\\n%s\\n%s\", ",
- case prepared of
- NONE => string "query"
- | SOME _ => p_exp env query,
- string ", PQerrorMessage(conn));",
- newline],
- string "}",
- newline,
- newline,
+ newline,
+ newline,
- string "uw_end_region(ctx);",
- newline,
- string "n = PQntuples(res);",
- newline,
- string "if (n != 1) {",
- newline,
- box [string "PQclear(res);",
- newline,
- string "uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Wrong number of result rows:\\n%s\\n%s\", ",
- case prepared of
- NONE => string "query"
- | SOME _ => p_exp env query,
- string ", PQerrorMessage(conn));",
- newline],
- string "}",
+ #nextval (Settings.currentDbms ()) loc]
+ | SOME (id, query) => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
+ id = id,
+ query = query},
newline,
newline,
- string "n = ",
- p_unsql true env (TFfi ("Basis", "int"), loc)
- (string "PQgetvalue(res, 0, 0)")
- (box []),
- string ";",
- newline,
- string "PQclear(res);",
- newline,
string "n;",
newline,
string "}))"]
diff --git a/src/mysql.sml b/src/mysql.sml
index 27b4ca77..6f3d99cd 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -257,6 +257,8 @@ fun query _ = raise Fail "MySQL query"
fun queryPrepared _ = raise Fail "MySQL queryPrepared"
fun dml _ = raise Fail "MySQL dml"
fun dmlPrepared _ = raise Fail "MySQL dmlPrepared"
+fun nextval _ = raise Fail "MySQL nextval"
+fun nextvalPrepared _ = raise Fail "MySQL nextvalPrepared"
val () = addDbms {name = "mysql",
header = "mysql/mysql.h",
@@ -277,6 +279,8 @@ val () = addDbms {name = "mysql",
query = query,
queryPrepared = queryPrepared,
dml = dml,
- dmlPrepared = dmlPrepared}
+ dmlPrepared = dmlPrepared,
+ nextval = nextval,
+ nextvalPrepared = nextvalPrepared}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index 01777843..b1390bc4 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -472,6 +472,75 @@ fun dmlPrepared {loc, id, dml, inputs} =
string (String.toString dml),
string "\""]}]
+fun nextvalCommon {loc, query} =
+ box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
+ newline,
+ newline,
+
+ string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
+ newline,
+ box [string "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Query failed:\\n%s\\n%s\", ",
+ query,
+ string ", PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "uw_end_region(ctx);",
+ newline,
+ string "n = PQntuples(res);",
+ newline,
+ string "if (n != 1) {",
+ newline,
+ box [string "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Wrong number of result rows:\\n%s\\n%s\", ",
+ query,
+ string ", PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));",
+ newline,
+ string "PQclear(res);",
+ newline]
+
+fun nextval loc =
+ box [string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
+ newline,
+ newline,
+ nextvalCommon {loc = loc, query = string "query"}]
+
+fun nextvalPrepared {loc, id, query} =
+ box [string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ newline,
+ string "PGresult *res = ",
+ if #persistent (Settings.currentProtocol ()) then
+ box [string "PQexecPrepared(conn, \"uw",
+ string (Int.toString id),
+ string "\", 0, NULL, NULL, NULL, 0);"]
+ else
+ box [string "PQexecParams(conn, \"",
+ string (String.toString query),
+ string "\", 0, NULL, NULL, NULL, NULL, 0);"],
+ newline,
+ newline,
+ nextvalCommon {loc = loc, query = box [string "\"",
+ string (String.toString query),
+ string "\""]}]
+
val () = addDbms {name = "postgres",
header = "postgresql/libpq-fe.h",
link = "-lpq",
@@ -481,7 +550,9 @@ val () = addDbms {name = "postgres",
query = query,
queryPrepared = queryPrepared,
dml = dml,
- dmlPrepared = dmlPrepared}
+ dmlPrepared = dmlPrepared,
+ nextval = nextval,
+ nextvalPrepared = nextvalPrepared}
val () = setDbms "postgres"
end
diff --git a/src/settings.sig b/src/settings.sig
index 9912b0e1..3b897353 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -138,7 +138,9 @@ signature SETTINGS = sig
-> 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
+ inputs : sql_type list} -> Print.PD.pp_desc,
+ nextval : ErrorMsg.span -> Print.PD.pp_desc,
+ nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc
}
val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 86d8afa9..8ad1d3f6 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -324,7 +324,9 @@ type dbms = {
-> 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
+ inputs : sql_type list} -> Print.PD.pp_desc,
+ nextval : ErrorMsg.span -> Print.PD.pp_desc,
+ nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc
}
val dbmses = ref ([] : dbms list)
@@ -336,7 +338,9 @@ val curDb = ref ({name = "",
query = fn _ => Print.box [],
queryPrepared = fn _ => Print.box [],
dml = fn _ => Print.box [],
- dmlPrepared = fn _ => Print.box []} : dbms)
+ dmlPrepared = fn _ => Print.box [],
+ nextval = fn _ => Print.box [],
+ nextvalPrepared = fn _ => Print.box []} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 01:34:46 +0000