From cdd504ea9f9dcf4cfe18756e48319b7a9df296cd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 7 Sep 2010 09:06:13 -0400 Subject: 'tryDml' works with Postgres --- include/urweb.h | 1 + src/c/urweb.c | 9 +++++ src/cjr_print.sml | 12 ++----- src/mysql.sml | 4 +-- src/postgres.sml | 98 ++++++++++++++++++++++++++++++++++++++++++++++++++----- src/sqlite.sml | 4 +-- tests/tryDml.ur | 6 ++-- 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
%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 {[o1]}; {[o2]} + o2 <- tryDml (INSERT INTO t (Id) VALUES (2)); + dml (INSERT INTO t (Id) VALUES (3)); + o3 <- tryDml (INSERT INTO t (Id) VALUES (3)); + return {[o1]}; {[o2]}; {[o3]} fun main () = return
-- cgit v1.2.3