Mercurial > urweb
changeset 870:7fa9a37a34b3
Move all DBMS initialization to #init
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 30 Jun 2009 15:45:10 -0400 |
| parents | 64ba57fa20bf |
| children | 3ae6b655ced0 |
| files | src/cjr_print.sml src/mysql.sml src/postgres.sml src/settings.sig src/settings.sml |
| diffstat | 5 files changed, 355 insertions(+), 329 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Jun 28 16:41:10 2009 -0400 +++ b/src/cjr_print.sml Tue Jun 30 15:45:10 2009 -0400 @@ -1837,8 +1837,6 @@ string "}"] end -val prepped = ref ([] : (string * int) list) - fun p_decl env (dAll as (d, _) : decl) = case d of DStruct (n, xts) => @@ -1990,35 +1988,8 @@ space, string " */", newline] - | DDatabase {name, expunge, initialize} => - box [string "static void uw_db_validate(uw_context);", - newline, - string "static void uw_db_prepare(uw_context);", - newline, - newline, - - #init (Settings.currentDbms ()) (name, !prepped), - - string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {", - newline, - box [p_enamed env expunge, - string "(ctx, cli);", - newline], - string "}", - newline, - newline, - - string "void uw_initializer(uw_context ctx) {", - newline, - box [p_enamed env initialize, - string "(ctx, uw_unit_v);", - newline], - string "}", - newline] - - | DPreparedStatements ss => - (prepped := ss; - box []) + | DDatabase _ => box [] + | DPreparedStatements _ => box [] | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), @@ -2605,267 +2576,27 @@ val pds' = map p_page ps - val tables = List.mapPartial (fn (DTable (s, xts, _, _), _) => SOME (s, xts) - | _ => NONE) ds - val sequences = List.mapPartial (fn (DSequence s, _) => SOME s - | _ => NONE) ds + val hasDb = ref false + val tables = ref [] + val sequences = ref [] + val dbstring = ref "" + val expunge = ref 0 + val initialize = ref 0 + val prepped = ref [] - val validate = - if #persistent (Settings.currentProtocol ()) then - box [string "static void uw_db_validate(uw_context ctx) {", - newline, - string "PGconn *conn = uw_get_db(ctx);", - newline, - string "PGresult *res;", - newline, - newline, - p_list_sep newline - (fn (s, xts) => - let - val sl = CharVector.map Char.toLower s + val () = app (fn d => + case #1 d of + DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true; + dbstring := x; + expunge := y; + initialize := z) + | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) => + (x, sql_type_in env t)) xts) :: !tables + | DSequence s => sequences := s :: !sequences + | DPreparedStatements ss => prepped := ss + | _ => ()) ds - val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" - ^ sl ^ "'" - - val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", - sl, - "') AND (", - String.concatWith " OR " - (map (fn (x, t) => - String.concat ["(attname = 'uw_", - CharVector.map - Char.toLower (ident x), - "' AND atttypid = (SELECT oid FROM pg_type", - " WHERE typname = '", - p_sqltype_base' env t, - "') AND attnotnull = ", - if is_not_null t then - "TRUE" - else - "FALSE", - ")"]) xts), - ")"] - - val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", - sl, - "') AND attname LIKE 'uw_%'"] - in - box [string "res = PQexec(conn, \"", - string q, - string "\");", - newline, - newline, - string "if (res == NULL) {", - newline, - box [string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", - newline], - string "}", - newline, - newline, - string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", - newline, - box [string "char msg[1024];", - newline, - string "strncpy(msg, PQerrorMessage(conn), 1024);", - newline, - string "msg[1023] = 0;", - newline, - string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Query failed:\\n", - string q, - string "\\n%s\", msg);", - newline], - string "}", - newline, - newline, - string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", - newline, - box [string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Table '", - string s, - string "' does not exist.\");", - newline], - string "}", - newline, - newline, - string "PQclear(res);", - newline, - - string "res = PQexec(conn, \"", - string q', - string "\");", - newline, - newline, - string "if (res == NULL) {", - newline, - box [string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", - newline], - string "}", - newline, - newline, - string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", - newline, - box [string "char msg[1024];", - newline, - string "strncpy(msg, PQerrorMessage(conn), 1024);", - newline, - string "msg[1023] = 0;", - newline, - string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Query failed:\\n", - string q', - string "\\n%s\", msg);", - newline], - string "}", - newline, - newline, - string "if (strcmp(PQgetvalue(res, 0, 0), \"", - string (Int.toString (length xts)), - string "\")) {", - newline, - box [string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Table '", - string s, - string "' has the wrong column types.\");", - newline], - string "}", - newline, - newline, - string "PQclear(res);", - newline, - newline, - - string "res = PQexec(conn, \"", - string q'', - string "\");", - newline, - newline, - string "if (res == NULL) {", - newline, - box [string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", - newline], - string "}", - newline, - newline, - string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", - newline, - box [string "char msg[1024];", - newline, - string "strncpy(msg, PQerrorMessage(conn), 1024);", - newline, - string "msg[1023] = 0;", - newline, - string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Query failed:\\n", - string q'', - string "\\n%s\", msg);", - newline], - string "}", - newline, - newline, - string "if (strcmp(PQgetvalue(res, 0, 0), \"", - string (Int.toString (length xts)), - string "\")) {", - newline, - box [string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Table '", - string s, - string "' has extra columns.\");", - newline], - string "}", - newline, - newline, - string "PQclear(res);", - newline] - end) tables, - - p_list_sep newline - (fn s => - let - val sl = CharVector.map Char.toLower s - - val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" - ^ sl ^ "' AND relkind = 'S'" - in - box [string "res = PQexec(conn, \"", - string q, - string "\");", - newline, - newline, - string "if (res == NULL) {", - newline, - box [string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", - newline], - string "}", - newline, - newline, - string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", - newline, - box [string "char msg[1024];", - newline, - string "strncpy(msg, PQerrorMessage(conn), 1024);", - newline, - string "msg[1023] = 0;", - newline, - string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Query failed:\\n", - string q, - string "\\n%s\", msg);", - newline], - string "}", - newline, - newline, - string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", - newline, - box [string "PQclear(res);", - newline, - string "PQfinish(conn);", - newline, - string "uw_error(ctx, FATAL, \"Sequence '", - string s, - string "' does not exist.\");", - newline], - string "}", - newline, - newline, - string "PQclear(res);", - newline] - end) sequences, - - string "}"] - else - string "static void uw_db_validate(uw_context ctx) { }" - - val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds + val hasDb = !hasDb val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds @@ -2920,7 +2651,6 @@ newline] else box [], - newline, p_list_sep (box []) (fn s => box [string "#include \"", string s, string "\"", @@ -2932,6 +2662,22 @@ newline, newline, + if hasDb then + #init (Settings.currentDbms ()) {dbstring = !dbstring, + prepared = !prepped, + tables = !tables, + sequences = !sequences} + else + box [string "void uw_db_init(uw_context ctx) { };", + newline, + string "int uw_db_begin(uw_context ctx) { return 0; };", + newline, + string "int uw_db_commit(uw_context ctx) { return 0; };", + newline, + string "int uw_db_rollback(uw_context ctx) { return 0; };"], + newline, + newline, + string "const char *uw_url_prefix = \"", string (Settings.getUrlPrefix ()), string "\";", @@ -3008,24 +2754,26 @@ string "}", newline, newline, + if hasDb then - validate + box [string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {", + newline, + box [p_enamed env (!expunge), + string "(ctx, cli);", + newline], + string "}", + newline, + newline, + + string "void uw_initializer(uw_context ctx) {", + newline, + box [p_enamed env (!initialize), + string "(ctx, uw_unit_v);", + newline], + string "}", + newline] else - box [], - newline, - if List.exists (fn (DDatabase _, _) => true | _ => false) ds then - box [] - else - box [newline, - string "void uw_db_init(uw_context ctx) { };", - newline, - string "int uw_db_begin(uw_context ctx) { return 0; };", - newline, - string "int uw_db_commit(uw_context ctx) { return 0; };", - newline, - string "int uw_db_rollback(uw_context ctx) { return 0; };", - newline, - string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };", + box [string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };", newline, string "void uw_initializer(uw_context ctx) { };", newline]]
--- a/src/mysql.sml Sun Jun 28 16:41:10 2009 -0400 +++ b/src/mysql.sml Tue Jun 30 15:45:10 2009 -0400 @@ -31,7 +31,7 @@ open Print.PD open Print -fun init (dbstring, ss) = +fun init {dbstring, prepared = ss, tables, sequences} = let val host = ref NONE val user = ref NONE
--- a/src/postgres.sml Sun Jun 28 16:41:10 2009 -0400 +++ b/src/postgres.sml Tue Jun 30 15:45:10 2009 -0400 @@ -31,9 +31,275 @@ open Print.PD open Print -fun init (dbstring, ss) = +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +fun p_sql_type_base t = + case t of + Int => "int8" + | Float => "float8" + | String => "text" + | Bool => "bool" + | Time => "timestamp" + | Blob => "bytea" + | Channel => "int8" + | Client => "int4" + | Nullable t => p_sql_type_base t + +fun init {dbstring, prepared = ss, tables, sequences} = box [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 "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res;", + newline, + newline, + p_list_sep newline + (fn (s, xts) => + let + val sl = CharVector.map Char.toLower s + + val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" + ^ sl ^ "'" + + val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", + sl, + "') AND (", + String.concatWith " OR " + (map (fn (x, t) => + String.concat ["(attname = 'uw_", + CharVector.map + Char.toLower (ident x), + "' AND atttypid = (SELECT oid FROM pg_type", + " WHERE typname = '", + p_sql_type_base t, + "') AND attnotnull = ", + if isNotNull t then + "TRUE" + else + "FALSE", + ")"]) xts), + ")"] + + val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", + sl, + "') AND attname LIKE 'uw_%'"] + in + box [string "res = PQexec(conn, \"", + string q, + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string s, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline, + + string "res = PQexec(conn, \"", + string q', + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q', + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string s, + string "' has the wrong column types.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline, + newline, + + string "res = PQexec(conn, \"", + string q'', + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q'', + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string s, + string "' has extra columns.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline] + end) tables, + + p_list_sep newline + (fn s => + let + val sl = CharVector.map Char.toLower s + + val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" + ^ sl ^ "' AND relkind = 'S'" + in + box [string "res = PQexec(conn, \"", + string q, + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Sequence '", + string s, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline] + end) sequences, + + string "}", + + string "static void uw_db_prepare(uw_context ctx) {", newline, string "PGconn *conn = uw_get_db(ctx);", newline, @@ -153,7 +419,10 @@ newline, newline] else - string "static void uw_db_prepare(uw_context ctx) { }", + box [string "static void uw_db_validate(uw_context ctx) { }", + newline, + string "static void uw_db_prepare(uw_context ctx) { }"], + newline, newline, @@ -222,10 +491,10 @@ String => getter t | _ => box [string "({", newline, - p_sql_type t, + string (p_sql_type t), space, string "*tmp = uw_malloc(ctx, sizeof(", - p_sql_type t, + string (p_sql_type t), string "));", newline, string "*tmp = ", @@ -241,7 +510,7 @@ string (Int.toString i), string ") ? ", box [string "({", - p_sql_type t, + string (p_sql_type t), space, string "tmp;", newline,
--- a/src/settings.sig Sun Jun 28 16:41:10 2009 -0400 +++ b/src/settings.sig Tue Jun 30 15:45:10 2009 -0400 @@ -112,8 +112,9 @@ | Client | Nullable of sql_type - val p_sql_type : sql_type -> Print.PD.pp_desc + val p_sql_type : sql_type -> string val isBlob : sql_type -> bool + val isNotNull : sql_type -> bool type dbms = { name : string, @@ -124,9 +125,11 @@ (* Pass these linker arguments *) global_init : Print.PD.pp_desc, (* Define uw_client_init() *) - init : string * (string * int) list -> Print.PD.pp_desc, - (* Define uw_db_init(), uw_db_close(), uw_db_begin(), uw_db_commit(), and uw_db_rollback() - * from dbstring and prepared statements *) + init : {dbstring : string, + prepared : (string * int) list, + tables : (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() *) query : {loc : ErrorMsg.span, numCols : int, doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) -> Print.PD.pp_desc}
--- a/src/settings.sml Sun Jun 28 16:41:10 2009 -0400 +++ b/src/settings.sml Tue Jun 30 15:45:10 2009 -0400 @@ -291,28 +291,34 @@ open Print in case t of - Int => string "uw_Basis_int" - | Float => string "uw_Basis_float" - | String => string "uw_Basis_string" - | Bool => string "uw_Basis_bool" - | Time => string "uw_Basis_time" - | Blob => string "uw_Basis_blob" - | Channel => string "uw_Basis_channel" - | Client => string "uw_Basis_client" - | Nullable String => string "uw_Basis_string" - | Nullable t => box [p_sql_type t, string "*"] + 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 ^ "*" end fun isBlob Blob = true | isBlob (Nullable t) = isBlob t | isBlob _ = false +fun isNotNull (Nullable _) = false + | isNotNull _ = true + type dbms = { name : string, header : string, link : string, global_init : Print.PD.pp_desc, - init : string * (string * int) list -> Print.PD.pp_desc, + init : {dbstring : string, + prepared : (string * int) list, + tables : (string * (string * sql_type) list) list, + sequences : string list} -> Print.PD.pp_desc, query : {loc : ErrorMsg.span, numCols : int, doCols : ({wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) -> Print.PD.pp_desc}