# HG changeset patch # User Adam Chlipala # Date 1246220537 14400 # Node ID 06497beb265b3e97276d3daac370ec3ee126f846 # Parent e7f80d78075b3e49fefd21cc671512a11c4454ed Moved dml code into Settings diff -r e7f80d78075b -r 06497beb265b src/cjr_print.sml --- a/src/cjr_print.sml Sun Jun 28 16:03:00 2009 -0400 +++ b/src/cjr_print.sml Sun Jun 28 16:22:17 2009 -0400 @@ -1696,16 +1696,16 @@ | 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 @@ 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 -r e7f80d78075b -r 06497beb265b src/mysql.sml --- a/src/mysql.sml Sun Jun 28 16:03:00 2009 -0400 +++ b/src/mysql.sml Sun Jun 28 16:22:17 2009 -0400 @@ -255,6 +255,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" val () = addDbms {name = "mysql", header = "mysql/mysql.h", @@ -273,6 +275,8 @@ newline], init = init, query = query, - queryPrepared = queryPrepared} + queryPrepared = queryPrepared, + dml = dml, + dmlPrepared = dmlPrepared} end diff -r e7f80d78075b -r 06497beb265b src/postgres.sml --- a/src/postgres.sml Sun Jun 28 16:03:00 2009 -0400 +++ b/src/postgres.sml Sun Jun 28 16:22:17 2009 -0400 @@ -391,6 +391,87 @@ 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 @@ newline], init = init, query = query, - queryPrepared = queryPrepared} + queryPrepared = queryPrepared, + dml = dml, + dmlPrepared = dmlPrepared} val () = setDbms "postgres" end diff -r e7f80d78075b -r 06497beb265b src/settings.sig --- a/src/settings.sig Sun Jun 28 16:03:00 2009 -0400 +++ b/src/settings.sig Sun Jun 28 16:22:17 2009 -0400 @@ -135,7 +135,10 @@ 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 -r e7f80d78075b -r 06497beb265b src/settings.sml --- a/src/settings.sml Sun Jun 28 16:03:00 2009 -0400 +++ b/src/settings.sml Sun Jun 28 16:22:17 2009 -0400 @@ -321,7 +321,10 @@ 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 @@ 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 =