From 861f4c0a3619812bb56f2f6b5dd5cb3a13b05bd4 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 26 Apr 2009 10:53:36 -0400
Subject: Handling nullable blobs

---
 src/cjr_print.sml | 22 ++++++++++++----------
 tests/blobOpt.ur  | 38 ++++++++++++++++++++++++++++++++++++++
 tests/blobOpt.urp |  5 +++++
 tests/blobOpt.urs |  1 +
 4 files changed, 56 insertions(+), 10 deletions(-)
 create mode 100644 tests/blobOpt.ur
 create mode 100644 tests/blobOpt.urp
 create mode 100644 tests/blobOpt.urs

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 1447d9e5..8ce4433f 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -392,7 +392,7 @@ fun patConInfo env pc =
          "uw_" ^ ident m ^ "_" ^ ident con,
          "uw_" ^ ident con)
 
-fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
+fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen =
     case t of
         TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
@@ -403,6 +403,11 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
             box [string "uw_strdup(ctx, ", e, string ")"]
       | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
+      | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ",
+                                       e,
+                                       string ", ",
+                                       eLen,
+                                       string ")"]
       | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
 
@@ -434,18 +439,14 @@ fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
                            newline,
                            string "})"],
              string ")"]
-
-      | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, PQgetvalue(res, i, ",
-                                       string (Int.toString i),
-                                       string "), PQgetlength(res, i, ",
-                                       string (Int.toString i),
-                                       string "))"]
-             
       | _ =>
         p_unsql wontLeakStrings env tAll
                 (box [string "PQgetvalue(res, i, ",
                       string (Int.toString i),
                       string ")"])
+                (box [string "PQgetlength(res, i, ",
+                      string (Int.toString i),
+                      string ")"])
 
 datatype sql_type =
          Int
@@ -526,7 +527,7 @@ fun p_ensql t e =
       | Nullable t => box [string "(",
                            e,
                            string " == NULL ? NULL : ",
-                           p_ensql t (box [string "*", e]),
+                           p_ensql t (box [string "(*", e, string ")"]),
                            string ")"]
 
 fun notLeaky env allowHeapAllocated =
@@ -1821,7 +1822,8 @@ fun p_exp' par env (e, loc) =
 
                  string "n = ",
                  p_unsql true env (TFfi ("Basis", "int"), loc)
-                         (string "PQgetvalue(res, 0, 0)"),
+                         (string "PQgetvalue(res, 0, 0)")
+                         (box []),
                  string ";",
                  newline,
                  string "PQclear(res);",
diff --git a/tests/blobOpt.ur b/tests/blobOpt.ur
new file mode 100644
index 00000000..261ce226
--- /dev/null
+++ b/tests/blobOpt.ur
@@ -0,0 +1,38 @@
+sequence s
+table t : { Id : int, Data : option blob, Typ : string }
+
+fun view id =
+    r <- oneRow (SELECT t.Data, t.Typ FROM t WHERE t.Id = {[id]});
+    case r.T.Data of
+        None => return <xml>This one's empty.</xml>
+      | Some data => returnBlob data (blessMime r.T.Typ)
+
+fun save r =
+    id <- nextval s;
+    dml (INSERT INTO t (Id, Data, Typ)
+         VALUES ({[id]}, {[Some (fileData r.Data)]}, {[fileMimeType r.Data]}));
+    main ()
+
+and saveEmpty () =
+    id <- nextval s;
+    dml (INSERT INTO t (Id, Data, Typ)
+         VALUES ({[id]}, {[None]}, "bogus"));
+    main ()
+
+and main () =
+    ls <- queryX (SELECT t.Id FROM t)
+          (fn r => <xml><li><a link={view r.T.Id}>{[r.T.Id]}</a></li></xml>);
+    return <xml><body>
+      {ls}
+
+      <br/>
+
+      <form>
+        <upload{#Data}/>
+        <submit action={save}/>
+      </form>
+
+      <form>
+        <submit action={saveEmpty}/>
+      </form>
+    </body></xml>
diff --git a/tests/blobOpt.urp b/tests/blobOpt.urp
new file mode 100644
index 00000000..fef3c5d2
--- /dev/null
+++ b/tests/blobOpt.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=blobopt
+sql blobOpt.sql
+
+blobOpt
diff --git a/tests/blobOpt.urs b/tests/blobOpt.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/blobOpt.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3