Mercurial > urweb
changeset 869:64ba57fa20bf
Moved nextval code into Settings
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 28 Jun 2009 16:41:10 -0400 |
| parents | 06497beb265b |
| children | 7fa9a37a34b3 |
| files | src/cjr_print.sml src/mysql.sml src/postgres.sml src/settings.sig src/settings.sml |
| diffstat | 5 files changed, 95 insertions(+), 72 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Jun 28 16:22:17 2009 -0400 +++ b/src/cjr_print.sml Sun Jun 28 16:41:10 2009 -0400 @@ -1751,81 +1751,23 @@ 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, + + #nextval (Settings.currentDbms ()) loc] + | SOME (id, query) => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, + id = id, + query = query}, 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, - - 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 "}", - 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 "}))"]
--- a/src/mysql.sml Sun Jun 28 16:22:17 2009 -0400 +++ b/src/mysql.sml Sun Jun 28 16:41:10 2009 -0400 @@ -257,6 +257,8 @@ 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 @@ query = query, queryPrepared = queryPrepared, dml = dml, - dmlPrepared = dmlPrepared} + dmlPrepared = dmlPrepared, + nextval = nextval, + nextvalPrepared = nextvalPrepared} end
--- a/src/postgres.sml Sun Jun 28 16:22:17 2009 -0400 +++ b/src/postgres.sml Sun Jun 28 16:41:10 2009 -0400 @@ -472,6 +472,75 @@ 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 @@ query = query, queryPrepared = queryPrepared, dml = dml, - dmlPrepared = dmlPrepared} + dmlPrepared = dmlPrepared, + nextval = nextval, + nextvalPrepared = nextvalPrepared} val () = setDbms "postgres" end
--- a/src/settings.sig Sun Jun 28 16:22:17 2009 -0400 +++ b/src/settings.sig Sun Jun 28 16:41:10 2009 -0400 @@ -138,7 +138,9 @@ -> 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
--- a/src/settings.sml Sun Jun 28 16:22:17 2009 -0400 +++ b/src/settings.sml Sun Jun 28 16:41:10 2009 -0400 @@ -324,7 +324,9 @@ -> 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 @@ 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 =