Mercurial > urweb

comparison src/cjr_print.sml @ 866:03e7f111fe99

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of multi-DBMS support
author Adam Chlipala <adamc@hcoop.net>
date Sun, 28 Jun 2009 13:49:32 -0400
parents 305bc0a431de
children e7f80d78075b
comparison
equal deleted inserted replaced
865:ebefb0609ac3 866:03e7f111fe99
2037 string ");"], 2037 string ");"],
2038 newline, 2038 newline,
2039 string "}"] 2039 string "}"]
2040 end 2040 end
2041 2041
2042 val prepped = ref ([] : (string * int) list)
2043
2042 fun p_decl env (dAll as (d, _) : decl) = 2044 fun p_decl env (dAll as (d, _) : decl) =
2043 case d of 2045 case d of
2044 DStruct (n, xts) => 2046 DStruct (n, xts) =>
2045 let 2047 let
2046 val env = E.declBinds env dAll 2048 val env = E.declBinds env dAll
2194 box [string "static void uw_db_validate(uw_context);", 2196 box [string "static void uw_db_validate(uw_context);",
2195 newline, 2197 newline,
2196 string "static void uw_db_prepare(uw_context);", 2198 string "static void uw_db_prepare(uw_context);",
2197 newline, 2199 newline,
2198 newline, 2200 newline,
2199 string "void uw_db_init(uw_context ctx) {", 2201
2200 newline, 2202 #init (Settings.currentDbms ()) (name, !prepped),
2201 string "PGconn *conn = PQconnectdb(\"",
2202 string (String.toString name),
2203 string "\");",
2204 newline,
2205 string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ",
2206 string "\"libpq can't allocate a connection.\");",
2207 newline,
2208 string "if (PQstatus(conn) != CONNECTION_OK) {",
2209 newline,
2210 box [string "char msg[1024];",
2211 newline,
2212 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2213 newline,
2214 string "msg[1023] = 0;",
2215 newline,
2216 string "PQfinish(conn);",
2217 newline,
2218 string "uw_error(ctx, BOUNDED_RETRY, ",
2219 string "\"Connection to Postgres server failed: %s\", msg);"],
2220 newline,
2221 string "}",
2222 newline,
2223 string "uw_set_db(ctx, conn);",
2224 newline,
2225 string "uw_db_validate(ctx);",
2226 newline,
2227 string "uw_db_prepare(ctx);",
2228 newline,
2229 string "}",
2230 newline,
2231 newline,
2232 string "void uw_db_close(uw_context ctx) {",
2233 newline,
2234 string "PQfinish(uw_get_db(ctx));",
2235 newline,
2236 string "}",
2237 newline,
2238 newline,
2239
2240 string "int uw_db_begin(uw_context ctx) {",
2241 newline,
2242 string "PGconn *conn = uw_get_db(ctx);",
2243 newline,
2244 string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
2245 newline,
2246 newline,
2247 string "if (res == NULL) return 1;",
2248 newline,
2249 newline,
2250 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
2251 box [string "PQclear(res);",
2252 newline,
2253 string "return 1;",
2254 newline],
2255 string "}",
2256 newline,
2257 string "return 0;",
2258 newline,
2259 string "}",
2260 newline,
2261 newline,
2262
2263 string "int uw_db_commit(uw_context ctx) {",
2264 newline,
2265 string "PGconn *conn = uw_get_db(ctx);",
2266 newline,
2267 string "PGresult *res = PQexec(conn, \"COMMIT\");",
2268 newline,
2269 newline,
2270 string "if (res == NULL) return 1;",
2271 newline,
2272 newline,
2273 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
2274 box [string "PQclear(res);",
2275 newline,
2276 string "return 1;",
2277 newline],
2278 string "}",
2279 newline,
2280 string "return 0;",
2281 newline,
2282 string "}",
2283 newline,
2284 newline,
2285
2286 string "int uw_db_rollback(uw_context ctx) {",
2287 newline,
2288 string "PGconn *conn = uw_get_db(ctx);",
2289 newline,
2290 string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
2291 newline,
2292 newline,
2293 string "if (res == NULL) return 1;",
2294 newline,
2295 newline,
2296 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
2297 box [string "PQclear(res);",
2298 newline,
2299 string "return 1;",
2300 newline],
2301 string "}",
2302 newline,
2303 string "return 0;",
2304 newline,
2305 string "}",
2306 newline,
2307 newline,
2308 2203
2309 string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {", 2204 string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
2310 newline, 2205 newline,
2311 box [p_enamed env expunge, 2206 box [p_enamed env expunge,
2312 string "(ctx, cli);", 2207 string "(ctx, cli);",
2321 string "(ctx, uw_unit_v);", 2216 string "(ctx, uw_unit_v);",
2322 newline], 2217 newline],
2323 string "}", 2218 string "}",
2324 newline] 2219 newline]
2325 2220
2326 | DPreparedStatements [] =>
2327 box [string "static void uw_db_prepare(uw_context ctx) {",
2328 newline,
2329 string "}"]
2330 | DPreparedStatements ss => 2221 | DPreparedStatements ss =>
2331 if #persistent (Settings.currentProtocol ()) then 2222 (prepped := ss;
2332 box [string "static void uw_db_prepare(uw_context ctx) {", 2223 box [])
2333 newline,
2334 string "PGconn *conn = uw_get_db(ctx);",
2335 newline,
2336 string "PGresult *res;",
2337 newline,
2338 newline,
2339
2340 p_list_sepi newline (fn i => fn (s, n) =>
2341 box [string "res = PQprepare(conn, \"uw",
2342 string (Int.toString i),
2343 string "\", \"",
2344 string (String.toString s),
2345 string "\", ",
2346 string (Int.toString n),
2347 string ", NULL);",
2348 newline,
2349 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
2350 newline,
2351 box [string "char msg[1024];",
2352 newline,
2353 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2354 newline,
2355 string "msg[1023] = 0;",
2356 newline,
2357 string "PQclear(res);",
2358 newline,
2359 string "PQfinish(conn);",
2360 newline,
2361 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
2362 string (String.toString s),
2363 string "\\n%s\", msg);",
2364 newline],
2365 string "}",
2366 newline,
2367 string "PQclear(res);",
2368 newline])
2369 ss,
2370
2371 string "}"]
2372 else
2373 string "static void uw_db_prepare(uw_context ctx) { }"
2374 2224
2375 | DJavaScript s => box [string "static char jslib[] = \"", 2225 | DJavaScript s => box [string "static char jslib[] = \"",
2376 string (String.toString s), 2226 string (String.toString s),
2377 string "\";"] 2227 string "\";"]
2378 | DCookie s => box [string "/*", 2228 | DCookie s => box [string "/*",
3266 string "#include <string.h>", 3116 string "#include <string.h>",
3267 newline, 3117 newline,
3268 string "#include <math.h>", 3118 string "#include <math.h>",
3269 newline, 3119 newline,
3270 if hasDb then 3120 if hasDb then
3271 box [string "#include <postgresql/libpq-fe.h>", 3121 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
3272 newline] 3122 newline]
3273 else 3123 else
3274 box [], 3124 box [],
3275 newline, 3125 newline,
3276 p_list_sep (box []) (fn s => box [string "#include \"", 3126 p_list_sep (box []) (fn s => box [string "#include \"",