aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2014-01-04 19:02:14 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2014-01-04 19:02:14 -0500
commit771723435b7949b0a0ccb1e55ce919994a97613f (patch)
tree094c7e8aa2ab521cce351f856ca80f42e5bc77b0 /src
parentd7c4eb5eb07091dfa292943c8a6825a2ec7f244c (diff)
noMangleSql .urp directive
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sml1
-rw-r--r--src/monoize.sml62
-rw-r--r--src/mysql.sml57
-rw-r--r--src/postgres.sml25
-rw-r--r--src/settings.sig9
-rw-r--r--src/settings.sml20
6 files changed, 110 insertions, 64 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index b2635e5e..5e60288b 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -864,6 +864,7 @@ fun parseUrp' accLibs fname =
| "alwaysInline" => Settings.addAlwaysInline arg
| "noXsrfProtection" => Settings.addNoXsrfProtection arg
| "timeFormat" => Settings.setTimeFormat arg
+ | "noMangleSql" => Settings.setMangleSql false
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
diff --git a/src/monoize.sml b/src/monoize.sml
index aeb99d94..000ba7b6 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1624,7 +1624,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EPrim (Prim.String
(String.concatWith ", "
(map (fn (x, _) =>
- "uw_" ^ monoNameLc env x
+ Settings.mangleSql (monoNameLc env x)
^ (if #textKeysNeedLengths (Settings.currentDbms ())
andalso isBlobby t then
"(767)"
@@ -1668,7 +1668,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EPrim (Prim.String ("UNIQUE ("
^ String.concatWith ", "
- (map (fn (x, t) => "uw_" ^ monoNameLc env x
+ (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
^ (if #textKeysNeedLengths (Settings.currentDbms ())
andalso isBlobby t then
"(767)"
@@ -1714,19 +1714,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("m", mat, mat,
(L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
[((L'.PPrim (Prim.String ""), loc),
- (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)),
+ (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))),
loc), string),
- ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)),
+ ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))),
loc), string)], loc)),
((L'.PWild, loc),
(L'.ERecord [("1", (L'.EStrcat (
- (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1
+ (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1)
^ ", ")),
loc),
(L'.EField ((L'.ERel 0, loc), "1"), loc)),
loc), string),
("2", (L'.EStrcat (
- (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2
+ (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2)
^ ", ")), loc),
(L'.EField ((L'.ERel 0, loc), "2"), loc)),
loc), string)],
@@ -1857,7 +1857,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcat [sc "INSERT INTO ",
(L'.ERel 1, loc),
sc " (",
- strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
+ strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields),
sc ") VALUES (",
strcatComma (map (fn (x, _) =>
(L'.EField ((L'.ERel 0, loc),
@@ -1884,7 +1884,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ERel 1, loc),
sc " AS T_T SET ",
strcatComma (map (fn (x, _) =>
- strcat [sc ("uw_" ^ x
+ strcat [sc (Settings.mangleSql x
^ " = "),
(L'.EField
((L'.ERel 2,
@@ -1898,7 +1898,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ERel 1, loc),
sc " SET ",
strcatComma (map (fn (x, _) =>
- strcat [sc ("uw_" ^ x
+ strcat [sc (Settings.mangleSql x
^ " = "),
(L'.EFfiApp ("Basis", "unAs",
[((L'.EField
@@ -2090,14 +2090,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcatComma (map (fn (x, t) =>
strcat [
(L'.EField (gf "SelectExps", x), loc),
- sc (" AS uw_" ^ x)
+ sc (" AS " ^ Settings.mangleSql x)
]) sexps
@ map (fn (x, xts) =>
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
- ^ ".uw_"
- ^ x'))
+ ^ "."
+ ^ Settings.mangleSql x'))
xts)) stables),
(L'.ECase (gf "From",
[((L'.PPrim (Prim.String ""), loc),
@@ -2131,8 +2131,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
- ^ ".uw_"
- ^ x'))
+ ^ ""
+ ^ Settings.mangleSql x'))
xts)) grouped)
],
@@ -2626,7 +2626,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
(L.CName tab, _)), _),
- (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm)
+ (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm)
| L.ECApp (
(L.ECApp (
@@ -2638,7 +2638,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
_), _),
- (L.CName nm, _)) => ((L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm)), loc), fm)
+ (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm)
| L.ECApp (
(L.ECApp (
@@ -4368,7 +4368,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSqlTable s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4386,7 +4386,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSqlTable s
val e_name = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4404,7 +4404,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val s = "uw_" ^ s
+ val s = Settings.mangleSql s
val e = (L'.EPrim (Prim.String s), loc)
in
SOME (Env.pushENamed env x n t NONE s,
@@ -4553,7 +4553,7 @@ fun monoize env file =
val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
- (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
+ (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
^ (case v of
Client => ""
| Channel => " >> 32")
@@ -4564,10 +4564,10 @@ fun monoize env file =
foldl (fn ((x, v), e) =>
(L'.ESeq (
(L'.EDml ((L'.EStrcat (
- (L'.EPrim (Prim.String ("UPDATE uw_"
- ^ tab
- ^ " SET uw_"
- ^ x
+ (L'.EPrim (Prim.String ("UPDATE "
+ ^ Settings.mangleSql tab
+ ^ " SET "
+ ^ Settings.mangleSql x
^ " = NULL WHERE ")), loc),
cond (x, v)), loc), L'.Error), loc),
e), loc))
@@ -4584,8 +4584,8 @@ fun monoize env file =
(L'.EStrcat ((L'.EPrim (Prim.String " OR "),
loc),
cond eb), loc)), loc))
- (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
- ^ tab
+ (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
+ ^ Settings.mangleSql tab
^ " WHERE ")), loc),
cond eb), loc)
ebs, L'.Error), loc),
@@ -4618,11 +4618,11 @@ fun monoize env file =
(L'.ESeq (
(L'.EDml ((L'.EPrim (Prim.String
(foldl (fn ((x, _), s) =>
- s ^ ", uw_" ^ x ^ " = NULL")
+ s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
("UPDATE uw_"
^ tab
- ^ " SET uw_"
- ^ x
+ ^ " SET "
+ ^ Settings.mangleSql x
^ " = NULL")
ebs)), loc), L'.Error), loc),
e), loc)
@@ -4632,8 +4632,8 @@ fun monoize env file =
[] => e
| eb :: ebs =>
(L'.ESeq (
- (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_"
- ^ tab)), loc), L'.Error), loc),
+ (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
+ ^ Settings.mangleSql tab)), loc), L'.Error), loc),
e), loc)
in
e
diff --git a/src/mysql.sml b/src/mysql.sml
index 884cde36..a119321c 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -76,7 +76,11 @@ val ident = String.translate (fn #"'" => "PRIME"
fun checkRel (table, checkNullable) (s, xts) =
let
val sl = CharVector.map Char.toLower s
- val both = "table_name IN ('" ^ sl ^ "', '" ^ s ^ "')"
+ val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+ String.substring (sl, 1, size sl - 2)
+ else
+ sl
+ val both = "LOWER(table_name) = ('" ^ sl ^ "')"
val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both
@@ -85,14 +89,17 @@ fun checkRel (table, checkNullable) (s, xts) =
" AND (",
case String.concatWith " OR "
(map (fn (x, t) =>
- String.concat ["(column_name IN ('uw_",
- CharVector.map
- Char.toLower (ident x),
- "', 'uw_",
- ident x,
- "') AND data_type = '",
- p_sql_type_base t,
- "'",
+ String.concat ["(LOWER(column_name) = '",
+ Settings.mangleSqlCatalog
+ (CharVector.map
+ Char.toLower (ident x)),
+ "' AND data_type ",
+ case p_sql_type_base t of
+ "bigint" =>
+ "IN ('bigint', 'int')"
+ | "longtext" =>
+ "IN ('longtext', 'varchar')"
+ | s => "= '" ^ s ^ "'",
if checkNullable then
(" AND is_nullable = '"
^ (if isNotNull t then
@@ -109,7 +116,7 @@ fun checkRel (table, checkNullable) (s, xts) =
val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ",
both,
- " AND column_name LIKE 'uw_%'"]
+ " AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
in
box [string "if (mysql_query(conn->conn, \"",
string q,
@@ -174,7 +181,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' does not exist.\");",
newline],
string "}",
@@ -249,7 +256,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has the wrong column types.\");",
newline],
string "}",
@@ -324,7 +331,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "mysql_close(conn->conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has extra columns.\");",
newline],
string "}",
@@ -1201,15 +1208,21 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
box []]
fun dmlCommon {loc, dml, mode} =
- box [string "if (mysql_stmt_execute(stmt)) ",
- case mode of
- Settings.Error => box [string "uw_error(ctx, FATAL, \"",
- string (ErrorMsg.spanToString loc),
- string ": Error executing DML: %s\\n%s\", ",
- dml,
- string ", mysql_error(conn->conn));"]
- | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
- newline,
+ box [string "if (mysql_stmt_execute(stmt)) {",
+ box [string "if (mysql_errno(conn->conn) == 1213)",
+ newline,
+ box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
+ newline],
+ newline,
+ case mode of
+ Settings.Error => box [string "uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error executing DML: %s\\n%s\", ",
+ dml,
+ string ", mysql_error(conn->conn));"]
+ | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
+ newline],
+ string "}",
newline]
fun dml (loc, mode) =
diff --git a/src/postgres.sml b/src/postgres.sml
index 8cfa5f48..6ed7eeb0 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -63,8 +63,12 @@ fun p_sql_type_base t =
fun checkRel (table, checkNullable) (s, xts) =
let
val sl = CharVector.map Char.toLower s
+ val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+ String.substring (sl, 1, size sl - 2)
+ else
+ sl
- val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
+ val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE LOWER(table_name) = '"
^ sl ^ "'"
val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
@@ -72,12 +76,15 @@ fun checkRel (table, checkNullable) (s, xts) =
"' AND (",
case String.concatWith " OR "
(map (fn (x, t) =>
- String.concat ["(column_name = 'uw_",
- CharVector.map
- Char.toLower (ident x),
+ String.concat ["(LOWER(column_name) = '",
+ Settings.mangleSqlCatalog
+ (CharVector.map
+ Char.toLower (ident x)),
(case p_sql_type_base t of
"bigint" =>
- "' AND data_type IN ('bigint', 'numeric')"
+ "' AND data_type IN ('bigint', 'numeric', 'integer')"
+ | "text" =>
+ "' AND data_type IN ('text', 'character varying')"
| t =>
String.concat ["' AND data_type = '",
t,
@@ -98,7 +105,7 @@ fun checkRel (table, checkNullable) (s, xts) =
val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
sl,
- "' AND column_name LIKE 'uw_%'"]
+ "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
in
box [string "res = PQexec(conn, \"",
string q,
@@ -140,7 +147,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' does not exist.\");",
newline],
string "}",
@@ -191,7 +198,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has the wrong column types.\");",
newline],
string "}",
@@ -243,7 +250,7 @@ fun checkRel (table, checkNullable) (s, xts) =
string "PQfinish(conn);",
newline,
string "uw_error(ctx, FATAL, \"Table '",
- string s,
+ string sl,
string "' has extra columns.\");",
newline],
string "}",
diff --git a/src/settings.sig b/src/settings.sig
index 40cfbacc..847cb5f6 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -258,6 +258,11 @@ signature SETTINGS = sig
val setTimeFormat : string -> unit
val getTimeFormat : unit -> string
- val getCCompiler : unit -> string
- val setCCompiler : string -> unit
+ val getCCompiler : unit -> string
+ val setCCompiler : string -> unit
+
+ val setMangleSql : bool -> unit
+ val mangleSql : string -> string
+ val mangleSqlCatalog : string -> string
+ val mangleSqlTable : string -> string
end
diff --git a/src/settings.sml b/src/settings.sml
index eaaa374d..ebe38b17 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -696,4 +696,24 @@ val timeFormat = ref "%c"
fun setTimeFormat v = timeFormat := v
fun getTimeFormat () = !timeFormat
+fun lowercase s =
+ case s of
+ "" => ""
+ | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+fun capitalize s =
+ case s of
+ "" => ""
+ | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+val mangle = ref true
+fun setMangleSql x = mangle := x
+fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
+ else if #name (currentDbms ()) = "mysql" then capitalize s
+ else "\"" ^ lowercase s ^ "\""
+fun mangleSql s = if !mangle then "uw_" ^ s
+ else if #name (currentDbms ()) = "mysql" then lowercase s
+ else "\"" ^ lowercase s ^ "\""
+fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
+
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 17:05:02 +0000