Mercurial > urweb
changeset 878:a8952047e1d3
Sequence code compiles in MySQL
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Jul 2009 16:29:13 -0400 |
| parents | dae141d911d9 |
| children | b2a175a0f2ef |
| files | src/cjr_print.sml src/mysql.sml src/postgres.sml src/prepare.sml src/settings.sig src/settings.sml |
| diffstat | 6 files changed, 165 insertions(+), 70 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Thu Jul 16 13:59:30 2009 -0400 +++ b/src/cjr_print.sml Thu Jul 16 16:29:13 2009 -0400 @@ -1737,41 +1737,26 @@ string "}))"] | ENextval {seq, prepared} => - let - val query = case seq of - (EPrim (Prim.String s), loc) => - (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) - | _ => - let - val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - in - (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) - end - in - box [string "(uw_begin_region(ctx), ", - string "({", - newline, - string "uw_Basis_int n;", - newline, + box [string "({", + newline, + string "uw_Basis_int n;", + newline, - case prepared of - NONE => box [string "char *query = ", - p_exp env query, - string ";", - newline, - newline, + case prepared of + NONE => #nextval (Settings.currentDbms ()) {loc = loc, + seqE = p_exp env seq, + seqName = case #1 seq of + EPrim (Prim.String s) => SOME s + | _ => NONE} + | SOME (id, query) => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, + id = id, + query = query}, + newline, + newline, - #nextval (Settings.currentDbms ()) loc] - | SOME (id, query) => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, - id = id, - query = query}, - newline, - newline, - - string "n;", - newline, - string "}))"] - end + string "n;", + newline, + string "})"] | EUnurlify (e, t) => let
--- a/src/mysql.sml Thu Jul 16 13:59:30 2009 -0400 +++ b/src/mysql.sml Thu Jul 16 16:29:13 2009 -0400 @@ -907,6 +907,36 @@ newline, newline, + string "if (stmt == NULL) {", + newline, + box [string "stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");", + newline, + string "if (mysql_stmt_prepare(stmt, \"", + string (String.toString query), + string "\", ", + string (Int.toString (size query)), + string ")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_stmt_error(stmt), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);", + newline], + string "}", + newline, + string "conn->p", + string (Int.toString id), + string " = stmt;", + newline], + string "}", + newline, + newline, + string "memset(in, 0, sizeof in);", newline, p_list_sepi (box []) (fn i => fn t => @@ -1129,6 +1159,36 @@ newline, newline, + string "if (stmt == NULL) {", + newline, + box [string "stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");", + newline, + string "if (mysql_stmt_prepare(stmt, \"", + string (String.toString dml), + string "\", ", + string (Int.toString (size dml)), + string ")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_stmt_error(stmt), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);", + newline], + string "}", + newline, + string "conn->p", + string (Int.toString id), + string " = stmt;", + newline], + string "}", + newline, + newline, + string "memset(in, 0, sizeof in);", newline, p_list_sepi (box []) (fn i => fn t => @@ -1280,8 +1340,35 @@ string (String.toString dml), string "\""]}] -fun nextval _ = box [] -fun nextvalPrepared _ = box [] +fun nextval {loc, seqE, seqName} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "char *insert = ", + case seqName of + SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES ()\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ", + seqE, + string ", \" VALUES ()\"))"], + string ";", + newline, + string "char *delete = ", + case seqName of + SOME s => string ("\"DELETE FROM " ^ s ^ "\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ", + seqE, + string ")"], + string ";", + newline, + newline, + + string "if (mysql_query(conn->conn, insert)) uw_error(ctx, FATAL, \"'nextval' INSERT failed\");", + newline, + string "n = mysql_insert_id(conn->conn);", + newline, + string "if (mysql_query(conn->conn, delete)) uw_error(ctx, FATAL, \"'nextval' DELETE failed\");", + newline] + +fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called" fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" @@ -1314,6 +1401,7 @@ p_blank = p_blank, supportsDeleteAs = false, createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTO_INCREMENT)", - textKeysNeedLengths = true} + textKeysNeedLengths = true, + supportsNextval = false} end
--- a/src/postgres.sml Thu Jul 16 13:59:30 2009 -0400 +++ b/src/postgres.sml Thu Jul 16 16:29:13 2009 -0400 @@ -805,13 +805,28 @@ string "PQclear(res);", newline] -fun nextval loc = - box [string "PGconn *conn = uw_get_db(ctx);", - newline, - string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", - newline, - newline, - nextvalCommon {loc = loc, query = string "query"}] +open Cjr + +fun nextval {loc, seqE, seqName} = + let + val query = case seqName of + SOME s => + string ("SELECT NEXTVAL('" ^ s ^ "')") + | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ", + seqE, + string ", \"')\"))"] + in + box [string "char *query = ", + query, + string ";", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + nextvalCommon {loc = loc, query = string "query"}] + end fun nextvalPrepared {loc, id, query} = box [string "PGconn *conn = uw_get_db(ctx);", @@ -862,7 +877,8 @@ p_blank = p_blank, supportsDeleteAs = true, createSequence = fn s => "CREATE SEQUENCE " ^ s, - textKeysNeedLengths = false} + textKeysNeedLengths = false, + supportsNextval = true} val () = setDbms "postgres"
--- a/src/prepare.sml Thu Jul 16 13:59:30 2009 -0400 +++ b/src/prepare.sml Thu Jul 16 16:29:13 2009 -0400 @@ -216,27 +216,30 @@ end) | ENextval {seq, ...} => - let - val s = case seq of - (EPrim (Prim.String s), loc) => - (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) - | _ => - let - val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - in - (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) - end - in - case prepString (s, [], 0) of - NONE => (e, sns) - | SOME (ss, n) => - let - val s = String.concat (rev ss) - in - ((ENextval {seq = seq, prepared = SOME (#2 sns, s)}, loc), - ((s, n) :: #1 sns, #2 sns + 1)) - end - end + if #supportsNextval (Settings.currentDbms ()) then + let + val s = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) + end + in + case prepString (s, [], 0) of + NONE => (e, sns) + | SOME (ss, n) => + let + val s = String.concat (rev ss) + in + ((ENextval {seq = seq, prepared = SOME (#2 sns, s)}, loc), + ((s, n) :: #1 sns, #2 sns + 1)) + end + end + else + (e, sns) | EUnurlify (e, t) => let
--- a/src/settings.sig Thu Jul 16 13:59:30 2009 -0400 +++ b/src/settings.sig Thu Jul 16 16:29:13 2009 -0400 @@ -142,14 +142,15 @@ dml : ErrorMsg.span -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, inputs : sql_type list} -> Print.PD.pp_desc, - nextval : ErrorMsg.span -> Print.PD.pp_desc, + nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> 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, createSequence : string -> string, - textKeysNeedLengths : bool + textKeysNeedLengths : bool, + supportsNextval : bool } val addDbms : dbms -> unit
--- a/src/settings.sml Thu Jul 16 13:59:30 2009 -0400 +++ b/src/settings.sml Thu Jul 16 16:29:13 2009 -0400 @@ -332,14 +332,15 @@ dml : ErrorMsg.span -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, inputs : sql_type list} -> Print.PD.pp_desc, - nextval : ErrorMsg.span -> Print.PD.pp_desc, + nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> 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, createSequence : string -> string, - textKeysNeedLengths : bool + textKeysNeedLengths : bool, + supportsNextval : bool } val dbmses = ref ([] : dbms list) @@ -359,7 +360,8 @@ p_blank = fn _ => "", supportsDeleteAs = false, createSequence = fn _ => "", - textKeysNeedLengths = false} : dbms) + textKeysNeedLengths = false, + supportsNextval = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s =