Ur/Web: src/cjr_print.sml comparison

comparison src/cjr_print.sml @ 1979:81bc76aa4acd

Merge in upstream changes.

author	Patrick Hurst <phurst@mit.edu>
date	Sat, 18 Jan 2014 18:26:24 -0500
parents	ac1be85e91ad
children	ced78ef1c82f 01c8aceac480

comparison

equal deleted inserted replaced

-:c5143edaf3c7
+:81bc76aa4acd
 string ");",
 newline,
 string "tmp;",
 newline,
 string "})"]
-| EReturnBlob {blob, mimeType, t} =>
+| EReturnBlob {blob = SOME blob, mimeType, t} =>
 box [string "({",
 newline,
 string "uw_Basis_blob",
 space,
 string "blob",
 p_typ env t,
 space,
 string "tmp;",
 newline,
 string "uw_return_blob(ctx, blob, mimeType);",
+newline,
+string "tmp;",
+newline,
+string "})"]
+| EReturnBlob {blob = NONE, mimeType, t} =>
+box [string "({",
+newline,
+string "uw_Basis_string",
+space,
+string "mimeType",
+space,
+string "=",
+space,
+p_exp' false false env mimeType,
+string ";",
+newline,
+p_typ env t,
+space,
+string "tmp;",
+newline,
+string "uw_return_blob_from_page(ctx, mimeType);",
 newline,
 string "tmp;",
 newline,
 string "})"]
 | ERedirect (e, t) =>
 p_exp' false false env initial,
 string ";",
 newline,
 string "int dummy = (uw_begin_region(ctx), 0);",
 newline,
+string "uw_ensure_transaction(ctx);",
+newline,
 case prepared of
 NONE =>
 box [string "char *query = ",
 p_exp' false false env query,
 newline,
 case prepared of
 NONE => box [string "char *dml = ",
 p_exp' false false env dml,
 string ";",
+newline,
+string "uw_ensure_transaction(ctx);",
 newline,
 newline,
 #dml (Settings.currentDbms ()) (loc, mode)]
 | SOME {id, dml = dml'} =>
 let
 space,
 p_exp' false false env e,
 string ";"])
 inputs,
 newline,
+string "uw_ensure_transaction(ctx);",
 newline,
+newline,
 #dmlPrepared (Settings.currentDbms ()) {loc = loc,
 id = id,
 dml = dml',
 inputs = map #2 inputs,
 mode = mode}]
 | ENextval {seq, prepared} =>
 box [string "({",
 newline,
 string "uw_Basis_int n;",
+newline,
+string "uw_ensure_transaction(ctx);",
 newline,
 case prepared of
 NONE => #nextval (Settings.currentDbms ()) {loc = loc,
 seqE = p_exp' false false env seq,
 newline,
 string "})"]
 | ESetval {seq, count} =>
 box [string "({",
+newline,
+string "uw_ensure_transaction(ctx);",
 newline,
 #setval (Settings.currentDbms ()) {loc = loc,
 seqE = p_exp' false false env seq,
 count = p_exp' false false env count},
 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record")
 | _ => (List.take (ts, length ts - 1), string "", string "", NONE)
 fun couldWrite ek =
 case ek of
-Link => false
+Link _ => false
 | Action ef => ef = ReadCookieWrite
 | Rpc ef => ef = ReadCookieWrite
 | Extern _ => false
+fun couldWriteDb ek =
+case ek of
+Link ef => ef <> ReadOnly
+| Action ef => ef <> ReadOnly
+| Rpc ef => ef <> ReadOnly
+| Extern ef => ef <> ReadOnly
 val s =
 case Settings.getUrlPrefix () of
 "" => s
 | "/" => s
 box (case ek of
 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
 newline]
 | _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");",
 newline,
-string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
+case side of
-newline,
+ServerOnly => box []
-string "uw_write(ctx, begin_xhtml);",
+| _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
+newline],
+string ("uw_write(ctx, uw_begin_" ^
+(if Settings.getIsHtml5 () then
+"html5"
+else
+"xhtml") ^ ");"),
 newline,
 string "uw_mayReturnIndirectly(ctx);",
 newline,
 string "uw_set_script_header(ctx, \"",
 let
 in
 string scripts
 end,
 string "\");",
 newline]),
+string "uw_set_could_write_db(ctx, ",
+string (if couldWriteDb ek then "1" else "0"),
+string ");",
+newline,
 string "uw_set_needs_push(ctx, ",
 string (case side of
 ServerAndPullAndPush => "1"
 | _ => "0"),
 string ");",
 | EBinop (_, e1, e2) => expDb e1 orelse expDb e2
 | ERecord (_, xes) => List.exists (expDb o #2) xes
 | EField (e, _) => expDb e
 | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
 | EError (e, _) => expDb e
-| EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
+| EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2
+| EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
 | ERedirect (e, _) => expDb e
 | EWrite e => expDb e
 | ESeq (e1, e2) => expDb e1 orelse expDb e2
 | ELet (_, _, e1, e2) => expDb e1 orelse expDb e2
 | EQuery _ => true
 else
 box [string "static void uw_client_init(void) { };",
 newline,
 string "static void uw_db_init(uw_context ctx) { };",
 newline,
-string "static int uw_db_begin(uw_context ctx) { return 0; };",
+string "static int uw_db_begin(uw_context ctx, int could_write) { return 0; };",
 newline,
 string "static void uw_db_close(uw_context ctx) { };",
 newline,
 string "static int uw_db_commit(uw_context ctx) { return 0; };",
 newline,
 string "static int uw_db_rollback(uw_context ctx) { return 0; };"],
 newline,
 newline,
-string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
-newline,
-newline,
 p_list_sep newline (fn x => x) pds,
 newline,
 newline,
 string "static int uw_input_num(const char *name) {",
 "uw_client_init", "uw_initializer", "uw_expunger",
 "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close",
 "uw_handle",
 "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar",
 case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
-"\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\""],
+"\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"",
+if Settings.getIsHtml5 () then "1" else "0"],
 string "};",
 newline]
 end
 fun p_sql env (ds, _) =

Mercurial > urweb

comparison src/cjr_print.sml @ 1979:81bc76aa4acd