diff options
| -rw-r--r-- | include/urweb.h | 7 | ||||
| -rw-r--r-- | src/c/urweb.c | 46 | ||||
| -rw-r--r-- | src/checknest.sig | 32 | ||||
| -rw-r--r-- | src/checknest.sml | 178 | ||||
| -rw-r--r-- | src/cjr.sml | 6 | ||||
| -rw-r--r-- | src/cjr_print.sml | 9 | ||||
| -rw-r--r-- | src/compiler.sig | 2 | ||||
| -rw-r--r-- | src/compiler.sml | 9 | ||||
| -rw-r--r-- | src/mysql.sml | 70 | ||||
| -rw-r--r-- | src/postgres.sml | 25 | ||||
| -rw-r--r-- | src/prepare.sml | 6 | ||||
| -rw-r--r-- | src/settings.sig | 6 | ||||
| -rw-r--r-- | src/settings.sml | 9 | ||||
| -rw-r--r-- | src/sources | 3 |
14 files changed, 354 insertions, 54 deletions
diff --git a/include/urweb.h b/include/urweb.h index c24550f7..da1299eb 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -207,4 +207,11 @@ void uw_set_heap_front(uw_context, char*); uw_Basis_string uw_Basis_unAs(uw_context, uw_Basis_string); +extern char *uw_sqlfmtInt; +extern char *uw_sqlfmtFloat; +extern int uw_Estrings; +extern char *uw_sqlsuffixString; +extern char *uw_sqlsuffixBlob; +extern char *uw_sqlfmtUint4; + #endif diff --git a/src/c/urweb.c b/src/c/urweb.c index 4b92c2b4..cf44686a 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1932,13 +1932,15 @@ char *uw_memdup(uw_context ctx, const char *p, size_t len) { return r; } +char *uw_sqlfmtInt = "%lld::int8%n"; + char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { int len; char *r; uw_check_heap(ctx, INTS_MAX + 6); r = ctx->heap.front; - sprintf(r, "%lld::int8%n", n, &len); + sprintf(r, uw_sqlfmtInt, n, &len); ctx->heap.front += len+1; return r; } @@ -1950,13 +1952,15 @@ char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { return uw_Basis_sqlifyInt(ctx, *n); } +char *uw_sqlfmtFloat = "%g::float8%n"; + char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { int len; char *r; uw_check_heap(ctx, FLOATS_MAX + 8); r = ctx->heap.front; - sprintf(r, "%g::float8%n", n, &len); + sprintf(r, uw_sqlfmtFloat, n, &len); ctx->heap.front += len+1; return r; } @@ -1968,14 +1972,17 @@ char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) { return uw_Basis_sqlifyFloat(ctx, *n); } +int uw_Estrings = 1; +char *uw_sqlsuffixString = "::text"; uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; - uw_check_heap(ctx, strlen(s) * 2 + 10); + uw_check_heap(ctx, strlen(s) * 2 + 3 + uw_Estrings + strlen(uw_sqlsuffixString)); r = s2 = ctx->heap.front; - *s2++ = 'E'; + if (uw_Estrings) + *s2++ = 'E'; *s2++ = '\''; for (; *s; s++) { @@ -1993,26 +2000,32 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { default: if (isprint(c)) *s2++ = c; - else { + else if (uw_Estrings) { sprintf(s2, "\\%03o", c); s2 += 4; } + else + uw_error(ctx, FATAL, "Non-printable character %u in string to SQLify", c); } } - strcpy(s2, "'::text"); - ctx->heap.front = s2 + 8; + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixString); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixString); return r; } +char *uw_sqlsuffixBlob = "::bytea"; + uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) { char *r, *s2; size_t i; - uw_check_heap(ctx, b.size * 5 + 11); + uw_check_heap(ctx, b.size * 5 + 3 + uw_Estrings + strlen(uw_sqlsuffixBlob)); r = s2 = ctx->heap.front; - *s2++ = 'E'; + if (uw_Estrings) + *s2++ = 'E'; *s2++ = '\''; for (i = 0; i < b.size; ++i) { @@ -2030,15 +2043,18 @@ uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) { default: if (isprint(c)) *s2++ = c; - else { + else if (uw_Estrings) { sprintf(s2, "\\\\%03o", c); s2 += 5; } + else + uw_error(ctx, FATAL, "Non-printable character %u in blob to SQLify", c); } } - strcpy(s2, "'::bytea"); - ctx->heap.front = s2 + 9; + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixBlob); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixBlob); return r; } @@ -2049,7 +2065,7 @@ char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel chn) { uw_check_heap(ctx, INTS_MAX + 7); r = ctx->heap.front; - sprintf(r, "%lld::int8%n", combo, &len); + sprintf(r, uw_sqlfmtInt, combo, &len); ctx->heap.front += len+1; return r; } @@ -2066,13 +2082,15 @@ char *uw_Basis_attrifyChannel(uw_context ctx, uw_Basis_channel chn) { return r; } +char *uw_sqlfmtUint4 = "%u::int4%n"; + char *uw_Basis_sqlifyClient(uw_context ctx, uw_Basis_client cli) { int len; char *r; uw_check_heap(ctx, INTS_MAX + 7); r = ctx->heap.front; - sprintf(r, "%u::int4%n", cli, &len); + sprintf(r, uw_sqlfmtUint4, cli, &len); ctx->heap.front += len+1; return r; } diff --git a/src/checknest.sig b/src/checknest.sig new file mode 100644 index 00000000..f8273b4f --- /dev/null +++ b/src/checknest.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature CHECKNEST = sig + + val annotate : Cjr.file -> Cjr.file + +end diff --git a/src/checknest.sml b/src/checknest.sml new file mode 100644 index 00000000..27a1796c --- /dev/null +++ b/src/checknest.sml @@ -0,0 +1,178 @@ +(* Copyright (c) 2009, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Checknest :> CHECKNEST = struct + +open Cjr + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun expUses globals = + let + fun eu (e, _) = + case e of + EPrim _ => IS.empty + | ERel _ => IS.empty + | ENamed n => Option.getOpt (IM.find (globals, n), IS.empty) + | ECon (_, _, NONE) => IS.empty + | ECon (_, _, SOME e) => eu e + | ENone _ => IS.empty + | ESome (_, e) => eu e + | EFfi _ => IS.empty + | EFfiApp (_, _, es) => foldl IS.union IS.empty (map eu es) + | EApp (e, es) => foldl IS.union (eu e) (map eu es) + + | EUnop (_, e) => eu e + | EBinop (_, e1, e2) => IS.union (eu e1, eu e2) + + | ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes + | EField (e, _) => eu e + + | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes + + | EError (e, _) => eu e + | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType) + + | EWrite e => eu e + | ESeq (e1, e2) => IS.union (eu e1, eu e2) + | ELet (_, _, e1, e2) => IS.union (eu e1, eu e2) + + | EQuery {query, body, initial, prepared, ...} => + let + val s = IS.union (eu query, IS.union (eu body, eu initial)) + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + | EDml {dml, prepared, ...} => + let + val s = eu dml + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + | ENextval {seq, prepared, ...} => + let + val s = eu seq + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + + | EUnurlify (e, _) => eu e + in + eu + end + +fun annotateExp globals = + let + fun ae (e as (_, loc)) = + case #1 e of + EPrim _ => e + | ERel _ => e + | ENamed n => e + | ECon (_, _, NONE) => e + | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc) + | ENone _ => e + | ESome (t, e) => (ESome (t, ae e), loc) + | EFfi _ => e + | EFfiApp (m, f, es) => (EFfiApp (m, f, map ae es), loc) + | EApp (e, es) => (EApp (ae e, map ae es), loc) + + | EUnop (uo, e) => (EUnop (uo, ae e), loc) + | EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc) + + | ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc) + | EField (e, f) => (EField (ae e, f), loc) + + | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc) + + | EError (e, t) => (EError (ae e, t), loc) + | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc) + + | EWrite e => (EWrite (ae e), loc) + | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc) + + | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => + (EQuery {exps = exps, + tables = tables, + rnum = rnum, + state = state, + query = ae query, + body = ae body, + initial = ae initial, + prepared = case prepared of + NONE => NONE + | SOME {id, query, ...} => SOME {id = id, query = query, + nested = IS.member (expUses globals body, id)}}, + loc) + | EDml {dml, prepared} => + (EDml {dml = ae dml, + prepared = prepared}, loc) + + | ENextval {seq, prepared} => + (ENextval {seq = ae seq, + prepared = prepared}, loc) + + | EUnurlify (e, t) => (EUnurlify (ae e, t), loc) + in + ae + end + +fun annotate (ds, syms) = + let + val globals = + foldl (fn ((d, _), globals) => + case d of + DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e) + | DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e) + | DFunRec fs => + let + val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs + in + foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs + end + | _ => globals) IM.empty ds + + val ds = + map (fn d as (_, loc) => + case #1 d of + DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc) + | DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc) + | DFunRec fs => (DFunRec + (map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc) + | _ => d) ds + in + (ds, syms) + end + +end diff --git a/src/cjr.sml b/src/cjr.sml index a5931a55..8c4267f6 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -89,11 +89,11 @@ datatype exp' = query : exp, body : exp, initial : exp, - prepared : (int * string) option } + prepared : {id : int, query : string, nested : bool} option } | EDml of { dml : exp, - prepared : (int * string) option } + prepared : {id : int, dml : string} option } | ENextval of { seq : exp, - prepared : (int * string) option } + prepared : {id : int, query : string} option } | EUnurlify of exp * typ withtype exp = exp' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 375cc4b8..3e4ccdd0 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1654,7 +1654,7 @@ fun p_exp' par env (e, loc) = {loc = loc, cols = map (fn (_, t) => sql_type_in env t) outputs, doCols = doCols}] - | SOME (id, query) => + | SOME {id, query, nested} => box [p_list_sepi newline (fn i => fn (e, t) => box [p_sql_type t, @@ -1676,7 +1676,8 @@ fun p_exp' par env (e, loc) = query = query, inputs = map #2 inputs, cols = map (fn (_, t) => sql_type_in env t) outputs, - doCols = doCols}], + doCols = doCols, + nested = nested}], newline, if wontLeakAnything then @@ -1703,7 +1704,7 @@ fun p_exp' par env (e, loc) = newline, newline, #dml (Settings.currentDbms ()) loc] - | SOME (id, dml') => + | SOME {id, dml = dml'} => let val inputs = getPargs dml in @@ -1748,7 +1749,7 @@ fun p_exp' par env (e, loc) = seqName = case #1 seq of EPrim (Prim.String s) => SOME s | _ => NONE} - | SOME (id, query) => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, + | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, id = id, query = query}, newline, diff --git a/src/compiler.sig b/src/compiler.sig index f7727771..c36ae2cc 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -99,6 +99,7 @@ signature COMPILER = sig val cjrize : (Mono.file, Cjr.file) phase val scriptcheck : (Cjr.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase + val checknest : (Cjr.file, Cjr.file) phase val sqlify : (Mono.file, Cjr.file) phase val toParseJob : (string, job) transform @@ -138,6 +139,7 @@ signature COMPILER = sig val toCjrize : (string, Cjr.file) transform val toScriptcheck : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform + val toChecknest : (string, Cjr.file) transform val toSqlify : (string, Cjr.file) transform end diff --git a/src/compiler.sml b/src/compiler.sml index 9cf874c7..03454638 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -884,6 +884,13 @@ val prepare = { val toPrepare = transform prepare "prepare" o toScriptcheck +val checknest = { + func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f, + print = CjrPrint.p_file CjrEnv.empty +} + +val toChecknest = transform checknest "checknest" o toPrepare + val sqlify = { func = Cjrize.cjrize, print = CjrPrint.p_sql CjrEnv.empty @@ -924,7 +931,7 @@ fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = end fun compile job = - case run toPrepare job of + case run toChecknest job of NONE => print "Ur compilation failed\n" | SOME file => let diff --git a/src/mysql.sml b/src/mysql.sml index 439e8444..e6d42687 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2009, Adam Chlipala +(* Copyright (c) 2009, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -376,7 +376,21 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = string "void uw_client_init(void) {", newline, - box [string "if (mysql_library_init(0, NULL, NULL)) {", + box [string "uw_sqlfmtInt = \"%lld%n\";", + newline, + string "uw_sqlfmtFloat = \"%g%n\";", + newline, + string "uw_Estrings = 0;", + newline, + string "uw_sqlsuffixString = \"\";", + newline, + string "uw_sqlsuffixBlob = \"\";", + newline, + string "uw_sqlfmtUint4 = \"%u%n\";", + newline, + newline, + + string "if (mysql_library_init(0, NULL, NULL)) {", newline, box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");", newline, @@ -867,7 +881,7 @@ fun query {loc, cols, doCols} = string "uw_pop_cleanup(ctx);", newline] -fun queryPrepared {loc, id, query, inputs, cols, doCols} = +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = box [string "uw_conn *conn = uw_get_db(ctx);", newline, string "MYSQL_BIND in[", @@ -901,18 +915,25 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols} = | _ => buffers t, newline] end) inputs, - string "MYSQL_STMT *stmt = conn->p", - string (Int.toString id), - string ";", - newline, - newline, - string "if (stmt == NULL) {", - newline, + if nested then + box [string "MYSQL_STMT *stmt;", + newline] + else + box [string "MYSQL_STMT *stmt = conn->p", + string (Int.toString id), + string ";", + newline, + newline, + + string "if (stmt == NULL) {", + newline], + box [string "stmt = mysql_stmt_init(conn->conn);", newline, string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");", newline, + string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);", string "if (mysql_stmt_prepare(stmt, \"", string (String.toString query), string "\", ", @@ -929,12 +950,18 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols} = newline], string "}", newline, - string "conn->p", - string (Int.toString id), - string " = stmt;", - newline], - string "}", - newline, + if nested then + box [] + else + box [string "conn->p", + string (Int.toString id), + string " = stmt;", + newline]], + if nested then + box [] + else + box [string "}", + newline], newline, string "memset(in, 0, sizeof in);", @@ -1086,7 +1113,13 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols} = queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", string (String.toString query), - string "\""]}] + string "\""]}, + + if nested then + box [string "uw_pop_cleanup(ctx);", + newline] + else + box []] fun dmlCommon {loc, dml} = box [string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"", @@ -1402,6 +1435,7 @@ val () = addDbms {name = "mysql", supportsDeleteAs = false, createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTO_INCREMENT)", textKeysNeedLengths = true, - supportsNextval = false} + supportsNextval = false, + supportsNestedPrepared = false} end diff --git a/src/postgres.sml b/src/postgres.sml index 24166258..e1ef0514 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -247,7 +247,21 @@ fun checkRel (table, checkNullable) (s, xts) = fun init {dbstring, prepared = ss, tables, views, sequences} = box [if #persistent (currentProtocol ()) then - box [string "void uw_client_init(void) { }", + box [string "void uw_client_init(void) {", + newline, + box [string "uw_sqlfmtInt = \"%lld::int8%n\";", + newline, + string "uw_sqlfmtFloat = \"%g::float8%n\";", + newline, + string "uw_Estrings = 1;", + newline, + string "uw_sqlsuffixString = \"::text\";", + newline, + string "uw_sqlsuffixBlob = \"::bytea\";", + newline, + string "uw_sqlfmtUint4 = \"%u::int4%n\";", + newline], + string "}", newline, newline, @@ -639,7 +653,7 @@ fun p_ensql t e = p_ensql t (box [string "(*", e, string ")"]), string ")"] -fun queryPrepared {loc, id, query, inputs, cols, doCols} = +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = box [string "PGconn *conn = uw_get_db(ctx);", newline, string "const int paramFormats[] = { ", @@ -782,8 +796,6 @@ fun nextvalCommon {loc, query} = newline, newline, - string "uw_end_region(ctx);", - newline, string "n = PQntuples(res);", newline, string "if (n != 1) {", @@ -811,7 +823,7 @@ fun nextval {loc, seqE, seqName} = let val query = case seqName of SOME s => - string ("SELECT NEXTVAL('" ^ s ^ "')") + string ("\"SELECT NEXTVAL('" ^ s ^ "')\"") | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ", seqE, string ", \"')\"))"] @@ -878,7 +890,8 @@ val () = addDbms {name = "postgres", supportsDeleteAs = true, createSequence = fn s => "CREATE SEQUENCE " ^ s, textKeysNeedLengths = false, - supportsNextval = true} + supportsNextval = true, + supportsNestedPrepared = true} val () = setDbms "postgres" diff --git a/src/prepare.sml b/src/prepare.sml index 29def780..2bf23d72 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -199,7 +199,7 @@ fun prepExp (e as (_, loc), sns) = in ((EQuery {exps = exps, tables = tables, rnum = rnum, state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns, s)}, loc), + initial = initial, prepared = SOME {id = #2 sns, query = s, nested = true}}, loc), ((s, n) :: #1 sns, #2 sns + 1)) end end @@ -211,7 +211,7 @@ fun prepExp (e as (_, loc), sns) = let val s = String.concat (rev ss) in - ((EDml {dml = dml, prepared = SOME (#2 sns, s)}, loc), + ((EDml {dml = dml, prepared = SOME {id = #2 sns, dml = s}}, loc), ((s, n) :: #1 sns, #2 sns + 1)) end) @@ -234,7 +234,7 @@ fun prepExp (e as (_, loc), sns) = let val s = String.concat (rev ss) in - ((ENextval {seq = seq, prepared = SOME (#2 sns, s)}, loc), + ((ENextval {seq = seq, prepared = SOME {id = #2 sns, query = s}}, loc), ((s, n) :: #1 sns, #2 sns + 1)) end end diff --git a/src/settings.sig b/src/settings.sig index c7855856..c1a6d871 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -137,7 +137,8 @@ signature SETTINGS = sig queryPrepared : {loc : ErrorMsg.span, id : int, query : string, inputs : sql_type list, cols : sql_type list, doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) - -> Print.PD.pp_desc} + -> Print.PD.pp_desc, + nested : bool} -> Print.PD.pp_desc, dml : ErrorMsg.span -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, @@ -150,7 +151,8 @@ signature SETTINGS = sig supportsDeleteAs : bool, createSequence : string -> string, textKeysNeedLengths : bool, - supportsNextval : bool + supportsNextval : bool, + supportsNestedPrepared : bool } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index 7393013e..812e323f 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -327,7 +327,8 @@ type dbms = { queryPrepared : {loc : ErrorMsg.span, id : int, query : string, inputs : sql_type list, cols : sql_type list, doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) - -> Print.PD.pp_desc} + -> Print.PD.pp_desc, + nested : bool} -> Print.PD.pp_desc, dml : ErrorMsg.span -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, @@ -340,7 +341,8 @@ type dbms = { supportsDeleteAs : bool, createSequence : string -> string, textKeysNeedLengths : bool, - supportsNextval : bool + supportsNextval : bool, + supportsNestedPrepared : bool } val dbmses = ref ([] : dbms list) @@ -361,7 +363,8 @@ val curDb = ref ({name = "", supportsDeleteAs = false, createSequence = fn _ => "", textKeysNeedLengths = false, - supportsNextval = false} : dbms) + supportsNextval = false, + supportsNestedPrepared = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = diff --git a/src/sources b/src/sources index b284e5a9..ea6ae586 100644 --- a/src/sources +++ b/src/sources @@ -192,6 +192,9 @@ scriptcheck.sml prepare.sig prepare.sml +checknest.sig +checknest.sml + compiler.sig compiler.sml |