Mercurial > urweb

annotate src/postgres.sml @ 2134:752e5efe9da9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use hyperref in manual This allows the table of contents to show up properly in PDF readers.
author Julian Squires <julian@cipht.net>
date Fri, 24 Apr 2015 07:43:22 -0400
parents 661b531f55bd
children d2a98983f502
rev   line source
adam@1295 1 (* Copyright (c) 2008-2010, Adam Chlipala
adamc@866 2 * All rights reserved.
adamc@866 3 *
adamc@866 4 * Redistribution and use in source and binary forms, with or without
adamc@866 5 * modification, are permitted provided that the following conditions are met:
adamc@866 6 *
adamc@866 7 * - Redistributions of source code must retain the above copyright notice,
adamc@866 8 * this list of conditions and the following disclaimer.
adamc@866 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@866 10 * this list of conditions and the following disclaimer in the documentation
adamc@866 11 * and/or other materials provided with the distribution.
adamc@866 12 * - The names of contributors may not be used to endorse or promote products
adamc@866 13 * derived from this software without specific prior written permission.
adamc@866 14 *
adamc@866 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@866 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@866 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@866 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adam@1682 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@866 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@866 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@866 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@866 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@866 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@866 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@866 26 *)
adamc@866 27
adamc@866 28 structure Postgres :> POSTGRES = struct
adamc@866 29
adamc@866 30 open Settings
adamc@866 31 open Print.PD
adamc@866 32 open Print
adamc@866 33
adamc@870 34 val ident = String.translate (fn #"'" => "PRIME"
adamc@870 35 | ch => str ch)
adamc@870 36
adamc@873 37 fun p_sql_type t =
adamc@873 38 case t of
adamc@873 39 Int => "int8"
adamc@873 40 | Float => "float8"
adamc@873 41 | String => "text"
adamc@1011 42 | Char => "char"
adamc@873 43 | Bool => "bool"
adamc@873 44 | Time => "timestamp"
adamc@873 45 | Blob => "bytea"
adamc@873 46 | Channel => "int8"
adamc@873 47 | Client => "int4"
adamc@873 48 | Nullable t => p_sql_type t
adamc@873 49
adamc@870 50 fun p_sql_type_base t =
adamc@870 51 case t of
adamc@871 52 Int => "bigint"
adamc@871 53 | Float => "double precision"
adamc@870 54 | String => "text"
adamc@1011 55 | Char => "character"
adamc@871 56 | Bool => "boolean"
adamc@871 57 | Time => "timestamp without time zone"
adamc@870 58 | Blob => "bytea"
adamc@871 59 | Channel => "bigint"
adamc@871 60 | Client => "integer"
adamc@870 61 | Nullable t => p_sql_type_base t
adamc@870 62
adamc@872 63 fun checkRel (table, checkNullable) (s, xts) =
adamc@871 64 let
adamc@871 65 val sl = CharVector.map Char.toLower s
adam@1953 66 val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
adam@1953 67 String.substring (sl, 1, size sl - 2)
adam@1953 68 else
adam@1953 69 sl
adamc@871 70
adam@1958 71 val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
adamc@871 72 ^ sl ^ "'"
adamc@871 73
adamc@871 74 val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
adamc@871 75 sl,
adamc@871 76 "' AND (",
adam@1600 77 case String.concatWith " OR "
adam@1600 78 (map (fn (x, t) =>
adam@1953 79 String.concat ["(LOWER(column_name) = '",
adam@1953 80 Settings.mangleSqlCatalog
adam@1953 81 (CharVector.map
adam@1953 82 Char.toLower (ident x)),
adam@1600 83 (case p_sql_type_base t of
adam@1600 84 "bigint" =>
adam@1953 85 "' AND data_type IN ('bigint', 'numeric', 'integer')"
adam@1953 86 | "text" =>
adam@1953 87 "' AND data_type IN ('text', 'character varying')"
adam@1600 88 | t =>
adam@1600 89 String.concat ["' AND data_type = '",
adam@1600 90 t,
adam@1600 91 "'"]),
adam@1600 92 if checkNullable then
adam@1600 93 (" AND is_nullable = '"
adam@1600 94 ^ (if isNotNull t then
adam@1600 95 "NO"
adam@1600 96 else
adam@1600 97 "YES")
adam@1600 98 ^ "'")
adam@1600 99 else
adam@1600 100 "",
adam@1600 101 ")"]) xts) of
adam@1600 102 "" => "FALSE"
adam@1600 103 | s => s,
adamc@871 104 ")"]
adamc@871 105
adamc@871 106 val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
adamc@871 107 sl,
adam@1953 108 "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
adamc@871 109 in
adamc@871 110 box [string "res = PQexec(conn, \"",
adamc@871 111 string q,
adamc@871 112 string "\");",
adamc@871 113 newline,
adamc@871 114 newline,
adamc@871 115 string "if (res == NULL) {",
adamc@871 116 newline,
adamc@871 117 box [string "PQfinish(conn);",
adamc@871 118 newline,
adamc@871 119 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@871 120 newline],
adamc@871 121 string "}",
adamc@871 122 newline,
adamc@871 123 newline,
adamc@871 124 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@871 125 newline,
adamc@871 126 box [string "char msg[1024];",
adamc@871 127 newline,
adamc@871 128 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@871 129 newline,
adamc@871 130 string "msg[1023] = 0;",
adamc@871 131 newline,
adamc@871 132 string "PQclear(res);",
adamc@871 133 newline,
adamc@871 134 string "PQfinish(conn);",
adamc@871 135 newline,
adamc@871 136 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@871 137 string q,
adamc@871 138 string "\\n%s\", msg);",
adamc@871 139 newline],
adamc@871 140 string "}",
adamc@871 141 newline,
adamc@871 142 newline,
adamc@871 143 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@871 144 newline,
adamc@871 145 box [string "PQclear(res);",
adamc@871 146 newline,
adamc@871 147 string "PQfinish(conn);",
adamc@871 148 newline,
adamc@871 149 string "uw_error(ctx, FATAL, \"Table '",
adam@1953 150 string sl,
adamc@871 151 string "' does not exist.\");",
adamc@871 152 newline],
adamc@871 153 string "}",
adamc@871 154 newline,
adamc@871 155 newline,
adamc@871 156 string "PQclear(res);",
adamc@871 157 newline,
adamc@871 158
adamc@871 159 string "res = PQexec(conn, \"",
adamc@871 160 string q',
adamc@871 161 string "\");",
adamc@871 162 newline,
adamc@871 163 newline,
adamc@871 164 string "if (res == NULL) {",
adamc@871 165 newline,
adamc@871 166 box [string "PQfinish(conn);",
adamc@871 167 newline,
adamc@871 168 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@871 169 newline],
adamc@871 170 string "}",
adamc@871 171 newline,
adamc@871 172 newline,
adamc@871 173 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@871 174 newline,
adamc@871 175 box [string "char msg[1024];",
adamc@871 176 newline,
adamc@871 177 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@871 178 newline,
adamc@871 179 string "msg[1023] = 0;",
adamc@871 180 newline,
adamc@871 181 string "PQclear(res);",
adamc@871 182 newline,
adamc@871 183 string "PQfinish(conn);",
adamc@871 184 newline,
adamc@871 185 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@871 186 string q',
adamc@871 187 string "\\n%s\", msg);",
adamc@871 188 newline],
adamc@871 189 string "}",
adamc@871 190 newline,
adamc@871 191 newline,
adamc@871 192 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@871 193 string (Int.toString (length xts)),
adamc@871 194 string "\")) {",
adamc@871 195 newline,
adamc@871 196 box [string "PQclear(res);",
adamc@871 197 newline,
adamc@871 198 string "PQfinish(conn);",
adamc@871 199 newline,
adamc@871 200 string "uw_error(ctx, FATAL, \"Table '",
adam@1953 201 string sl,
adamc@871 202 string "' has the wrong column types.\");",
adamc@871 203 newline],
adamc@871 204 string "}",
adamc@871 205 newline,
adamc@871 206 newline,
adamc@871 207 string "PQclear(res);",
adamc@871 208 newline,
adamc@871 209 newline,
adamc@871 210
adamc@871 211 string "res = PQexec(conn, \"",
adamc@871 212 string q'',
adamc@871 213 string "\");",
adamc@871 214 newline,
adamc@871 215 newline,
adamc@871 216 string "if (res == NULL) {",
adamc@871 217 newline,
adamc@871 218 box [string "PQfinish(conn);",
adamc@871 219 newline,
adamc@871 220 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@871 221 newline],
adamc@871 222 string "}",
adamc@871 223 newline,
adamc@871 224 newline,
adamc@871 225 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@871 226 newline,
adamc@871 227 box [string "char msg[1024];",
adamc@871 228 newline,
adamc@871 229 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@871 230 newline,
adamc@871 231 string "msg[1023] = 0;",
adamc@871 232 newline,
adamc@871 233 string "PQclear(res);",
adamc@871 234 newline,
adamc@871 235 string "PQfinish(conn);",
adamc@871 236 newline,
adamc@871 237 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@871 238 string q'',
adamc@871 239 string "\\n%s\", msg);",
adamc@871 240 newline],
adamc@871 241 string "}",
adamc@871 242 newline,
adamc@871 243 newline,
adamc@871 244 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@871 245 string (Int.toString (length xts)),
adamc@871 246 string "\")) {",
adamc@871 247 newline,
adamc@871 248 box [string "PQclear(res);",
adamc@871 249 newline,
adamc@871 250 string "PQfinish(conn);",
adamc@871 251 newline,
adamc@871 252 string "uw_error(ctx, FATAL, \"Table '",
adam@1953 253 string sl,
adamc@871 254 string "' has extra columns.\");",
adamc@871 255 newline],
adamc@871 256 string "}",
adamc@871 257 newline,
adamc@871 258 newline,
adamc@871 259 string "PQclear(res);",
adamc@871 260 newline]
adamc@871 261 end
adamc@871 262
adamc@872 263 fun init {dbstring, prepared = ss, tables, views, sequences} =
adamc@866 264 box [if #persistent (currentProtocol ()) then
adamc@1094 265 box [string "static void uw_db_validate(uw_context ctx) {",
adamc@870 266 newline,
adamc@870 267 string "PGconn *conn = uw_get_db(ctx);",
adamc@870 268 newline,
adamc@870 269 string "PGresult *res;",
adamc@870 270 newline,
adamc@870 271 newline,
adamc@872 272 p_list_sep newline (checkRel ("tables", true)) tables,
adamc@872 273 p_list_sep newline (checkRel ("views", false)) views,
adamc@870 274
adamc@870 275 p_list_sep newline
adamc@870 276 (fn s =>
adamc@870 277 let
adamc@870 278 val sl = CharVector.map Char.toLower s
adamc@870 279
adamc@870 280 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
adamc@870 281 ^ sl ^ "' AND relkind = 'S'"
adamc@870 282 in
adamc@870 283 box [string "res = PQexec(conn, \"",
adamc@870 284 string q,
adamc@870 285 string "\");",
adamc@870 286 newline,
adamc@870 287 newline,
adamc@870 288 string "if (res == NULL) {",
adamc@870 289 newline,
adamc@870 290 box [string "PQfinish(conn);",
adamc@870 291 newline,
adamc@870 292 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@870 293 newline],
adamc@870 294 string "}",
adamc@870 295 newline,
adamc@870 296 newline,
adamc@870 297 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@870 298 newline,
adamc@870 299 box [string "char msg[1024];",
adamc@870 300 newline,
adamc@870 301 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@870 302 newline,
adamc@870 303 string "msg[1023] = 0;",
adamc@870 304 newline,
adamc@870 305 string "PQclear(res);",
adamc@870 306 newline,
adamc@870 307 string "PQfinish(conn);",
adamc@870 308 newline,
adamc@870 309 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@870 310 string q,
adamc@870 311 string "\\n%s\", msg);",
adamc@870 312 newline],
adamc@870 313 string "}",
adamc@870 314 newline,
adamc@870 315 newline,
adamc@870 316 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@870 317 newline,
adamc@870 318 box [string "PQclear(res);",
adamc@870 319 newline,
adamc@870 320 string "PQfinish(conn);",
adamc@870 321 newline,
adamc@870 322 string "uw_error(ctx, FATAL, \"Sequence '",
adamc@870 323 string s,
adamc@870 324 string "' does not exist.\");",
adamc@870 325 newline],
adamc@870 326 string "}",
adamc@870 327 newline,
adamc@870 328 newline,
adamc@870 329 string "PQclear(res);",
adamc@870 330 newline]
adamc@870 331 end) sequences,
adamc@870 332
adamc@870 333 string "}",
adamc@870 334
adamc@870 335 string "static void uw_db_prepare(uw_context ctx) {",
adamc@866 336 newline,
adamc@866 337 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 338 newline,
adamc@866 339 string "PGresult *res;",
adamc@866 340 newline,
adamc@866 341 newline,
adamc@866 342
adam@2103 343 p_list_sepi newline (fn i => fn (s, _) =>
adamc@866 344 box [string "res = PQprepare(conn, \"uw",
adamc@866 345 string (Int.toString i),
adamc@866 346 string "\", \"",
adam@1656 347 string (Prim.toCString s),
adam@2103 348 string "\", 0, NULL);",
adamc@866 349 newline,
adamc@866 350 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 351 newline,
adamc@866 352 box [string "char msg[1024];",
adamc@866 353 newline,
adamc@866 354 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 355 newline,
adamc@866 356 string "msg[1023] = 0;",
adamc@866 357 newline,
adamc@866 358 string "PQclear(res);",
adamc@866 359 newline,
adamc@866 360 string "PQfinish(conn);",
adamc@866 361 newline,
adamc@866 362 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
adam@1656 363 string (Prim.toCString s),
adamc@866 364 string "\\n%s\", msg);",
adamc@866 365 newline],
adamc@866 366 string "}",
adamc@866 367 newline,
adamc@866 368 string "PQclear(res);",
adamc@866 369 newline])
adamc@866 370 ss,
adamc@866 371
adamc@866 372 string "}",
adamc@866 373 newline,
adamc@866 374 newline]
adamc@866 375 else
adamc@870 376 box [string "static void uw_db_validate(uw_context ctx) { }",
adamc@870 377 newline,
adamc@870 378 string "static void uw_db_prepare(uw_context ctx) { }"],
adamc@870 379
adamc@1094 380 string "static void uw_client_init(void) {",
adamc@1094 381 newline,
adamc@1094 382 box [string "uw_sqlfmtInt = \"%lld::int8%n\";",
adamc@1094 383 newline,
adam@1920 384 string "uw_sqlfmtFloat = \"%.16g::float8%n\";",
adamc@1094 385 newline,
adamc@1094 386 string "uw_Estrings = 1;",
adamc@1094 387 newline,
adam@1834 388 string "uw_sql_type_annotations = 1;",
adam@1834 389 newline,
adamc@1094 390 string "uw_sqlsuffixString = \"::text\";",
adamc@1094 391 newline,
adamc@1094 392 string "uw_sqlsuffixChar = \"::char\";",
adamc@1094 393 newline,
adamc@1094 394 string "uw_sqlsuffixBlob = \"::bytea\";",
adamc@1094 395 newline,
adamc@1094 396 string "uw_sqlfmtUint4 = \"%u::int4%n\";",
adamc@1094 397 newline],
adamc@1094 398 string "}",
adamc@866 399 newline,
adamc@866 400 newline,
adamc@866 401
adamc@1094 402 string "static void uw_db_close(uw_context ctx) {",
adamc@1094 403 newline,
adamc@1094 404 string "PQfinish(uw_get_db(ctx));",
adamc@1094 405 newline,
adamc@1094 406 string "}",
adamc@1094 407 newline,
adamc@1094 408 newline,
adamc@1094 409
adam@1936 410 string "static int uw_db_begin(uw_context ctx, int could_write) {",
adamc@1094 411 newline,
adamc@1094 412 string "PGconn *conn = uw_get_db(ctx);",
adamc@1094 413 newline,
adam@1936 414 string "PGresult *res = PQexec(conn, could_write ? \"BEGIN ISOLATION LEVEL SERIALIZABLE\" : \"BEGIN ISOLATION LEVEL SERIALIZABLE, READ ONLY\");",
adamc@1094 415 newline,
adamc@1094 416 newline,
adamc@1094 417 string "if (res == NULL) return 1;",
adamc@1094 418 newline,
adamc@1094 419 newline,
adamc@1094 420 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@1094 421 box [string "PQclear(res);",
adamc@1094 422 newline,
adamc@1094 423 string "return 1;",
adamc@1094 424 newline],
adamc@1094 425 string "}",
adamc@1094 426 newline,
adamc@1144 427 string "PQclear(res);",
adamc@1144 428 newline,
adamc@1094 429 string "return 0;",
adamc@1094 430 newline,
adamc@1094 431 string "}",
adamc@1094 432 newline,
adamc@1094 433 newline,
adamc@1094 434
adamc@1094 435 string "static int uw_db_commit(uw_context ctx) {",
adamc@1094 436 newline,
adamc@1094 437 string "PGconn *conn = uw_get_db(ctx);",
adamc@1094 438 newline,
adamc@1094 439 string "PGresult *res = PQexec(conn, \"COMMIT\");",
adamc@1094 440 newline,
adamc@1094 441 newline,
adamc@1094 442 string "if (res == NULL) return 1;",
adamc@1094 443 newline,
adamc@1094 444 newline,
adamc@1094 445 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adam@1938 446 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
adam@1938 447 box [newline,
adam@1938 448 string "PQclear(res);",
adam@1938 449 newline,
adam@1938 450 string "return -1;",
adam@1938 451 newline],
adam@1938 452 string "}",
adam@1938 453 newline,
adam@1938 454 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
adam@1938 455 box [newline,
adam@1938 456 string "PQclear(res);",
adam@1938 457 newline,
adam@1938 458 string "return -1;",
adam@1938 459 newline],
adam@1938 460 string "}",
adam@1938 461 newline,
adam@1938 462 string "PQclear(res);",
adamc@1094 463 newline,
adamc@1094 464 string "return 1;",
adamc@1094 465 newline],
adamc@1094 466 string "}",
adamc@1094 467 newline,
adamc@1144 468 string "PQclear(res);",
adamc@1144 469 newline,
adamc@1094 470 string "return 0;",
adamc@1094 471 newline,
adamc@1094 472 string "}",
adamc@1094 473 newline,
adamc@1094 474 newline,
adamc@1094 475
adamc@1094 476 string "static int uw_db_rollback(uw_context ctx) {",
adamc@1094 477 newline,
adamc@1094 478 string "PGconn *conn = uw_get_db(ctx);",
adamc@1094 479 newline,
adamc@1094 480 string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
adamc@1094 481 newline,
adamc@1094 482 newline,
adamc@1094 483 string "if (res == NULL) return 1;",
adamc@1094 484 newline,
adamc@1094 485 newline,
adamc@1094 486 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@1094 487 box [string "PQclear(res);",
adamc@1094 488 newline,
adamc@1094 489 string "return 1;",
adamc@1094 490 newline],
adamc@1094 491 string "}",
adamc@1094 492 newline,
adamc@1144 493 string "PQclear(res);",
adamc@1144 494 newline,
adamc@1094 495 string "return 0;",
adamc@1094 496 newline,
adamc@1094 497 string "}",
adamc@1094 498
adamc@1094 499 newline,
adamc@1094 500 newline,
adamc@1094 501
adamc@1094 502 string "static void uw_db_init(uw_context ctx) {",
adamc@866 503 newline,
as@1564 504 string "char *env_db_str = getenv(\"URWEB_PQ_CON\");",
as@1564 505 newline,
as@1564 506 string "PGconn *conn = PQconnectdb(env_db_str == NULL ? \"",
adam@1656 507 string (Prim.toCString dbstring),
as@1564 508 string "\" : env_db_str);",
adamc@866 509 newline,
adamc@866 510 string "if (conn == NULL) uw_error(ctx, FATAL, ",
adamc@866 511 string "\"libpq can't allocate a connection.\");",
adamc@866 512 newline,
adamc@866 513 string "if (PQstatus(conn) != CONNECTION_OK) {",
adamc@866 514 newline,
adamc@866 515 box [string "char msg[1024];",
adamc@866 516 newline,
adamc@866 517 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 518 newline,
adamc@866 519 string "msg[1023] = 0;",
adamc@866 520 newline,
adamc@866 521 string "PQfinish(conn);",
adamc@866 522 newline,
adamc@866 523 string "uw_error(ctx, BOUNDED_RETRY, ",
adamc@866 524 string "\"Connection to Postgres server failed: %s\", msg);"],
adamc@866 525 newline,
adamc@866 526 string "}",
adamc@866 527 newline,
adamc@866 528 string "uw_set_db(ctx, conn);",
adamc@866 529 newline,
adamc@866 530 string "uw_db_validate(ctx);",
adamc@866 531 newline,
adamc@866 532 string "uw_db_prepare(ctx);",
adamc@866 533 newline,
adamc@866 534 string "}"]
adamc@866 535
adamc@880 536 fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
adamc@867 537 let
adamc@867 538 fun p_unsql t e eLen =
adamc@867 539 case t of
adamc@867 540 Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
adamc@867 541 | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
adamc@867 542 | String =>
adamc@867 543 if wontLeakStrings then
adamc@867 544 e
adamc@867 545 else
adamc@867 546 box [string "uw_strdup(ctx, ", e, string ")"]
adamc@1011 547 | Char => box [e, string "[0]"]
adamc@867 548 | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
adamc@939 549 | Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"]
adamc@867 550 | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ",
adamc@867 551 e,
adamc@867 552 string ", ",
adamc@867 553 eLen,
adamc@867 554 string ")"]
adamc@867 555 | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
adamc@867 556 | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
adamc@867 557
adamc@867 558 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@867 559
adamc@867 560 fun getter t =
adamc@867 561 case t of
adamc@867 562 Nullable t =>
adamc@867 563 box [string "(PQgetisnull(res, i, ",
adamc@867 564 string (Int.toString i),
adamc@867 565 string ") ? NULL : ",
adamc@867 566 case t of
adamc@867 567 String => getter t
adamc@867 568 | _ => box [string "({",
adamc@867 569 newline,
adamc@874 570 string (p_sql_ctype t),
adamc@867 571 space,
adamc@867 572 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@874 573 string (p_sql_ctype t),
adamc@867 574 string "));",
adamc@867 575 newline,
adamc@867 576 string "*tmp = ",
adamc@867 577 getter t,
adamc@867 578 string ";",
adamc@867 579 newline,
adamc@867 580 string "tmp;",
adamc@867 581 newline,
adamc@867 582 string "})"],
adamc@867 583 string ")"]
adamc@867 584 | _ =>
adamc@867 585 box [string "(PQgetisnull(res, i, ",
adamc@867 586 string (Int.toString i),
adamc@867 587 string ") ? ",
adamc@867 588 box [string "({",
adamc@874 589 string (p_sql_ctype t),
adamc@867 590 space,
adamc@867 591 string "tmp;",
adamc@867 592 newline,
adamc@880 593 string "uw_error(ctx, FATAL, \"",
adamc@880 594 string (ErrorMsg.spanToString loc),
adamc@880 595 string ": Unexpectedly NULL field #",
adamc@867 596 string (Int.toString i),
adamc@867 597 string "\");",
adamc@867 598 newline,
adamc@867 599 string "tmp;",
adamc@867 600 newline,
adamc@867 601 string "})"],
adamc@867 602 string " : ",
adamc@867 603 p_unsql t
adamc@867 604 (box [string "PQgetvalue(res, i, ",
adamc@867 605 string (Int.toString i),
adamc@867 606 string ")"])
adamc@867 607 (box [string "PQgetlength(res, i, ",
adamc@867 608 string (Int.toString i),
adamc@867 609 string ")"]),
adamc@867 610 string ")"]
adamc@867 611 in
adamc@867 612 getter t
adamc@867 613 end
adamc@867 614
adamc@873 615 fun queryCommon {loc, query, cols, doCols} =
adamc@867 616 box [string "int n, i;",
adamc@867 617 newline,
adamc@867 618 newline,
adamc@867 619
adamc@867 620 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@867 621 newline,
adamc@867 622 newline,
adamc@867 623
adamc@867 624 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@867 625 newline,
adam@1918 626 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
adam@1918 627 box [newline,
adam@1918 628 string "PQclear(res);",
adam@1918 629 newline,
adam@1918 630 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
adam@1918 631 newline],
adam@1918 632 string "}",
adam@1918 633 newline,
adam@1918 634 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
adam@1918 635 box [newline,
adam@1918 636 string "PQclear(res);",
adam@1918 637 newline,
adam@1918 638 string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
adam@1918 639 newline],
adam@1918 640 string "}",
adam@1918 641 newline,
adam@1918 642 string "PQclear(res);",
adamc@867 643 newline,
adamc@867 644 string "uw_error(ctx, FATAL, \"",
adamc@867 645 string (ErrorMsg.spanToString loc),
adamc@867 646 string ": Query failed:\\n%s\\n%s\", ",
adamc@867 647 query,
adamc@867 648 string ", PQerrorMessage(conn));",
adamc@867 649 newline],
adamc@867 650 string "}",
adamc@867 651 newline,
adamc@867 652 newline,
adamc@867 653
adamc@867 654 string "if (PQnfields(res) != ",
adamc@873 655 string (Int.toString (length cols)),
adamc@867 656 string ") {",
adamc@867 657 newline,
adamc@867 658 box [string "int nf = PQnfields(res);",
adamc@867 659 newline,
adamc@867 660 string "PQclear(res);",
adamc@867 661 newline,
adamc@867 662 string "uw_error(ctx, FATAL, \"",
adamc@867 663 string (ErrorMsg.spanToString loc),
adamc@867 664 string ": Query returned %d columns instead of ",
adamc@873 665 string (Int.toString (length cols)),
adamc@867 666 string ":\\n%s\\n%s\", nf, ",
adamc@867 667 query,
adamc@867 668 string ", PQerrorMessage(conn));",
adamc@867 669 newline],
adamc@867 670 string "}",
adamc@867 671 newline,
adamc@867 672 newline,
adamc@867 673
adamc@867 674 string "uw_end_region(ctx);",
adamc@867 675 newline,
adamc@867 676 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
adamc@867 677 newline,
adamc@867 678 string "n = PQntuples(res);",
adamc@867 679 newline,
adamc@867 680 string "for (i = 0; i < n; ++i) {",
adamc@867 681 newline,
adamc@867 682 doCols p_getcol,
adamc@867 683 string "}",
adamc@867 684 newline,
adamc@867 685 newline,
adamc@867 686 string "uw_pop_cleanup(ctx);",
adam@1682 687 newline]
adamc@867 688
adamc@873 689 fun query {loc, cols, doCols} =
adamc@867 690 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 691 newline,
adamc@867 692 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@867 693 newline,
adamc@867 694 newline,
adamc@873 695 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}]
adamc@867 696
adamc@867 697 fun p_ensql t e =
adamc@867 698 case t of
adamc@867 699 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
adamc@867 700 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
adamc@867 701 | String => e
adamc@1011 702 | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"]
adamc@867 703 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
adam@1364 704 | Time => box [string "uw_Basis_ensqlTime(ctx, ", e, string ")"]
adamc@867 705 | Blob => box [e, string ".data"]
adamc@867 706 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
adamc@867 707 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
adamc@867 708 | Nullable String => e
adamc@867 709 | Nullable t => box [string "(",
adamc@867 710 e,
adamc@867 711 string " == NULL ? NULL : ",
adamc@867 712 p_ensql t (box [string "(*", e, string ")"]),
adamc@867 713 string ")"]
adamc@867 714
adam@1431 715 fun makeParams inputs =
adam@1431 716 box [string "static const int paramFormats[] = { ",
adamc@867 717 p_list_sep (box [string ",", space])
adamc@867 718 (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@867 719 string " };",
adamc@867 720 newline,
adam@1431 721 if List.exists isBlob inputs then
adam@1650 722 box [string "int *paramLengths = uw_malloc(ctx, ",
adam@1431 723 string (Int.toString (length inputs)),
adam@1431 724 string " * sizeof(int));",
adam@1431 725 newline,
adam@1431 726 p_list_sepi (box [])
adam@1431 727 (fn i => fn t =>
adam@1431 728 box [string "paramLengths[",
adam@1431 729 string (Int.toString i),
adam@1431 730 string "] = ",
adam@1431 731 case t of
adam@1431 732 Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adam@1431 733 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adam@1431 734 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adam@1431 735 | _ => string "0",
adam@1431 736 string ";",
adam@1431 737 newline]) inputs,
adam@1431 738 newline]
adam@1431 739 else
adam@1431 740 box [string "const int *paramLengths = paramFormats;",
adam@1431 741 newline],
adam@1431 742
adam@1431 743 string "const char **paramValues = uw_malloc(ctx, ",
adam@1431 744 string (Int.toString (length inputs)),
adam@1431 745 string " * sizeof(char*));",
adamc@867 746 newline,
adam@1431 747 p_list_sepi (box [])
adam@1431 748 (fn i => fn t => box [string "paramValues[",
adam@1431 749 string (Int.toString i),
adam@1431 750 string "] = ",
adam@1431 751 p_ensql t (box [string "arg",
adam@1431 752 string (Int.toString (i + 1))]),
adam@1431 753 string ";",
adam@1431 754 newline])
adamc@867 755 inputs,
adam@1431 756 newline]
adam@1431 757
adam@1431 758 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} =
adam@1431 759 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 760 newline,
adam@1431 761
adam@1431 762 makeParams inputs,
adam@1431 763
adamc@867 764 newline,
adamc@867 765 string "PGresult *res = ",
adamc@867 766 if #persistent (Settings.currentProtocol ()) then
adamc@867 767 box [string "PQexecPrepared(conn, \"uw",
adamc@867 768 string (Int.toString id),
adamc@867 769 string "\", ",
adamc@867 770 string (Int.toString (length inputs)),
adamc@867 771 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@867 772 else
adamc@867 773 box [string "PQexecParams(conn, \"",
adam@1656 774 string (Prim.toCString query),
adamc@867 775 string "\", ",
adamc@867 776 string (Int.toString (length inputs)),
adamc@867 777 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@867 778 newline,
adamc@867 779 newline,
adamc@873 780 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
adam@1656 781 string (Prim.toCString query),
adamc@873 782 string "\""]}]
adamc@867 783
adam@1293 784 fun dmlCommon {loc, dml, mode} =
adamc@868 785 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adamc@868 786 newline,
adamc@868 787 newline,
adamc@868 788
adamc@868 789 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@868 790 newline,
adamc@868 791 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
adamc@868 792 box [newline,
adamc@868 793 string "PQclear(res);",
adamc@868 794 newline,
adamc@868 795 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
adamc@868 796 newline],
adamc@868 797 string "}",
adamc@868 798 newline,
adam@1550 799 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
adam@1550 800 box [newline,
adam@1550 801 string "PQclear(res);",
adam@1550 802 newline,
adam@1550 803 string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
adam@1550 804 newline],
adam@1550 805 string "}",
adam@1550 806 newline,
adam@1293 807 case mode of
adam@1918 808 Settings.Error => box [string "PQclear(res);",
adam@1293 809 newline,
adam@1293 810 string "uw_error(ctx, FATAL, \"",
adam@1293 811 string (ErrorMsg.spanToString loc),
adam@1918 812 string ": DML failed:\\n%s\\n%s\", ",
adam@1293 813 dml,
adam@1918 814 string ", PQerrorMessage(conn));"]
adam@1295 815 | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));",
adam@1295 816 newline,
adam@1295 817 newline,
adam@1295 818
adam@1295 819 string "res = PQexec(conn, \"ROLLBACK TO s\");",
adam@1295 820 newline,
adam@1295 821 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adam@1295 822 newline,
adam@1295 823 newline,
adam@1295 824
adam@1295 825 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adam@1295 826 newline,
adam@1295 827 box [string "PQclear(res);",
adam@1295 828 newline,
adam@1295 829 string "uw_error(ctx, FATAL, \"",
adam@1295 830 string (ErrorMsg.spanToString loc),
adam@1295 831 string ": ROLLBACK TO failed:\\n%s\\n%s\", ",
adam@1295 832 dml,
adam@1295 833 string ", PQerrorMessage(conn));",
adam@1295 834 newline,
adam@1295 835 string "}"],
adam@1295 836 newline,
adam@1295 837
adam@1295 838 string "PQclear(res);",
adam@1295 839 newline],
adamc@868 840 newline],
adamc@868 841 string "}",
adamc@868 842
adam@1295 843 case mode of
adam@1295 844 Error => box [newline,
adam@1295 845 newline,
adam@1295 846 string "PQclear(res);",
adam@1295 847 newline]
adam@1295 848 | None => box[string " else {",
adam@1295 849 newline,
adam@1295 850 box [string "PQclear(res);",
adam@1295 851 newline,
adam@1295 852 string "res = PQexec(conn, \"RELEASE s\");",
adam@1295 853 newline,
adam@1295 854 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adam@1295 855 newline,
adam@1295 856 newline,
adam@1295 857
adam@1295 858 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adam@1295 859 newline,
adam@1295 860 box [string "PQclear(res);",
adam@1295 861 newline,
adam@1295 862 string "uw_error(ctx, FATAL, \"",
adam@1295 863 string (ErrorMsg.spanToString loc),
adam@1295 864 string ": RELEASE failed:\\n%s\\n%s\", ",
adam@1295 865 dml,
adam@1295 866 string ", PQerrorMessage(conn));",
adam@1295 867 newline],
adam@1295 868 string "}",
adam@1295 869 newline,
adam@1295 870 string "PQclear(res);",
adam@1295 871 newline],
adam@1295 872 string "}",
adam@1295 873 newline]]
adam@1295 874
adam@1295 875 fun makeSavepoint mode =
adam@1295 876 case mode of
adam@1295 877 Error => box []
adam@1295 878 | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");",
adam@1295 879 newline,
adam@1295 880 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adam@1295 881 newline,
adam@1295 882 newline,
adam@1295 883 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adam@1295 884 box [newline,
adam@1295 885 string "PQclear(res);",
adam@1295 886 newline,
adam@1295 887 string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");",
adam@1295 888 newline],
adam@1295 889 string "}",
adam@1295 890 newline,
adam@1295 891 string "PQclear(res);",
adam@1295 892 newline,
adam@1295 893 newline]
adamc@868 894
adam@1293 895 fun dml (loc, mode) =
adamc@868 896 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 897 newline,
adam@1295 898 string "PGresult *res;",
adam@1295 899 newline,
adam@1295 900
adam@1295 901 makeSavepoint mode,
adam@1295 902
adam@1295 903 string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
adamc@868 904 newline,
adamc@868 905 newline,
adam@1293 906 dmlCommon {loc = loc, dml = string "dml", mode = mode}]
adamc@868 907
adam@1293 908 fun dmlPrepared {loc, id, dml, inputs, mode} =
adamc@868 909 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 910 newline,
adam@1431 911
adam@1431 912 makeParams inputs,
adam@1431 913
adamc@868 914 newline,
adam@1295 915 string "PGresult *res;",
adam@1295 916 newline,
adam@1295 917 newline,
adam@1295 918
adam@1295 919 makeSavepoint mode,
adam@1295 920
adam@1295 921 string "res = ",
adamc@868 922 if #persistent (Settings.currentProtocol ()) then
adamc@868 923 box [string "PQexecPrepared(conn, \"uw",
adamc@868 924 string (Int.toString id),
adamc@868 925 string "\", ",
adamc@868 926 string (Int.toString (length inputs)),
adamc@868 927 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@868 928 else
adamc@868 929 box [string "PQexecParams(conn, \"",
adam@1656 930 string (Prim.toCString dml),
adamc@868 931 string "\", ",
adamc@868 932 string (Int.toString (length inputs)),
adamc@868 933 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@868 934 newline,
adamc@868 935 newline,
adamc@868 936 dmlCommon {loc = loc, dml = box [string "\"",
adam@1656 937 string (Prim.toCString dml),
adam@1293 938 string "\""], mode = mode}]
adamc@868 939
adamc@869 940 fun nextvalCommon {loc, query} =
adamc@869 941 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
adamc@869 942 newline,
adamc@869 943 newline,
adamc@869 944
adamc@869 945 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@869 946 newline,
adamc@869 947 box [string "PQclear(res);",
adamc@869 948 newline,
adamc@869 949 string "uw_error(ctx, FATAL, \"",
adamc@869 950 string (ErrorMsg.spanToString loc),
adamc@869 951 string ": Query failed:\\n%s\\n%s\", ",
adamc@869 952 query,
adamc@869 953 string ", PQerrorMessage(conn));",
adamc@869 954 newline],
adamc@869 955 string "}",
adamc@869 956 newline,
adamc@869 957 newline,
adamc@869 958
adamc@869 959 string "n = PQntuples(res);",
adamc@869 960 newline,
adamc@869 961 string "if (n != 1) {",
adamc@869 962 newline,
adamc@869 963 box [string "PQclear(res);",
adamc@869 964 newline,
adamc@869 965 string "uw_error(ctx, FATAL, \"",
adamc@869 966 string (ErrorMsg.spanToString loc),
adamc@869 967 string ": Wrong number of result rows:\\n%s\\n%s\", ",
adamc@869 968 query,
adamc@869 969 string ", PQerrorMessage(conn));",
adamc@869 970 newline],
adamc@869 971 string "}",
adamc@869 972 newline,
adamc@869 973 newline,
adamc@869 974
adamc@869 975 string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));",
adamc@869 976 newline,
adamc@869 977 string "PQclear(res);",
adamc@869 978 newline]
adamc@869 979
adamc@878 980 open Cjr
adamc@878 981
adamc@878 982 fun nextval {loc, seqE, seqName} =
adamc@878 983 let
adamc@878 984 val query = case seqName of
adamc@878 985 SOME s =>
adamc@879 986 string ("\"SELECT NEXTVAL('" ^ s ^ "')\"")
adamc@878 987 | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ",
adamc@878 988 seqE,
adamc@878 989 string ", \"')\"))"]
adamc@878 990 in
adamc@878 991 box [string "char *query = ",
adamc@878 992 query,
adamc@878 993 string ";",
adamc@878 994 newline,
adamc@878 995 string "PGconn *conn = uw_get_db(ctx);",
adamc@878 996 newline,
adamc@878 997 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@878 998 newline,
adamc@878 999 newline,
adamc@878 1000 nextvalCommon {loc = loc, query = string "query"}]
adamc@878 1001 end
adamc@869 1002
adamc@869 1003 fun nextvalPrepared {loc, id, query} =
adamc@869 1004 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@869 1005 newline,
adamc@869 1006 newline,
adamc@869 1007 string "PGresult *res = ",
adamc@869 1008 if #persistent (Settings.currentProtocol ()) then
adamc@869 1009 box [string "PQexecPrepared(conn, \"uw",
adamc@869 1010 string (Int.toString id),
adamc@869 1011 string "\", 0, NULL, NULL, NULL, 0);"]
adamc@869 1012 else
adamc@869 1013 box [string "PQexecParams(conn, \"",
adam@1656 1014 string (Prim.toCString query),
adamc@869 1015 string "\", 0, NULL, NULL, NULL, NULL, 0);"],
adamc@869 1016 newline,
adamc@869 1017 newline,
adamc@869 1018 nextvalCommon {loc = loc, query = box [string "\"",
adam@1656 1019 string (Prim.toCString query),
adamc@869 1020 string "\""]}]
adamc@869 1021
adamc@1073 1022 fun setvalCommon {loc, query} =
adamc@1073 1023 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");",
adamc@1073 1024 newline,
adamc@1073 1025 newline,
adamc@1073 1026
adamc@1073 1027 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@1073 1028 newline,
adamc@1073 1029 box [string "PQclear(res);",
adamc@1073 1030 newline,
adamc@1073 1031 string "uw_error(ctx, FATAL, \"",
adamc@1073 1032 string (ErrorMsg.spanToString loc),
adamc@1073 1033 string ": Query failed:\\n%s\\n%s\", ",
adamc@1073 1034 query,
adamc@1073 1035 string ", PQerrorMessage(conn));",
adamc@1073 1036 newline],
adamc@1073 1037 string "}",
adamc@1073 1038 newline,
adamc@1073 1039 newline,
adamc@1073 1040
adamc@1073 1041 string "PQclear(res);",
adamc@1073 1042 newline]
adamc@1073 1043
adamc@1073 1044 fun setval {loc, seqE, count} =
adamc@1073 1045 let
adamc@1073 1046 val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
adamc@1073 1047 seqE,
adamc@1073 1048 string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
adamc@1073 1049 count,
adamc@1073 1050 string "), \")\"))))"]
adamc@1073 1051 in
adamc@1073 1052 box [string "char *query = ",
adamc@1073 1053 query,
adamc@1073 1054 string ";",
adamc@1073 1055 newline,
adamc@1073 1056 string "PGconn *conn = uw_get_db(ctx);",
adamc@1073 1057 newline,
adamc@1073 1058 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@1073 1059 newline,
adamc@1073 1060 newline,
adamc@1073 1061 setvalCommon {loc = loc, query = string "query"}]
adamc@1073 1062 end
adamc@1073 1063
adamc@874 1064 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
adamc@874 1065 | #"\\" => "\\\\"
adamc@874 1066 | ch =>
adamc@874 1067 if Char.isPrint ch then
adamc@874 1068 str ch
adamc@874 1069 else
adamc@874 1070 "\\" ^ StringCvt.padLeft #"0" 3
adamc@874 1071 (Int.fmt StringCvt.OCT (ord ch)))
adam@1656 1072 (Prim.toCString s) ^ "'::text"
adamc@874 1073
adamc@874 1074 fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
adamc@874 1075
adamc@874 1076 fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t)
adamc@874 1077
adamc@866 1078 val () = addDbms {name = "postgres",
adam@1682 1079 randomFunction = "RANDOM",
adam@1464 1080 header = Config.pgheader,
adamc@866 1081 link = "-lpq",
adamc@873 1082 p_sql_type = p_sql_type,
adamc@867 1083 init = init,
adamc@867 1084 query = query,
adamc@868 1085 queryPrepared = queryPrepared,
adamc@868 1086 dml = dml,
adamc@869 1087 dmlPrepared = dmlPrepared,
adamc@869 1088 nextval = nextval,
adamc@874 1089 nextvalPrepared = nextvalPrepared,
adamc@1073 1090 setval = setval,
adamc@874 1091 sqlifyString = sqlifyString,
adamc@874 1092 p_cast = p_cast,
adamc@874 1093 p_blank = p_blank,
adamc@877 1094 supportsDeleteAs = true,
adamc@886 1095 supportsUpdateAs = true,
adamc@877 1096 createSequence = fn s => "CREATE SEQUENCE " ^ s,
adamc@878 1097 textKeysNeedLengths = false,
adamc@879 1098 supportsNextval = true,
adamc@882 1099 supportsNestedPrepared = true,
adamc@890 1100 sqlPrefix = "",
adamc@1014 1101 supportsOctetLength = true,
adamc@1014 1102 trueString = "TRUE",
adamc@1196 1103 falseString = "FALSE",
adamc@1196 1104 onlyUnion = false,
adam@1777 1105 nestedRelops = true,
adam@1777 1106 windowFunctions = true}
adamc@874 1107
adamc@866 1108 val () = setDbms "postgres"
adamc@866 1109
adamc@866 1110 end