summaryrefslogtreecommitdiff
path: root/src/mysql.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-07-12 13:16:05 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-07-12 13:16:05 -0400
commit20b1f5880b6553c42f2a71fd5ad38b865faed6b6 (patch)
treec6e217e7e4e071638bb0a153e40c69d4e5f87a9b /src/mysql.sml
parent214f1f451fc04f7d8b5999a0f33a6794d47241f8 (diff)
MySQL query gets up to C linking
Diffstat (limited to 'src/mysql.sml')
-rw-r--r--src/mysql.sml513
1 files changed, 507 insertions, 6 deletions
diff --git a/src/mysql.sml b/src/mysql.sml
index 7b02c787..2fcdef2d 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -31,6 +31,30 @@ open Settings
open Print.PD
open Print
+fun p_sql_type t =
+ case t of
+ Int => "bigint"
+ | Float => "double"
+ | String => "longtext"
+ | Bool => "bool"
+ | Time => "timestamp"
+ | Blob => "longblob"
+ | Channel => "bigint"
+ | Client => "int"
+ | Nullable t => p_sql_type t
+
+fun p_buffer_type t =
+ case t of
+ Int => "MYSQL_TYPE_LONGLONG"
+ | Float => "MYSQL_TYPE_DOUBLE"
+ | String => "MYSQL_TYPE_STRING"
+ | Bool => "MYSQL_TYPE_LONG"
+ | Time => "MYSQL_TYPE_TIME"
+ | Blob => "MYSQL_TYPE_BLOB"
+ | Channel => "MYSQL_TYPE_LONGLONG"
+ | Client => "MYSQL_TYPE_LONG"
+ | Nullable t => p_buffer_type t
+
fun init {dbstring, prepared = ss, tables, views, sequences} =
let
val host = ref NONE
@@ -138,6 +162,10 @@ 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,
@@ -253,12 +281,484 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline]
end
-fun query _ = raise Fail "MySQL query"
-fun queryPrepared _ = raise Fail "MySQL queryPrepared"
-fun dml _ = raise Fail "MySQL dml"
-fun dmlPrepared _ = raise Fail "MySQL dmlPrepared"
-fun nextval _ = raise Fail "MySQL nextval"
-fun nextvalPrepared _ = raise Fail "MySQL nextvalPrepared"
+fun p_getcol {wontLeakStrings = _, col = i, typ = t} =
+ let
+ fun getter t =
+ case t of
+ String => box [string "({",
+ newline,
+ string "uw_Basis_string s = uw_malloc(ctx, length",
+ string (Int.toString i),
+ string " + 1);",
+ newline,
+ string "out[",
+ string (Int.toString i),
+ string "].buffer = s;",
+ newline,
+ string "out[",
+ string (Int.toString i),
+ string "].buffer_length = length",
+ string (Int.toString i),
+ string " + 1;",
+ newline,
+ string "mysql_stmt_fetch_column(stmt, &out[",
+ string (Int.toString i),
+ string "], ",
+ string (Int.toString i),
+ string ", 0);",
+ newline,
+ string "s[length",
+ string (Int.toString i),
+ string "] = 0;",
+ newline,
+ string "s;",
+ newline,
+ string "})"]
+ | Blob => box [string "({",
+ newline,
+ string "uw_Basis_blob b = {length",
+ string (Int.toString i),
+ string ", uw_malloc(ctx, length",
+ string (Int.toString i),
+ string ")};",
+ newline,
+ string "out[",
+ string (Int.toString i),
+ string "].buffer = b.data;",
+ newline,
+ string "out[",
+ string (Int.toString i),
+ string "].buffer_length = length",
+ string (Int.toString i),
+ string ";",
+ newline,
+ string "mysql_stmt_fetch_column(stmt, &out[",
+ string (Int.toString i),
+ string "], ",
+ string (Int.toString i),
+ string ", 0);",
+ newline,
+ string "b;",
+ newline,
+ string "})"]
+ | Time => box [string "({",
+ string "MYSQL_TIME *mt = buffer",
+ string (Int.toString i),
+ string ";",
+ newline,
+ newline,
+ string "struct tm t = {mt->second, mt->minute, mt->hour, mt->day, mt->month, mt->year, 0, 0, -1};",
+ newline,
+ string "mktime(&tm);",
+ newline,
+ string "})"]
+ | _ => box [string "buffer",
+ string (Int.toString i)]
+ in
+ case t of
+ Nullable t => box [string "(is_null",
+ string (Int.toString i),
+ string " ? NULL : ",
+ case t of
+ String => getter t
+ | _ => box [string "({",
+ newline,
+ string (p_sql_ctype t),
+ space,
+ string "*tmp = uw_malloc(ctx, sizeof(",
+ string (p_sql_ctype t),
+ string "));",
+ newline,
+ string "*tmp = ",
+ getter t,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"],
+ string ")"]
+ | _ => box [string "(is_null",
+ string (Int.toString i),
+ string " ? ",
+ box [string "({",
+ string (p_sql_ctype t),
+ space,
+ string "tmp;",
+ newline,
+ string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
+ string (Int.toString i),
+ string "\");",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"],
+ string " : ",
+ getter t,
+ string ")"]
+ end
+
+fun queryCommon {loc, query, cols, doCols} =
+ box [string "int n, r;",
+ newline,
+ string "MYSQL_BIND out[",
+ string (Int.toString (length cols)),
+ string "];",
+ newline,
+ p_list_sepi (box []) (fn i => fn t =>
+ let
+ fun buffers t =
+ case t of
+ String => box [string "unsigned long length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | Blob => box [string "unsigned long length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | _ => box [string (p_sql_ctype t),
+ space,
+ string "buffer",
+ string (Int.toString i),
+ string ";",
+ newline]
+ in
+ box [string "my_bool is_null",
+ string (Int.toString i),
+ string ";",
+ newline,
+ case t of
+ Nullable t => buffers t
+ | _ => buffers t,
+ newline]
+ end) cols,
+ newline,
+
+ string "memset(out, 0, sizeof out);",
+ newline,
+ p_list_sepi (box []) (fn i => fn t =>
+ let
+ fun buffers t =
+ case t of
+ String => box []
+ | Blob => box []
+ | _ => box [string "out[",
+ string (Int.toString i),
+ string "].buffer = &buffer",
+ string (Int.toString i),
+ string ";",
+ newline]
+ in
+ box [string "out[",
+ string (Int.toString i),
+ string "].buffer_type = ",
+ string (p_buffer_type t),
+ string ";",
+ newline,
+ string "out[",
+ string (Int.toString i),
+ string "].is_null = &is_null",
+ string (Int.toString i),
+ string ";",
+ newline,
+
+ case t of
+ Nullable t => buffers t
+ | _ => buffers t,
+ newline]
+ end) cols,
+ newline,
+
+ string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error executing query\");",
+ newline,
+ newline,
+
+ string "if (mysql_stmt_store_result(stmt)) uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error storing query result\");",
+ newline,
+ newline,
+
+ string "if (mysql_stmt_bind_result(stmt, out)) uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": Error binding query result\");",
+ newline,
+ newline,
+
+ string "uw_end_region(ctx);",
+ newline,
+ string "while ((r = mysql_stmt_fetch(stmt)) == 0) {",
+ newline,
+ doCols p_getcol,
+ string "}",
+ newline,
+ newline,
+
+ string "if (r != MYSQL_NO_DATA) uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": query result fetching failed\");",
+ newline]
+
+fun query {loc, cols, doCols} =
+ box [string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "MYSQL_stmt *stmt = mysql_stmt_init(conn->conn);",
+ newline,
+ string "if (stmt == NULL) uw_error(ctx, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": can't allocate temporary prepared statement\");",
+ newline,
+ string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);",
+ newline,
+ string "if (mysql_stmt_prepare(stmt, query, strlen(query))) uw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string "\");",
+ newline,
+ newline,
+
+ p_list_sepi (box []) (fn i => fn t =>
+ let
+ fun buffers t =
+ case t of
+ String => box []
+ | Blob => box []
+ | _ => box [string "out[",
+ string (Int.toString i),
+ string "].buffer = &buffer",
+ string (Int.toString i),
+ string ";",
+ newline]
+ in
+ box [string "in[",
+ string (Int.toString i),
+ string "].buffer_type = ",
+ string (p_buffer_type t),
+ string ";",
+ newline,
+
+ case t of
+ Nullable t => box [string "in[",
+ string (Int.toString i),
+ string "].is_null = &is_null",
+ string (Int.toString i),
+ string ";",
+ newline,
+ buffers t]
+ | _ => buffers t,
+ newline]
+ end) cols,
+ newline,
+
+ queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
+
+ string "uw_pop_cleanup(ctx);",
+ newline]
+
+fun p_ensql t e =
+ case t of
+ Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
+ | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
+ | String => e
+ | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
+ | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
+ | Blob => box [e, string ".data"]
+ | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
+ | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
+ | Nullable String => e
+ | Nullable t => box [string "(",
+ e,
+ string " == NULL ? NULL : ",
+ p_ensql t (box [string "(*", e, string ")"]),
+ string ")"]
+
+fun queryPrepared {loc, id, query, inputs, cols, doCols} =
+ box [string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "MYSQL_BIND in[",
+ string (Int.toString (length inputs)),
+ string "];",
+ newline,
+ p_list_sepi (box []) (fn i => fn t =>
+ let
+ fun buffers t =
+ case t of
+ String => box [string "unsigned long in_length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | Blob => box [string "unsigned long in_length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | Time => box [string (p_sql_ctype t),
+ space,
+ string "in_buffer",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | _ => box []
+ in
+ box [case t of
+ Nullable t => box [string "my_bool in_is_null",
+ string (Int.toString i),
+ string ";",
+ newline,
+ buffers t]
+ | _ => buffers t,
+ newline]
+ end) inputs,
+ string "MYSQL_STMT *stmt = conn->p",
+ string (Int.toString id),
+ string ";",
+ newline,
+ newline,
+
+ string "memset(in, 0, sizeof in);",
+ newline,
+ p_list_sepi (box []) (fn i => fn t =>
+ let
+ fun buffers t =
+ case t of
+ String => box [string "in[",
+ string (Int.toString i),
+ string "].buffer = arg",
+ string (Int.toString (i + 1)),
+ string ";",
+ newline,
+ string "in_length",
+ string (Int.toString i),
+ string "= in[",
+ string (Int.toString i),
+ string "].buffer_length = strlen(arg",
+ string (Int.toString (i + 1)),
+ string ");",
+ newline,
+ string "in[",
+ string (Int.toString i),
+ string "].length = &in_length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | Blob => box [string "in[",
+ string (Int.toString i),
+ string "].buffer = arg",
+ string (Int.toString (i + 1)),
+ string ".data;",
+ newline,
+ string "in_length",
+ string (Int.toString i),
+ string "= in[",
+ string (Int.toString i),
+ string "].buffer_length = arg",
+ string (Int.toString (i + 1)),
+ string ".size;",
+ newline,
+ string "in[",
+ string (Int.toString i),
+ string "].length = &in_length",
+ string (Int.toString i),
+ string ";",
+ newline]
+ | Time =>
+ let
+ fun oneField dst src =
+ box [string "in_buffer",
+ string (Int.toString i),
+ string ".",
+ string dst,
+ string " = tms.tm_",
+ string src,
+ string ";",
+ newline]
+ in
+ box [string "({",
+ newline,
+ string "struct tm tms;",
+ newline,
+ string "if (localtime_r(&arg",
+ string (Int.toString (i + 1)),
+ string ", &tm) == NULL) uw_error(\"",
+ string (ErrorMsg.spanToString loc),
+ string ": error converting to MySQL time\");",
+ newline,
+ oneField "year" "year",
+ oneField "month" "mon",
+ oneField "day" "mday",
+ oneField "hour" "hour",
+ oneField "minute" "min",
+ oneField "second" "sec",
+ newline,
+ string "in[",
+ string (Int.toString i),
+ string "].buffer = &in_buffer",
+ string (Int.toString i),
+ string ";",
+ newline]
+ end
+
+ | _ => box [string "in[",
+ string (Int.toString i),
+ string "].buffer = &arg",
+ string (Int.toString (i + 1)),
+ string ";",
+ newline]
+ in
+ box [string "in[",
+ string (Int.toString i),
+ string "].buffer_type = ",
+ string (p_buffer_type t),
+ string ";",
+ newline,
+
+ case t of
+ Nullable t => box [string "in[",
+ string (Int.toString i),
+ string "].is_null = &in_is_null",
+ string (Int.toString i),
+ string ";",
+ newline,
+ string "if (arg",
+ string (Int.toString (i + 1)),
+ string " == NULL) {",
+ newline,
+ box [string "in_is_null",
+ string (Int.toString i),
+ string " = 1;",
+ newline],
+ string "} else {",
+ box [case t of
+ String => box []
+ | _ =>
+ box [string (p_sql_ctype t),
+ space,
+ string "arg",
+ string (Int.toString (i + 1)),
+ string " = *arg",
+ string (Int.toString (i + 1)),
+ string ";",
+ newline],
+ string "in_is_null",
+ string (Int.toString i),
+ string " = 0;",
+ newline,
+ buffers t,
+ newline]]
+
+ | _ => buffers t,
+ newline]
+ end) inputs,
+ newline,
+
+ queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
+ string (String.toString query),
+ string "\""]}]
+
+fun dml _ = box []
+fun dmlPrepared _ = box []
+fun nextval _ = box []
+fun nextvalPrepared _ = box []
val () = addDbms {name = "mysql",
header = "mysql/mysql.h",
@@ -276,6 +776,7 @@ val () = addDbms {name = "mysql",
string "}",
newline],
init = init,
+ p_sql_type = p_sql_type,
query = query,
queryPrepared = queryPrepared,
dml = dml,