summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c87
-rw-r--r--src/cjr_print.sml16
-rw-r--r--src/mono_opt.sml26
-rw-r--r--src/monoize.sml4
-rw-r--r--src/mysql.sml5
-rw-r--r--src/postgres.sml6
-rw-r--r--src/settings.sig1
-rw-r--r--src/settings.sml2
-rw-r--r--src/sqlite.sml9
9 files changed, 136 insertions, 20 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 139a2507..7dd6d222 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1388,6 +1388,32 @@ char *uw_Basis_attrifyString(uw_context ctx, uw_Basis_string s) {
return result;
}
+char *uw_Basis_attrifyChar(uw_context ctx, uw_Basis_char c) {
+ char *result, *p;
+ uw_check_heap(ctx, 7);
+
+ result = p = ctx->heap.front;
+
+ if (c == '"') {
+ strcpy(p, """);
+ p += 6;
+ } else if (c == '&') {
+ strcpy(p, "&");
+ p += 5;
+ }
+ else if (isprint(c))
+ *p++ = c;
+ else {
+ int len2;
+ sprintf(p, "&#%d;%n", c, &len2);
+ p += len2;
+ }
+
+ *p++ = 0;
+ ctx->heap.front = p;
+ return result;
+}
+
char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) {
return s;
}
@@ -1438,6 +1464,24 @@ uw_unit uw_Basis_attrifyString_w(uw_context ctx, uw_Basis_string s) {
return uw_unit_v;
}
+uw_unit uw_Basis_attrifyChar_w(uw_context ctx, uw_Basis_char c) {
+ uw_check(ctx, 6);
+
+ if (c == '"')
+ uw_write_unsafe(ctx, """);
+ else if (c == '&')
+ uw_write_unsafe(ctx, "&");
+ else if (isprint(c))
+ uw_writec_unsafe(ctx, c);
+ else {
+ uw_write_unsafe(ctx, "&#");
+ uw_Basis_attrifyInt_w_unsafe(ctx, c);
+ uw_writec_unsafe(ctx, ';');
+ }
+
+ return uw_unit_v;
+}
+
char *uw_Basis_urlifyInt(uw_context ctx, uw_Basis_int n) {
int len;
@@ -1988,6 +2032,7 @@ char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) {
int uw_Estrings = 1;
char *uw_sqlsuffixString = "::text";
+char *uw_sqlsuffixChar = "::char";
uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
char *r, *s2;
@@ -2035,6 +2080,48 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
return r;
}
+uw_Basis_string uw_Basis_sqlifyChar(uw_context ctx, uw_Basis_char c) {
+ char *r, *s2;
+
+ uw_check_heap(ctx, 5 + uw_Estrings + strlen(uw_sqlsuffixChar));
+
+ r = s2 = ctx->heap.front;
+ if (uw_Estrings)
+ *s2++ = 'E';
+ *s2++ = '\'';
+
+ switch (c) {
+ case '\'':
+ if (uw_Estrings)
+ strcpy(s2, "\\'");
+ else
+ strcpy(s2, "''");
+ s2 += 2;
+ break;
+ case '\\':
+ if (uw_Estrings) {
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ } else
+ *s2++ = '\\';
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else if (uw_Estrings) {
+ sprintf(s2, "\\%03o", c);
+ s2 += 4;
+ }
+ else
+ uw_error(ctx, FATAL, "Non-printable character %u in char to SQLify", c);
+ }
+
+ *s2++ = '\'';
+ strcpy(s2, uw_sqlsuffixChar);
+ ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixChar);
+ return r;
+}
+
char *uw_sqlsuffixBlob = "::bytea";
uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) {
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 25666d97..d63c9099 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -491,20 +491,7 @@ fun isFile (t : typ) =
TFfi ("Basis", "file") => true
| _ => false
-fun p_sql_type' t =
- case t of
- Int => "uw_Basis_int"
- | Float => "uw_Basis_float"
- | String => "uw_Basis_string"
- | Bool => "uw_Basis_bool"
- | Time => "uw_Basis_time"
- | Blob => "uw_Basis_blob"
- | Channel => "uw_Basis_channel"
- | Client => "uw_Basis_client"
- | Nullable String => "uw_Basis_string"
- | Nullable t => p_sql_type' t ^ "*"
-
-fun p_sql_type t = string (p_sql_type' t)
+fun p_sql_type t = string (Settings.p_sql_ctype t)
fun getPargs (e, _) =
case e of
@@ -1308,6 +1295,7 @@ fun sql_type_in env (tAll as (t, loc)) =
TFfi ("Basis", "int") => Int
| TFfi ("Basis", "float") => Float
| TFfi ("Basis", "string") => String
+ | TFfi ("Basis", "char") => Char
| TFfi ("Basis", "bool") => Bool
| TFfi ("Basis", "time") => Time
| TFfi ("Basis", "blob") => Blob
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 9b9308be..78754082 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -45,12 +45,16 @@ fun attrifyFloat n =
else
Real.toString n
-val attrifyString = String.translate (fn #"\"" => """
- | #"&" => "&"
- | ch => if Char.isPrint ch then
- str ch
- else
- "&#" ^ Int.toString (ord ch) ^ ";")
+fun attrifyChar ch =
+ case ch of
+ #"\"" => """
+ | #"&" => "&"
+ | ch => if Char.isPrint ch then
+ str ch
+ else
+ "&#" ^ Int.toString (ord ch) ^ ";"
+
+val attrifyString = String.translate attrifyChar
val urlifyInt = attrifyInt
val urlifyFloat = attrifyFloat
@@ -95,6 +99,7 @@ fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int)
fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float)
fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s
+fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch)
fun unAs s =
let
@@ -260,6 +265,13 @@ fun exp e =
| EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
+ | EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]) =>
+ EPrim (Prim.String (attrifyChar s))
+ | EWrite (EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]), loc) =>
+ EWrite (EPrim (Prim.String (attrifyChar s)), loc)
+ | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) =>
+ EFfiApp ("Basis", "attrifyChar_w", [e])
+
| EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) =>
EPrim (Prim.String s)
| EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) =>
@@ -318,6 +330,8 @@ fun exp e =
result = (TFfi ("Basis", "string"), loc)}), loc)
| EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
EPrim (Prim.String (sqlifyString n))
+ | EFfiApp ("Basis", "sqlifyChar", [(EPrim (Prim.Char n), _)]) =>
+ EPrim (Prim.String (sqlifyChar n))
| EWrite (ECase (discE, pes, {disc, ...}), loc) =>
optExp (ECase (discE,
diff --git a/src/monoize.sml b/src/monoize.sml
index a01f953f..6512eb1e 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1921,6 +1921,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
fm)
+ | L.EFfi ("Basis", "sql_char") =>
+ ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
+ (L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc),
+ fm)
| L.EFfi ("Basis", "sql_time") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
(L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
diff --git a/src/mysql.sml b/src/mysql.sml
index 2941186c..d4db8710 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -36,6 +36,7 @@ fun p_sql_type t =
Int => "bigint"
| Float => "double"
| String => "longtext"
+ | Char => "char"
| Bool => "bool"
| Time => "timestamp"
| Blob => "longblob"
@@ -48,6 +49,7 @@ fun p_buffer_type t =
Int => "MYSQL_TYPE_LONGLONG"
| Float => "MYSQL_TYPE_DOUBLE"
| String => "MYSQL_TYPE_STRING"
+ | Char => "MYSQL_TYPE_TINY"
| Bool => "MYSQL_TYPE_LONG"
| Time => "MYSQL_TYPE_TIMESTAMP"
| Blob => "MYSQL_TYPE_BLOB"
@@ -60,6 +62,7 @@ fun p_sql_type_base t =
Int => "bigint"
| Float => "double"
| String => "longtext"
+ | Char => "char"
| Bool => "tinyint"
| Time => "timestamp"
| Blob => "longblob"
@@ -386,6 +389,8 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
string "uw_sqlsuffixString = \"\";",
newline,
+ string "uw_sqlsuffixChar = \"\";",
+ newline,
string "uw_sqlsuffixBlob = \"\";",
newline,
string "uw_sqlfmtUint4 = \"%u%n\";",
diff --git a/src/postgres.sml b/src/postgres.sml
index f3942db4..12142fe2 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -39,6 +39,7 @@ fun p_sql_type t =
Int => "int8"
| Float => "float8"
| String => "text"
+ | Char => "char"
| Bool => "bool"
| Time => "timestamp"
| Blob => "bytea"
@@ -51,6 +52,7 @@ fun p_sql_type_base t =
Int => "bigint"
| Float => "double precision"
| String => "text"
+ | Char => "character"
| Bool => "boolean"
| Time => "timestamp without time zone"
| Blob => "bytea"
@@ -257,6 +259,8 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
string "uw_sqlsuffixString = \"::text\";",
newline,
+ string "uw_sqlsuffixChar = \"::char\";",
+ newline,
string "uw_sqlsuffixBlob = \"::bytea\";",
newline,
string "uw_sqlfmtUint4 = \"%u::int4%n\";",
@@ -505,6 +509,7 @@ fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
e
else
box [string "uw_strdup(ctx, ", e, string ")"]
+ | Char => box [e, string "[0]"]
| Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
| Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"]
| Blob => box [string "uw_Basis_stringToBlob_error(ctx, ",
@@ -643,6 +648,7 @@ fun p_ensql t e =
Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
| Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
| String => e
+ | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"]
| Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
| Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
| Blob => box [e, string ".data"]
diff --git a/src/settings.sig b/src/settings.sig
index 1da58193..f07477e5 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -105,6 +105,7 @@ signature SETTINGS = sig
Int
| Float
| String
+ | Char
| Bool
| Time
| Blob
diff --git a/src/settings.sml b/src/settings.sml
index bed027a3..05a9e5da 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -282,6 +282,7 @@ datatype sql_type =
Int
| Float
| String
+ | Char
| Bool
| Time
| Blob
@@ -298,6 +299,7 @@ fun p_sql_ctype t =
Int => "uw_Basis_int"
| Float => "uw_Basis_float"
| String => "uw_Basis_string"
+ | Char => "uw_Basis_char"
| Bool => "uw_Basis_bool"
| Time => "uw_Basis_time"
| Blob => "uw_Basis_blob"
diff --git a/src/sqlite.sml b/src/sqlite.sml
index b1252b95..f0ebac2f 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -36,6 +36,7 @@ fun p_sql_type t =
Int => "integer"
| Float => "real"
| String => "text"
+ | Char => "integer"
| Bool => "integer"
| Time => "text"
| Blob => "blob"
@@ -165,6 +166,8 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
string "uw_sqlsuffixString = \"\";",
newline,
+ string "uw_sqlsuffixChar = \"\";",
+ newline,
string "uw_sqlsuffixBlob = \"\";",
newline,
string "uw_sqlfmtUint4 = \"%u%n\";",
@@ -370,6 +373,7 @@ fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")"]
else
box [string "uw_strdup(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
+ | Char => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
| Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
| Time => box [string "uw_Basis_stringToTime_error(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
| Blob => box [string "({",
@@ -523,6 +527,11 @@ fun p_inputs loc =
string ", ",
arg,
string ", -1, SQLITE_TRANSIENT)"]
+ | Char => box [string "sqlite3_bind_int(stmt, ",
+ string (Int.toString (i + 1)),
+ string ", ",
+ arg,
+ string ")"]
| Bool => box [string "sqlite3_bind_int(stmt, ",
string (Int.toString (i + 1)),
string ", ",
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-19 07:28:25 +0000