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 =