summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2010-09-07 09:06:13 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2010-09-07 09:06:13 -0400
commitcdd504ea9f9dcf4cfe18756e48319b7a9df296cd (patch)
tree301967018e16a7c4e7c27b64e5e4b08f288eba7f
parent5545969f485ef2fb944db8e7b0237acbabeb8d4c (diff)
'tryDml' works with Postgres
-rw-r--r--include/urweb.h1
-rw-r--r--src/c/urweb.c9
-rw-r--r--src/cjr_print.sml12
-rw-r--r--src/mysql.sml4
-rw-r--r--src/postgres.sml98
-rw-r--r--src/sqlite.sml4
-rw-r--r--tests/tryDml.ur6
7 files changed, 111 insertions, 23 deletions
diff --git a/include/urweb.h b/include/urweb.h
index f254da2a..3f5bf285 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -44,6 +44,7 @@ int uw_rollback(uw_context);
__attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *fmt, ...);
char *uw_error_message(uw_context);
void uw_set_error_message(uw_context, const char *fmt, ...);
+uw_Basis_string uw_dup_and_clear_error_message(uw_context);
int uw_has_error(uw_context);
void uw_push_cleanup(uw_context, void (*func)(void *), void *arg);
void uw_pop_cleanup(uw_context);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cac518ec..747f62b6 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -2175,6 +2175,15 @@ uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) {
return s;
}
+uw_Basis_string uw_dup_and_clear_error_message(uw_context ctx) {
+ if (ctx->error_message[0]) {
+ char *s = uw_strdup(ctx, ctx->error_message);
+ ctx->error_message[0] = 0;
+ return s;
+ } else
+ return NULL;
+}
+
uw_Basis_string uw_maybe_strdup(uw_context ctx, uw_Basis_string s1) {
if (s1)
return uw_strdup(ctx, s1);
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 9b5edab5..5282ddc2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1794,10 +1794,7 @@ fun p_exp' par env (e, loc) =
end
| EDml {dml, prepared, mode} =>
- box [case mode of
- Settings.Error => box []
- | Settings.None => string "({const char *uw_errmsg = NULL;",
- string "(uw_begin_region(ctx), ({",
+ box [string "(uw_begin_region(ctx), ({",
newline,
case prepared of
NONE => box [string "char *dml = ",
@@ -1838,13 +1835,10 @@ fun p_exp' par env (e, loc) =
case mode of
Settings.Error => string "uw_unit_v;"
- | Settings.None => string "uw_errmsg ? uw_strdup(ctx, uw_errmsg) : NULL;",
+ | Settings.None => string "uw_dup_and_clear_error_message(ctx);",
newline,
- string "}))",
- case mode of
- Settings.Error => box []
- | Settings.None => string ";})"]
+ string "}))"]
| ENextval {seq, prepared} =>
box [string "({",
diff --git a/src/mysql.sml b/src/mysql.sml
index 44d88c1d..2f28f4dd 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2009, Adam Chlipala
+(* Copyright (c) 2009-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -1202,7 +1202,7 @@ fun dmlCommon {loc, dml, mode} =
string ": Error executing DML: %s\\n%s\", ",
dml,
string ", mysql_error(conn->conn));"]
- | Settings.None => string "uw_errmsg = mysql_error(conn->conn);",
+ | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
newline,
newline]
diff --git a/src/postgres.sml b/src/postgres.sml
index bf1e8536..0acd1bf3 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -731,19 +731,95 @@ fun dmlCommon {loc, dml, mode} =
string ": DML failed:\\n%s\\n%s\", ",
dml,
string ", PQerrorMessage(conn));"]
- | Settings.None => string "uw_errmsg = PQerrorMessage(conn);",
+ | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));",
+ newline,
+ newline,
+
+ string "res = PQexec(conn, \"ROLLBACK TO s\");",
+ 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 "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": ROLLBACK TO failed:\\n%s\\n%s\", ",
+ dml,
+ string ", PQerrorMessage(conn));",
+ newline,
+ string "}"],
+ newline,
+
+ string "PQclear(res);",
+ newline],
newline],
string "}",
- newline,
- newline,
- string "PQclear(res);",
- newline]
+ case mode of
+ Error => box [newline,
+ newline,
+ string "PQclear(res);",
+ newline]
+ | None => box[string " else {",
+ newline,
+ box [string "PQclear(res);",
+ newline,
+ string "res = PQexec(conn, \"RELEASE s\");",
+ 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 "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": RELEASE failed:\\n%s\\n%s\", ",
+ dml,
+ string ", PQerrorMessage(conn));",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
+ newline],
+ string "}",
+ newline]]
+
+fun makeSavepoint mode =
+ case mode of
+ Error => box []
+ | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");",
+ newline,
+ string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
+ newline,
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ box [newline,
+ string "PQclear(res);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
+ newline,
+ newline]
fun dml (loc, mode) =
box [string "PGconn *conn = uw_get_db(ctx);",
newline,
- string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
+ string "PGresult *res;",
+ newline,
+
+ makeSavepoint mode,
+
+ string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
newline,
newline,
dmlCommon {loc = loc, dml = string "dml", mode = mode}]
@@ -772,7 +848,13 @@ fun dmlPrepared {loc, id, dml, inputs, mode} =
string " };",
newline,
newline,
- string "PGresult *res = ",
+ string "PGresult *res;",
+ newline,
+ newline,
+
+ makeSavepoint mode,
+
+ string "res = ",
if #persistent (Settings.currentProtocol ()) then
box [string "PQexecPrepared(conn, \"uw",
string (Int.toString id),
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 20afd5bc..c87bd509 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2009, Adam Chlipala
+(* Copyright (c) 2009-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -708,7 +708,7 @@ fun dmlCommon {loc, dml, mode} =
string ": DML step failed: %s<br />%s\", ",
dml,
string ", sqlite3_errmsg(conn->conn));"]
- | Settings.None => string "uw_errmsg = sqlite3_errmsg(conn->conn);",
+ | Settings.None => string "uw_set_error_message(ctx, sqlite3_errmsg(conn->conn));",
newline]
fun dml (loc, mode) =
diff --git a/tests/tryDml.ur b/tests/tryDml.ur
index bfe98cdb..942cc1cb 100644
--- a/tests/tryDml.ur
+++ b/tests/tryDml.ur
@@ -5,8 +5,10 @@ fun doStuff () =
dml (INSERT INTO t (Id) VALUES (0));
o1 <- tryDml (INSERT INTO t (Id) VALUES (0));
dml (INSERT INTO t (Id) VALUES (1));
- o2 <- tryDml (INSERT INTO t (Id) VALUES (1));
- return <xml>{[o1]}; {[o2]}</xml>
+ o2 <- tryDml (INSERT INTO t (Id) VALUES (2));
+ dml (INSERT INTO t (Id) VALUES (3));
+ o3 <- tryDml (INSERT INTO t (Id) VALUES (3));
+ return <xml>{[o1]}; {[o2]}; {[o3]}</xml>
fun main () = return <xml><body>
<form> <submit action={doStuff}/> </form>