summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c46
-rw-r--r--src/checknest.sig32
-rw-r--r--src/checknest.sml178
-rw-r--r--src/cjr.sml6
-rw-r--r--src/cjr_print.sml9
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/mysql.sml70
-rw-r--r--src/postgres.sml25
-rw-r--r--src/prepare.sml6
-rw-r--r--src/settings.sig6
-rw-r--r--src/settings.sml9
-rw-r--r--src/sources3
13 files changed, 347 insertions, 54 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 10:53:12 +0000