summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c35
-rw-r--r--src/cjr_print.sml16
-rw-r--r--src/mono_opt.sml63
-rw-r--r--src/monoize.sml14
-rw-r--r--src/mysql.sml360
-rw-r--r--src/postgres.sml35
-rw-r--r--src/prepare.sml70
-rw-r--r--src/settings.sig10
-rw-r--r--src/settings.sml14
9 files changed, 519 insertions, 98 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index f088e74d..4b92c2b4 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -2742,3 +2742,38 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
longjmp(ctx->jmp_buf, RETURN_BLOB);
}
+
+uw_Basis_string uw_Basis_unAs(uw_context ctx, uw_Basis_string s) {
+ uw_Basis_string r = uw_malloc(ctx, strlen(s) + 1);
+
+ for (; *s; ++s) {
+ if (s[0] == '\'') {
+ *r++ = '\'';
+ for (++s; *s; ++s) {
+ if (s[0] == '\'') {
+ *r++ = '\'';
+ break;
+ } else if (s[0] == '\\') {
+ if (s[1] == '\\') {
+ *r++ = '\\';
+ *r++ = '\\';
+ ++s;
+ } else if (s[1] == '\'') {
+ *r++ = '\\';
+ *r++ = '\'';
+ ++s;
+ } else
+ *r++ = '\'';
+ } else
+ *r++ = s[0];
+ }
+ if (*s == 0) break;
+ } else if (s[0] == 'T' && s[1] == '.')
+ ++s;
+ else
+ *r++ = s[0];
+ }
+
+ return r;
+}
+
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index fcfa402e..13386f5b 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2794,11 +2794,17 @@ fun p_sql env (ds, _) =
string s,
string "(",
p_list (fn (x, t) =>
- box [string "uw_",
- string (CharVector.map Char.toLower x),
- space,
- string (#p_sql_type (Settings.currentDbms ())
- (sql_type_in env t))]) xts,
+ let
+ val t = sql_type_in env t
+ in
+ box [string "uw_",
+ string (CharVector.map Char.toLower x),
+ space,
+ string (#p_sql_type (Settings.currentDbms ()) t),
+ case t of
+ Nullable _ => box []
+ | _ => string " NOT NULL"]
+ end) xts,
case (pk, csts) of
("", []) => box []
| _ => string ",",
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 97ad1916..9288b820 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -83,18 +83,30 @@ val urlifyString = String.translate (fn #" " => "+"
"%" ^ hexIt ch)
-fun sqlifyInt n = attrifyInt n ^ "::int8"
-fun sqlifyFloat n = attrifyFloat n ^ "::float8"
-
-fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
- | #"\\" => "\\\\"
- | ch =>
- if Char.isPrint ch then
- str ch
- else
- "\\" ^ StringCvt.padLeft #"0" 3
- (Int.fmt StringCvt.OCT (ord ch)))
- (String.toString s) ^ "'::text"
+fun sqlifyInt n = attrifyInt n ^ "::" ^ #p_sql_type (Settings.currentDbms ()) Settings.Int
+fun sqlifyFloat n = attrifyFloat n ^ "::" ^ #p_sql_type (Settings.currentDbms ()) Settings.Float
+
+fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s
+
+fun unAs s =
+ let
+ fun doChars (cs, acc) =
+ case cs of
+ #"T" :: #"." :: cs => doChars (cs, acc)
+ | #"'" :: cs => doString (cs, acc)
+ | ch :: cs => doChars (cs, ch :: acc)
+ | [] => String.implode (rev acc)
+
+ and doString (cs, acc) =
+ case cs of
+ #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc)
+ | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc)
+ | #"'" :: cs => doChars (cs, #"'" :: acc)
+ | ch :: cs => doString (cs, ch :: acc)
+ | [] => String.implode (rev acc)
+ in
+ doChars (String.explode s, [])
+ end
fun exp e =
case e of
@@ -442,6 +454,33 @@ fun exp e =
EPrim (Prim.String s)
end
+ | EFfiApp ("Basis", "unAs", [(EPrim (Prim.String s), _)]) =>
+ EPrim (Prim.String (unAs s))
+ | EFfiApp ("Basis", "unAs", [e']) =>
+ let
+ fun parts (e as (_, loc)) =
+ case #1 e of
+ EStrcat (s1, s2) =>
+ (case (parts s1, parts s2) of
+ (SOME p1, SOME p2) => SOME (p1 @ p2)
+ | _ => NONE)
+ | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)]
+ | EFfiApp ("Basis", f, [_]) =>
+ if String.isPrefix "sqlify" f then
+ SOME [e]
+ else
+ NONE
+ | _ => NONE
+ in
+ case parts e' of
+ SOME [e] => #1 e
+ | SOME es =>
+ (case rev es of
+ (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es)
+ | [] => raise Fail "MonoOpt impossible nil")
+ | NONE => e
+ end
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/monoize.sml b/src/monoize.sml
index 91160e02..aab2226b 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1604,10 +1604,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e", s, s,
- strcat [sc "DELETE FROM ",
- (L'.ERel 1, loc),
- sc " AS T WHERE ",
- (L'.ERel 0, loc)]), loc)), loc),
+ if #supportsDeleteAs (Settings.currentDbms ()) then
+ strcat [sc "DELETE FROM ",
+ (L'.ERel 1, loc),
+ sc " AS T WHERE ",
+ (L'.ERel 0, loc)]
+ else
+ strcat [sc "DELETE FROM ",
+ (L'.ERel 1, loc),
+ sc " WHERE ",
+ (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc),
fm)
end
diff --git a/src/mysql.sml b/src/mysql.sml
index 2fcdef2d..ebcddc7f 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -55,6 +55,278 @@ fun p_buffer_type t =
| Client => "MYSQL_TYPE_LONG"
| Nullable t => p_buffer_type t
+fun p_sql_type_base t =
+ case t of
+ Int => "bigint"
+ | Float => "double"
+ | String => "longtext"
+ | Bool => "tinyint"
+ | Time => "timestamp"
+ | Blob => "longblob"
+ | Channel => "bigint"
+ | Client => "int"
+ | Nullable t => p_sql_type_base t
+
+val ident = String.translate (fn #"'" => "PRIME"
+ | ch => str ch)
+
+fun checkRel (table, checkNullable) (s, xts) =
+ let
+ val sl = CharVector.map Char.toLower s
+
+ val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
+ ^ sl ^ "'"
+
+ val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
+ sl,
+ "' AND (",
+ String.concatWith " OR "
+ (map (fn (x, t) =>
+ String.concat ["(column_name = 'uw_",
+ CharVector.map
+ Char.toLower (ident x),
+ "' AND data_type = '",
+ p_sql_type_base t,
+ "'",
+ if checkNullable then
+ (" AND is_nullable = '"
+ ^ (if isNotNull t then
+ "NO"
+ else
+ "YES")
+ ^ "'")
+ else
+ "",
+ ")"]) xts),
+ ")"]
+
+ val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
+ sl,
+ "' AND column_name LIKE 'uw_%'"]
+ in
+ box [string "if (mysql_query(conn->conn, \"",
+ string q,
+ string "\")) {",
+ newline,
+ box [string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Query failed:\\n",
+ string q,
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Result store failed:\\n",
+ string q,
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (mysql_num_fields(res) != 1) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Bad column count:\\n",
+ string q,
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((row = mysql_fetch_row(res)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
+ string q,
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (strcmp(row[0], \"1\")) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Table '",
+ string s,
+ string "' does not exist.\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+ string "mysql_free_result(res);",
+ newline,
+ newline,
+
+ string "if (mysql_query(conn->conn, \"",
+ string q',
+ string "\")) {",
+ newline,
+ box [string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Query failed:\\n",
+ string q',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Result store failed:\\n",
+ string q',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (mysql_num_fields(res) != 1) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Bad column count:\\n",
+ string q',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((row = mysql_fetch_row(res)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
+ string q',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (strcmp(row[0], \"",
+ string (Int.toString (length xts)),
+ string "\")) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Table '",
+ string s,
+ string "' has the wrong column types.\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+ string "mysql_free_result(res);",
+ newline,
+ newline,
+
+ string "if (mysql_query(conn->conn, \"",
+ string q'',
+ string "\")) {",
+ newline,
+ box [string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Query failed:\\n",
+ string q'',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((res = mysql_store_result(conn->conn)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Result store failed:\\n",
+ string q'',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (mysql_num_fields(res) != 1) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Bad column count:\\n",
+ string q'',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if ((row = mysql_fetch_row(res)) == NULL) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Row fetch failed:\\n",
+ string q'',
+ string "\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "if (strcmp(row[0], \"",
+ string (Int.toString (length xts)),
+ string "\")) {",
+ newline,
+ box [string "mysql_free_result(res);",
+ newline,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Table '",
+ string s,
+ string "' has extra columns.\");",
+ newline],
+ string "}",
+ newline,
+ newline,
+ string "mysql_free_result(res);",
+ newline]
+ end
+
fun init {dbstring, prepared = ss, tables, views, sequences} =
let
val host = ref NONE
@@ -102,8 +374,37 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
+ string "void uw_client_init(void) {",
+ newline,
+ box [string "if (mysql_library_init(0, NULL, NULL)) {",
+ newline,
+ box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");",
+ newline,
+ string "exit(1);",
+ newline],
+ string "}",
+ newline],
+ string "}",
+ newline,
+ newline,
+
if #persistent (currentProtocol ()) then
- box [string "static void uw_db_prepare(uw_context ctx) {",
+ box [string "static void uw_db_validate(uw_context ctx) {",
+ newline,
+ string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "MYSQL_RES *res;",
+ newline,
+ string "MYSQL_ROW row;",
+ newline,
+ newline,
+ p_list_sep newline (checkRel ("tables", true)) tables,
+ p_list_sep newline (checkRel ("views", false)) views,
+ string "}",
+ newline,
+ newline,
+
+ string "static void uw_db_prepare(uw_context ctx) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
@@ -147,6 +448,10 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
uhoh false "Out of memory allocating prepared statement" [],
string "}",
newline,
+ string "conn->p",
+ string (Int.toString i),
+ string " = stmt;",
+ newline,
string "if (mysql_stmt_prepare(stmt, \"",
string (String.toString s),
@@ -162,10 +467,6 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
uhoh true "Error preparing statement: %s" ["msg"]],
string "}",
- newline,
- string "conn->p",
- string (Int.toString i),
- string " = stmt;",
newline]
end)
ss,
@@ -199,7 +500,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
| SOME n => string (Int.toString n),
string ", ",
stringOf unix_socket,
- string ", 0)) {",
+ string ", 0) == NULL) {",
newline,
box [string "char msg[1024];",
newline,
@@ -214,7 +515,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
string "}",
newline,
- string "conn = calloc(1, sizeof(conn));",
+ string "conn = calloc(1, sizeof(uw_conn));",
newline,
string "conn->conn = mysql;",
newline,
@@ -471,19 +772,19 @@ fun queryCommon {loc, query, cols, doCols} =
string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": Error executing query\");",
+ string ": Error executing query: %s\", mysql_error(conn->conn));",
newline,
newline,
string "if (mysql_stmt_store_result(stmt)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": Error storing query result\");",
+ string ": Error storing query result: %s\", mysql_error(conn->conn));",
newline,
newline,
string "if (mysql_stmt_bind_result(stmt, out)) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": Error binding query result\");",
+ string ": Error binding query result: %s\", mysql_error(conn->conn));",
newline,
newline,
@@ -496,9 +797,9 @@ fun queryCommon {loc, query, cols, doCols} =
newline,
newline,
- string "if (r != MYSQL_NO_DATA) uw_error(ctx, FATAL, \"",
+ string "if (r == 1) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": query result fetching failed\");",
+ string ": query result fetching failed (%d): %s\", r, mysql_error(conn->conn));",
newline]
fun query {loc, cols, doCols} =
@@ -514,7 +815,7 @@ fun query {loc, cols, doCols} =
newline,
string "if (mysql_stmt_prepare(stmt, query, strlen(query))) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string "\");",
+ string ": error preparing statement: %s\", mysql_error(conn->conn));",
newline,
newline,
@@ -760,21 +1061,24 @@ fun dmlPrepared _ = box []
fun nextval _ = box []
fun nextvalPrepared _ = box []
+fun sqlifyString s = "CAST('" ^ String.translate (fn #"'" => "\\'"
+ | #"\\" => "\\\\"
+ | ch =>
+ if Char.isPrint ch then
+ str ch
+ else
+ (ErrorMsg.error
+ "Non-printing character found in SQL string literal";
+ ""))
+ (String.toString s) ^ "' AS longtext)"
+
+fun p_cast (s, t) = "CAST(" ^ s ^ " AS " ^ p_sql_type t ^ ")"
+
+fun p_blank _ = "?"
+
val () = addDbms {name = "mysql",
header = "mysql/mysql.h",
link = "-lmysqlclient",
- global_init = box [string "void uw_client_init() {",
- newline,
- box [string "if (mysql_library_init(0, NULL, NULL)) {",
- newline,
- box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");",
- newline,
- string "exit(1);",
- newline],
- string "}",
- newline],
- string "}",
- newline],
init = init,
p_sql_type = p_sql_type,
query = query,
@@ -782,6 +1086,10 @@ val () = addDbms {name = "mysql",
dml = dml,
dmlPrepared = dmlPrepared,
nextval = nextval,
- nextvalPrepared = nextvalPrepared}
+ nextvalPrepared = nextvalPrepared,
+ sqlifyString = sqlifyString,
+ p_cast = p_cast,
+ p_blank = p_blank,
+ supportsDeleteAs = false}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index ca71798f..0b854efc 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -247,7 +247,11 @@ fun checkRel (table, checkNullable) (s, xts) =
fun init {dbstring, prepared = ss, tables, views, sequences} =
box [if #persistent (currentProtocol ()) then
- box [string "static void uw_db_validate(uw_context ctx) {",
+ box [string "void uw_client_init() { }",
+ newline,
+ newline,
+
+ string "static void uw_db_validate(uw_context ctx) {",
newline,
string "PGconn *conn = uw_get_db(ctx);",
newline,
@@ -509,10 +513,10 @@ fun p_getcol {wontLeakStrings, col = i, typ = t} =
String => getter t
| _ => box [string "({",
newline,
- string (p_sql_type t),
+ string (p_sql_ctype t),
space,
string "*tmp = uw_malloc(ctx, sizeof(",
- string (p_sql_type t),
+ string (p_sql_ctype t),
string "));",
newline,
string "*tmp = ",
@@ -528,7 +532,7 @@ fun p_getcol {wontLeakStrings, col = i, typ = t} =
string (Int.toString i),
string ") ? ",
box [string "({",
- string (p_sql_type t),
+ string (p_sql_ctype t),
space,
string "tmp;",
newline,
@@ -828,11 +832,23 @@ fun nextvalPrepared {loc, id, query} =
string (String.toString query),
string "\""]}]
+fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
+ | #"\\" => "\\\\"
+ | ch =>
+ if Char.isPrint ch then
+ str ch
+ else
+ "\\" ^ StringCvt.padLeft #"0" 3
+ (Int.fmt StringCvt.OCT (ord ch)))
+ (String.toString s) ^ "'::text"
+
+fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
+
+fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t)
+
val () = addDbms {name = "postgres",
header = "postgresql/libpq-fe.h",
link = "-lpq",
- global_init = box [string "void uw_client_init() { }",
- newline],
p_sql_type = p_sql_type,
init = init,
query = query,
@@ -840,7 +856,12 @@ val () = addDbms {name = "postgres",
dml = dml,
dmlPrepared = dmlPrepared,
nextval = nextval,
- nextvalPrepared = nextvalPrepared}
+ nextvalPrepared = nextvalPrepared,
+ sqlifyString = sqlifyString,
+ p_cast = p_cast,
+ p_blank = p_blank,
+ supportsDeleteAs = true}
+
val () = setDbms "postgres"
end
diff --git a/src/prepare.sml b/src/prepare.sml
index 89a974db..0a8ca7a2 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -28,47 +28,45 @@
structure Prepare :> PREPARE = struct
open Cjr
+open Settings
fun prepString (e, ss, n) =
- case #1 e of
- EPrim (Prim.String s) =>
- SOME (s :: ss, n)
- | EFfiApp ("Basis", "strcat", [e1, e2]) =>
- (case prepString (e1, ss, n) of
- NONE => NONE
- | SOME (ss, n) => prepString (e2, ss, n))
- | EFfiApp ("Basis", "sqlifyInt", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyString", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyBool", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyTime", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyBlob", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::bytea" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyChannel", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
- | EFfiApp ("Basis", "sqlifyClient", [e]) =>
- SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1)
+ let
+ fun doOne t =
+ SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1)
+ in
+ case #1 e of
+ EPrim (Prim.String s) =>
+ SOME (s :: ss, n)
+ | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+ (case prepString (e1, ss, n) of
+ NONE => NONE
+ | SOME (ss, n) => prepString (e2, ss, n))
+ | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int
+ | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float
+ | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String
+ | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool
+ | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time
+ | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob
+ | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel
+ | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client
- | ECase (e,
- [((PNone _, _),
- (EPrim (Prim.String "NULL"), _)),
- ((PSome (_, (PVar _, _)), _),
- (EFfiApp (m, x, [(ERel 0, _)]), _))],
- _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n)
+ | ECase (e,
+ [((PNone _, _),
+ (EPrim (Prim.String "NULL"), _)),
+ ((PSome (_, (PVar _, _)), _),
+ (EFfiApp (m, x, [(ERel 0, _)]), _))],
+ _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n)
- | ECase (e,
- [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
- (EPrim (Prim.String "TRUE"), _)),
- ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
- (EPrim (Prim.String "FALSE"), _))],
- _) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
+ | ECase (e,
+ [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
+ (EPrim (Prim.String "TRUE"), _)),
+ ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
+ (EPrim (Prim.String "FALSE"), _))],
+ _) => doOne Bool
- | _ => NONE
+ | _ => NONE
+ end
fun prepExp (e as (_, loc), sns) =
case #1 e of
diff --git a/src/settings.sig b/src/settings.sig
index 14e6338d..bfbc1f82 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -123,15 +123,13 @@ signature SETTINGS = sig
(* Include this C header file *)
link : string,
(* Pass these linker arguments *)
- global_init : Print.PD.pp_desc,
- (* Define uw_client_init() *)
p_sql_type : sql_type -> string,
init : {dbstring : string,
prepared : (string * int) list,
tables : (string * (string * sql_type) list) list,
views : (string * (string * sql_type) list) list,
sequences : string list} -> Print.PD.pp_desc,
- (* Define uw_db_init(), uw_db_close(), uw_db_begin(), uw_db_commit(), and uw_db_rollback() *)
+ (* Define uw_client_init(), uw_db_init(), uw_db_close(), uw_db_begin(), uw_db_commit(), and uw_db_rollback() *)
query : {loc : ErrorMsg.span, cols : sql_type list,
doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
-> Print.PD.pp_desc}
@@ -145,7 +143,11 @@ signature SETTINGS = sig
dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
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
+ nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+ sqlifyString : string -> string,
+ p_cast : string * sql_type -> string,
+ p_blank : int * sql_type -> string (* Prepared statement input *),
+ supportsDeleteAs : bool
}
val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index f2c2461d..32ab8bcd 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -314,7 +314,6 @@ type dbms = {
name : string,
header : string,
link : string,
- global_init : Print.PD.pp_desc,
p_sql_type : sql_type -> string,
init : {dbstring : string,
prepared : (string * int) list,
@@ -334,14 +333,17 @@ type dbms = {
dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
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
+ nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+ sqlifyString : string -> string,
+ p_cast : string * sql_type -> string,
+ p_blank : int * sql_type -> string,
+ supportsDeleteAs : bool
}
val dbmses = ref ([] : dbms list)
val curDb = ref ({name = "",
header = "",
link = "",
- global_init = Print.box [],
p_sql_type = fn _ => "",
init = fn _ => Print.box [],
query = fn _ => Print.box [],
@@ -349,7 +351,11 @@ val curDb = ref ({name = "",
dml = fn _ => Print.box [],
dmlPrepared = fn _ => Print.box [],
nextval = fn _ => Print.box [],
- nextvalPrepared = fn _ => Print.box []} : dbms)
+ nextvalPrepared = fn _ => Print.box [],
+ sqlifyString = fn s => s,
+ p_cast = fn _ => "",
+ p_blank = fn _ => "",
+ supportsDeleteAs = false} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 23:22:11 +0000