Mercurial > urweb

annotate src/sqlite.sml @ 974:b851675a2c3d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Compiled an 'option' pattern-match
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Sep 2009 14:15:29 -0400
parents 034eeb099564
children 16f7cb0891b6
rev   line source
adamc@885 1 (* Copyright (c) 2009, Adam Chlipala
adamc@885 2 * All rights reserved.
adamc@885 3 *
adamc@885 4 * Redistribution and use in source and binary forms, with or without
adamc@885 5 * modification, are permitted provided that the following conditions are met:
adamc@885 6 *
adamc@885 7 * - Redistributions of source code must retain the above copyright notice,
adamc@885 8 * this list of conditions and the following disclaimer.
adamc@885 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@885 10 * this list of conditions and the following disclaimer in the documentation
adamc@885 11 * and/or other materials provided with the distribution.
adamc@885 12 * - The names of contributors may not be used to endorse or promote products
adamc@885 13 * derived from this software without specific prior written permission.
adamc@885 14 *
adamc@885 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@885 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@885 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@885 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@885 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@885 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@885 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@885 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@885 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@885 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@885 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@885 26 *)
adamc@885 27
adamc@885 28 structure SQLite :> SQLITE = struct
adamc@885 29
adamc@885 30 open Settings
adamc@885 31 open Print.PD
adamc@885 32 open Print
adamc@885 33
adamc@885 34 fun p_sql_type t =
adamc@885 35 case t of
adamc@885 36 Int => "integer"
adamc@885 37 | Float => "real"
adamc@885 38 | String => "text"
adamc@885 39 | Bool => "integer"
adamc@887 40 | Time => "text"
adamc@885 41 | Blob => "blob"
adamc@885 42 | Channel => "integer"
adamc@885 43 | Client => "integer"
adamc@885 44 | Nullable t => p_sql_type t
adamc@885 45
adamc@885 46 val ident = String.translate (fn #"'" => "PRIME"
adamc@885 47 | ch => str ch)
adamc@885 48
adamc@885 49 fun checkRel (table, checkNullable) (s, xts) =
adamc@885 50 let
adamc@885 51 val q = "SELECT COUNT(*) FROM sqlite_master WHERE type = '" ^ table ^ "' AND name = '"
adamc@885 52 ^ s ^ "'"
adamc@885 53 in
adamc@885 54 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 55 string q,
adamc@885 56 string "\", -1, &stmt, NULL) != SQLITE_OK) {",
adamc@885 57 newline,
adamc@885 58 box [string "sqlite3_close(conn->conn);",
adamc@885 59 newline,
adamc@885 60 string "uw_error(ctx, FATAL, \"Query preparation failed:\\n",
adamc@885 61 string q,
adamc@885 62 string "\");",
adamc@885 63 newline],
adamc@885 64 string "}",
adamc@885 65 newline,
adamc@885 66 newline,
adamc@885 67
adamc@885 68 string "while ((res = sqlite3_step(stmt)) == SQLITE_BUSY)",
adamc@885 69 newline,
adamc@885 70 box [string "sleep(1);",
adamc@885 71 newline],
adamc@885 72 newline,
adamc@885 73 string "if (res == SQLITE_DONE) {",
adamc@885 74 newline,
adamc@885 75 box [string "sqlite3_finalize(stmt);",
adamc@885 76 newline,
adamc@885 77 string "sqlite3_close(conn->conn);",
adamc@885 78 newline,
adamc@885 79 string "uw_error(ctx, FATAL, \"No row returned:\\n",
adamc@885 80 string q,
adamc@885 81 string "\");",
adamc@885 82 newline],
adamc@885 83 string "}",
adamc@885 84 newline,
adamc@885 85 newline,
adamc@885 86 string "if (res != SQLITE_ROW) {",
adamc@885 87 newline,
adamc@885 88 box [string "sqlite3_finalize(stmt);",
adamc@885 89 newline,
adamc@885 90 string "sqlite3_close(conn->conn);",
adamc@885 91 newline,
adamc@885 92 string "uw_error(ctx, FATAL, \"Error getting row:\\n",
adamc@885 93 string q,
adamc@885 94 string "\");",
adamc@885 95 newline],
adamc@885 96 string "}",
adamc@885 97 newline,
adamc@885 98 newline,
adamc@885 99
adamc@885 100 string "if (sqlite3_column_count(stmt) != 1) {",
adamc@885 101 newline,
adamc@885 102 box [string "sqlite3_finalize(stmt);",
adamc@885 103 newline,
adamc@885 104 string "sqlite3_close(conn->conn);",
adamc@885 105 newline,
adamc@885 106 string "uw_error(ctx, FATAL, \"Bad column count:\\n",
adamc@885 107 string q,
adamc@885 108 string "\");",
adamc@885 109 newline],
adamc@885 110 string "}",
adamc@885 111 newline,
adamc@885 112 newline,
adamc@885 113
adamc@885 114 string "if (sqlite3_column_int(stmt, 0) != 1) {",
adamc@885 115 newline,
adamc@885 116 box [string "sqlite3_finalize(stmt);",
adamc@885 117 newline,
adamc@885 118 string "sqlite3_close(conn->conn);",
adamc@885 119 newline,
adamc@885 120 string "uw_error(ctx, FATAL, \"Table '",
adamc@885 121 string s,
adamc@885 122 string "' does not exist.\");",
adamc@885 123 newline],
adamc@885 124 string "}",
adamc@885 125 newline,
adamc@885 126 newline,
adamc@885 127 string "sqlite3_finalize(stmt);",
adamc@885 128 newline]
adamc@885 129 end
adamc@885 130
adamc@885 131 fun init {dbstring, prepared = ss, tables, views, sequences} =
adamc@885 132 let
adamc@885 133 val db = ref dbstring
adamc@885 134 in
adamc@885 135 app (fn s =>
adamc@885 136 case String.fields (fn ch => ch = #"=") s of
adamc@885 137 [name, value] =>
adamc@885 138 (case name of
adamc@885 139 "dbname" => db := value
adamc@885 140 | _ => ())
adamc@885 141 | _ => ()) (String.tokens Char.isSpace dbstring);
adamc@885 142
adamc@885 143 box [string "typedef struct {",
adamc@885 144 newline,
adamc@885 145 box [string "sqlite3 *conn;",
adamc@885 146 newline,
adamc@885 147 p_list_sepi (box [])
adamc@885 148 (fn i => fn _ =>
adamc@885 149 box [string "sqlite3_stmt *p",
adamc@885 150 string (Int.toString i),
adamc@885 151 string ";",
adamc@885 152 newline])
adamc@885 153 ss],
adamc@885 154 string "} uw_conn;",
adamc@885 155 newline,
adamc@885 156 newline,
adamc@885 157
adamc@885 158 string "void uw_client_init(void) {",
adamc@885 159 newline,
adamc@885 160 box [string "uw_sqlfmtInt = \"%lld%n\";",
adamc@885 161 newline,
adamc@885 162 string "uw_sqlfmtFloat = \"%g%n\";",
adamc@885 163 newline,
adamc@885 164 string "uw_Estrings = 0;",
adamc@885 165 newline,
adamc@885 166 string "uw_sqlsuffixString = \"\";",
adamc@885 167 newline,
adamc@885 168 string "uw_sqlsuffixBlob = \"\";",
adamc@885 169 newline,
adamc@885 170 string "uw_sqlfmtUint4 = \"%u%n\";",
adamc@885 171 newline],
adamc@885 172 string "}",
adamc@885 173 newline,
adamc@885 174 newline,
adamc@885 175
adamc@885 176 if #persistent (currentProtocol ()) then
adamc@885 177 box [string "static void uw_db_validate(uw_context ctx) {",
adamc@885 178 newline,
adamc@885 179 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 180 newline,
adamc@885 181 string "sqlite3_stmt *stmt;",
adamc@885 182 newline,
adamc@885 183 string "int res;",
adamc@885 184 newline,
adamc@885 185 newline,
adamc@885 186 p_list_sep newline (checkRel ("table", true)) tables,
adamc@885 187 p_list_sep newline (fn name => checkRel ("table", true)
adamc@885 188 (name, [("id", Settings.Client)])) sequences,
adamc@885 189 p_list_sep newline (checkRel ("view", false)) views,
adamc@885 190 string "}",
adamc@885 191 newline,
adamc@885 192 newline,
adamc@885 193
adamc@885 194 string "static void uw_db_prepare(uw_context ctx) {",
adamc@885 195 newline,
adamc@885 196 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 197 newline,
adamc@885 198 newline,
adamc@885 199
adamc@885 200 p_list_sepi newline (fn i => fn (s, n) =>
adamc@885 201 let
adamc@885 202 fun uhoh this s args =
adamc@885 203 box [p_list_sepi (box [])
adamc@885 204 (fn j => fn () =>
adamc@885 205 box [string
adamc@885 206 "sqlite3_finalize(conn->p",
adamc@885 207 string (Int.toString j),
adamc@885 208 string ");",
adamc@885 209 newline])
adamc@885 210 (List.tabulate (i, fn _ => ())),
adamc@885 211 box (if this then
adamc@885 212 [string
adamc@885 213 "sqlite3_finalize(conn->p",
adamc@885 214 string (Int.toString i),
adamc@885 215 string ");",
adamc@885 216 newline]
adamc@885 217 else
adamc@885 218 []),
adamc@885 219 string "sqlite3_close(conn->conn);",
adamc@885 220 newline,
adamc@885 221 string "uw_error(ctx, FATAL, \"",
adamc@885 222 string s,
adamc@885 223 string "\"",
adamc@885 224 p_list_sep (box []) (fn s => box [string ", ",
adamc@885 225 string s]) args,
adamc@885 226 string ");",
adamc@885 227 newline]
adamc@885 228 in
adamc@885 229 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 230 string (String.toString s),
adamc@885 231 string "\", -1, &conn->p",
adamc@885 232 string (Int.toString i),
adamc@885 233 string ", NULL) != SQLITE_OK) {",
adamc@885 234 newline,
adamc@886 235 box [string "char msg[1024];",
adamc@886 236 newline,
adamc@886 237 string "strncpy(msg, sqlite3_errmsg(conn->conn), 1024);",
adamc@886 238 newline,
adamc@886 239 string "msg[1023] = 0;",
adamc@886 240 newline,
adamc@886 241 uhoh false ("Error preparing statement: "
adamc@886 242 ^ String.toString s ^ "\\n%s") ["msg"]],
adamc@885 243 string "}",
adamc@885 244 newline]
adamc@885 245 end)
adamc@885 246 ss,
adamc@885 247
adamc@885 248 string "}"]
adamc@885 249 else
adamc@885 250 box [string "static void uw_db_prepare(uw_context ctx) { }",
adamc@885 251 newline,
adamc@885 252 string "static void uw_db_validate(uw_context ctx) { }"],
adamc@885 253 newline,
adamc@885 254 newline,
adamc@885 255
adamc@885 256 string "void uw_db_init(uw_context ctx) {",
adamc@885 257 newline,
adamc@885 258 string "sqlite3 *sqlite;",
adamc@885 259 newline,
adamc@885 260 string "uw_conn *conn;",
adamc@885 261 newline,
adamc@885 262 newline,
adamc@885 263 string "if (sqlite3_open(\"",
adamc@885 264 string (!db),
adamc@885 265 string "\", &sqlite) != SQLITE_OK) uw_error(ctx, FATAL, ",
adamc@885 266 string "\"Can't open SQLite database.\");",
adamc@885 267 newline,
adamc@885 268 newline,
adamc@885 269 string "conn = calloc(1, sizeof(uw_conn));",
adamc@885 270 newline,
adamc@885 271 string "conn->conn = sqlite;",
adamc@885 272 newline,
adamc@885 273 string "uw_set_db(ctx, conn);",
adamc@885 274 newline,
adamc@885 275 string "uw_db_validate(ctx);",
adamc@885 276 newline,
adamc@885 277 string "uw_db_prepare(ctx);",
adamc@885 278 newline,
adamc@885 279 string "}",
adamc@885 280 newline,
adamc@885 281 newline,
adamc@885 282
adamc@885 283 string "void uw_db_close(uw_context ctx) {",
adamc@885 284 newline,
adamc@885 285 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 286 newline,
adamc@885 287 p_list_sepi (box [])
adamc@885 288 (fn i => fn _ =>
adamc@885 289 box [string "if (conn->p",
adamc@885 290 string (Int.toString i),
adamc@885 291 string ") sqlite3_finalize(conn->p",
adamc@885 292 string (Int.toString i),
adamc@885 293 string ");",
adamc@885 294 newline])
adamc@885 295 ss,
adamc@885 296 string "sqlite3_close(conn->conn);",
adamc@885 297 newline,
adamc@885 298 string "}",
adamc@885 299 newline,
adamc@885 300 newline,
adamc@885 301
adamc@885 302 string "int uw_db_begin(uw_context ctx) {",
adamc@885 303 newline,
adamc@885 304 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 305 newline,
adamc@885 306 newline,
adamc@885 307 string "if (sqlite3_exec(conn->conn, \"BEGIN\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 308 newline,
adamc@885 309 box [string "return 0;",
adamc@885 310 newline],
adamc@885 311 string "else {",
adamc@885 312 newline,
adamc@885 313 box [string "fprintf(stderr, \"Begin error: %s\\n\", sqlite3_errmsg(conn->conn));",
adamc@885 314 newline,
adamc@885 315 string "return 1;",
adamc@885 316 newline],
adamc@885 317 string "}",
adamc@885 318 newline,
adamc@885 319 string "}",
adamc@885 320 newline,
adamc@885 321 string "int uw_db_commit(uw_context ctx) {",
adamc@885 322 newline,
adamc@885 323 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 324 newline,
adamc@885 325 string "if (sqlite3_exec(conn->conn, \"COMMIT\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 326 newline,
adamc@885 327 box [string "return 0;",
adamc@885 328 newline],
adamc@885 329 string "else {",
adamc@885 330 newline,
adamc@885 331 box [string "fprintf(stderr, \"Commit error: %s\\n\", sqlite3_errmsg(conn->conn));",
adamc@885 332 newline,
adamc@885 333 string "return 1;",
adamc@885 334 newline],
adamc@885 335 string "}",
adamc@885 336 newline,
adamc@885 337 string "}",
adamc@885 338 newline,
adamc@885 339 newline,
adamc@885 340
adamc@885 341 string "int uw_db_rollback(uw_context ctx) {",
adamc@885 342 newline,
adamc@885 343 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 344 newline,
adamc@885 345 string "if (sqlite3_exec(conn->conn, \"ROLLBACK\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 346 newline,
adamc@885 347 box [string "return 0;",
adamc@885 348 newline],
adamc@885 349 string "else {",
adamc@885 350 newline,
adamc@885 351 box [string "fprintf(stderr, \"Rollback error: %s\\n\", sqlite3_errmsg(conn->conn));",
adamc@885 352 newline,
adamc@885 353 string "return 1;",
adamc@885 354 newline],
adamc@885 355 string "}",
adamc@885 356 newline,
adamc@885 357 string "}",
adamc@885 358 newline,
adamc@885 359 newline]
adamc@885 360 end
adamc@885 361
adamc@885 362 fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
adamc@885 363 let
adamc@885 364 fun p_unsql t =
adamc@885 365 case t of
adamc@885 366 Int => box [string "sqlite3_column_int64(stmt, ", string (Int.toString i), string ")"]
adamc@885 367 | Float => box [string "sqlite3_column_double(stmt, ", string (Int.toString i), string ")"]
adamc@885 368 | String =>
adamc@885 369 if wontLeakStrings then
adamc@885 370 box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")"]
adamc@885 371 else
adamc@885 372 box [string "uw_strdup(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
adamc@885 373 | Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adamc@887 374 | Time => box [string "uw_Basis_stringToTime_error(ctx, sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
adamc@885 375 | Blob => box [string "({",
adamc@885 376 newline,
adamc@890 377 string "char *data = (char *)sqlite3_column_blob(stmt, ",
adamc@885 378 string (Int.toString i),
adamc@885 379 string ");",
adamc@885 380 newline,
adamc@890 381 string "int len = sqlite3_column_bytes(stmt, ",
adamc@885 382 string (Int.toString i),
adamc@890 383 string ");",
adamc@890 384 newline,
adamc@890 385 string "uw_Basis_blob b = {len, uw_memdup(ctx, data, len)};",
adamc@885 386 newline,
adamc@885 387 string "b;",
adamc@885 388 newline,
adamc@885 389 string "})"]
adamc@886 390 | Channel => box [string "({",
adamc@886 391 newline,
adamc@886 392 string "sqlite3_int64 n = sqlite3_column_int64(stmt, ",
adamc@886 393 string (Int.toString i),
adamc@886 394 string ");",
adamc@886 395 newline,
adamc@886 396 string "uw_Basis_channel ch = {n >> 32, n & 0xFFFFFFFF};",
adamc@886 397 newline,
adamc@886 398 string "ch;",
adamc@886 399 newline,
adamc@886 400 string "})"]
adamc@885 401 | Client => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adamc@885 402
adamc@885 403 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@885 404
adamc@885 405 fun getter t =
adamc@885 406 case t of
adamc@885 407 Nullable t =>
adamc@885 408 box [string "(sqlite3_column_type(stmt, ",
adamc@885 409 string (Int.toString i),
adamc@885 410 string ") == SQLITE_NULL ? NULL : ",
adamc@885 411 case t of
adamc@885 412 String => getter t
adamc@885 413 | _ => box [string "({",
adamc@885 414 newline,
adamc@885 415 string (p_sql_ctype t),
adamc@885 416 space,
adamc@885 417 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@885 418 string (p_sql_ctype t),
adamc@885 419 string "));",
adamc@885 420 newline,
adamc@885 421 string "*tmp = ",
adamc@885 422 getter t,
adamc@885 423 string ";",
adamc@885 424 newline,
adamc@885 425 string "tmp;",
adamc@885 426 newline,
adamc@885 427 string "})"],
adamc@885 428 string ")"]
adamc@885 429 | _ =>
adamc@885 430 box [string "(sqlite3_column_type(stmt, ",
adamc@885 431 string (Int.toString i),
adamc@885 432 string ") == SQLITE_NULL ? ",
adamc@885 433 box [string "({",
adamc@885 434 string (p_sql_ctype t),
adamc@885 435 space,
adamc@885 436 string "tmp;",
adamc@885 437 newline,
adamc@885 438 string "uw_error(ctx, FATAL, \"",
adamc@885 439 string (ErrorMsg.spanToString loc),
adamc@885 440 string ": Unexpectedly NULL field #",
adamc@885 441 string (Int.toString i),
adamc@885 442 string "\");",
adamc@885 443 newline,
adamc@885 444 string "tmp;",
adamc@885 445 newline,
adamc@885 446 string "})"],
adamc@885 447 string " : ",
adamc@885 448 p_unsql t,
adamc@885 449 string ")"]
adamc@885 450 in
adamc@885 451 getter t
adamc@885 452 end
adamc@885 453
adamc@885 454 fun queryCommon {loc, query, cols, doCols} =
adamc@885 455 box [string "int r;",
adamc@885 456 newline,
adamc@885 457
adamc@885 458 string "sqlite3_reset(stmt);",
adamc@885 459 newline,
adamc@885 460
adamc@885 461 string "uw_end_region(ctx);",
adamc@885 462 newline,
adamc@885 463 string "while ((r = sqlite3_step(stmt)) == SQLITE_ROW) {",
adamc@885 464 newline,
adamc@885 465 doCols p_getcol,
adamc@885 466 string "}",
adamc@885 467 newline,
adamc@885 468 newline,
adamc@885 469
adamc@885 470 string "if (r == SQLITE_BUSY) {",
adamc@885 471 box [string "sleep(1);",
adamc@885 472 newline,
adamc@885 473 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 474 newline],
adamc@885 475 string "}",
adamc@885 476 newline,
adamc@885 477 newline,
adamc@885 478
adamc@885 479 string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
adamc@885 480 string (ErrorMsg.spanToString loc),
adamc@885 481 string ": query step failed: %s\\n%s\", ",
adamc@885 482 query,
adamc@885 483 string ", sqlite3_errmsg(conn->conn));",
adamc@885 484 newline,
adamc@885 485 newline]
adamc@885 486
adamc@885 487 fun query {loc, cols, doCols} =
adamc@885 488 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 489 newline,
adamc@886 490 string "sqlite3_stmt *stmt;",
adamc@885 491 newline,
adamc@885 492 newline,
adamc@885 493 string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s\\n%s\", sqlite3_errmsg(conn->conn));",
adamc@885 494 newline,
adamc@885 495 newline,
adamc@885 496 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 497 newline,
adamc@885 498 newline,
adamc@885 499
adamc@885 500 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
adamc@885 501
adamc@885 502 string "uw_pop_cleanup(ctx);",
adamc@885 503 newline]
adamc@885 504
adamc@885 505 fun p_inputs loc =
adamc@885 506 p_list_sepi (box [])
adamc@885 507 (fn i => fn t =>
adamc@885 508 let
adamc@885 509 fun bind (t, arg) =
adamc@885 510 case t of
adamc@885 511 Int => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 512 string (Int.toString (i + 1)),
adamc@885 513 string ", ",
adamc@885 514 arg,
adamc@885 515 string ")"]
adamc@885 516 | Float => box [string "sqlite3_bind_double(stmt, ",
adamc@885 517 string (Int.toString (i + 1)),
adamc@885 518 string ", ",
adamc@885 519 arg,
adamc@885 520 string ")"]
adamc@885 521 | String => box [string "sqlite3_bind_text(stmt, ",
adamc@885 522 string (Int.toString (i + 1)),
adamc@885 523 string ", ",
adamc@885 524 arg,
adamc@885 525 string ", -1, SQLITE_TRANSIENT)"]
adamc@885 526 | Bool => box [string "sqlite3_bind_int(stmt, ",
adamc@885 527 string (Int.toString (i + 1)),
adamc@885 528 string ", ",
adamc@885 529 arg,
adamc@885 530 string ")"]
adamc@887 531 | Time => box [string "sqlite3_bind_text(stmt, ",
adamc@885 532 string (Int.toString (i + 1)),
adamc@887 533 string ", uw_Basis_attrifyTime(ctx, ",
adamc@885 534 arg,
adamc@887 535 string "), -1, SQLITE_TRANSIENT)"]
adamc@885 536 | Blob => box [string "sqlite3_bind_blob(stmt, ",
adamc@885 537 string (Int.toString (i + 1)),
adamc@885 538 string ", ",
adamc@885 539 arg,
adamc@885 540 string ".data, ",
adamc@885 541 arg,
adamc@890 542 string ".size, SQLITE_TRANSIENT)"]
adamc@886 543 | Channel => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 544 string (Int.toString (i + 1)),
adamc@886 545 string ", ((sqlite3_int64)",
adamc@885 546 arg,
adamc@886 547 string ".cli << 32) | ",
adamc@886 548 arg,
adamc@886 549 string ".chn)"]
adamc@885 550 | Client => box [string "sqlite3_bind_int(stmt, ",
adamc@885 551 string (Int.toString (i + 1)),
adamc@885 552 string ", ",
adamc@885 553 arg,
adamc@885 554 string ")"]
adamc@885 555 | Nullable t => box [string "(",
adamc@885 556 arg,
adamc@885 557 string " == NULL ? sqlite3_bind_null(stmt, ",
adamc@885 558 string (Int.toString (i + 1)),
adamc@885 559 string ") : ",
adamc@885 560 bind (t, case t of
adamc@885 561 String => arg
adamc@885 562 | _ => box [string "(*", arg, string ")"]),
adamc@885 563 string ")"]
adamc@885 564 in
adamc@885 565 box [string "if (",
adamc@885 566 bind (t, box [string "arg", string (Int.toString (i + 1))]),
adamc@885 567 string " != SQLITE_OK) uw_error(ctx, FATAL, \"",
adamc@885 568 string (ErrorMsg.spanToString loc),
adamc@885 569 string ": Error binding parameter #",
adamc@885 570 string (Int.toString (i + 1)),
adamc@885 571 string ": %s\", sqlite3_errmsg(conn->conn));",
adamc@885 572 newline]
adamc@885 573 end)
adamc@885 574
adamc@885 575 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
adamc@885 576 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 577 newline,
adamc@885 578 if nested then
adamc@885 579 box [string "sqlite3_stmt *stmt;",
adamc@885 580 newline]
adamc@885 581 else
adamc@885 582 box [string "sqlite3_stmt *stmt = conn->p",
adamc@885 583 string (Int.toString id),
adamc@885 584 string ";",
adamc@885 585 newline,
adamc@885 586 newline,
adamc@885 587
adamc@885 588 string "if (stmt == NULL) {",
adamc@885 589 newline],
adamc@885 590
adamc@885 591 string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 592 string (String.toString query),
adamc@885 593 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adamc@885 594 string (String.toString query),
adamc@885 595 string "\\n%s\", sqlite3_errmsg(conn->conn));",
adamc@885 596 newline,
adamc@885 597 if nested then
adamc@885 598 box [string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 599 newline]
adamc@885 600 else
adamc@885 601 box [string "conn->p",
adamc@885 602 string (Int.toString id),
adamc@885 603 string " = stmt;",
adamc@885 604 newline,
adamc@885 605 string "}",
adamc@885 606 newline,
adamc@885 607 newline,
adamc@885 608 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 609 newline,
adamc@885 610 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 611 newline],
adamc@885 612 newline,
adamc@885 613
adamc@885 614 p_inputs loc inputs,
adamc@885 615 newline,
adamc@885 616
adamc@885 617 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
adamc@885 618 string (String.toString query),
adamc@885 619 string "\""]},
adamc@885 620
adamc@885 621 string "uw_pop_cleanup(ctx);",
adamc@885 622 newline,
adamc@885 623 if nested then
adamc@885 624 box []
adamc@885 625 else
adamc@885 626 box [string "uw_pop_cleanup(ctx);",
adamc@885 627 newline]]
adamc@885 628
adamc@885 629 fun dmlCommon {loc, dml} =
adamc@885 630 box [string "int r;",
adamc@885 631 newline,
adamc@885 632
adamc@885 633 string "if ((r = sqlite3_step(stmt)) == SQLITE_BUSY) {",
adamc@885 634 box [string "sleep(1);",
adamc@885 635 newline,
adamc@885 636 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 637 newline],
adamc@885 638 string "}",
adamc@885 639 newline,
adamc@885 640 newline,
adamc@885 641
adamc@885 642 string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
adamc@885 643 string (ErrorMsg.spanToString loc),
adamc@885 644 string ": DML step failed: %s\\n%s\", ",
adamc@885 645 dml,
adamc@885 646 string ", sqlite3_errmsg(conn->conn));",
adamc@885 647 newline]
adamc@885 648
adamc@885 649 fun dml loc =
adamc@885 650 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 651 newline,
adamc@886 652 string "sqlite3_stmt *stmt;",
adamc@885 653 newline,
adamc@885 654 newline,
adamc@885 655 string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s\\n%s\", dml, sqlite3_errmsg(conn->conn));",
adamc@885 656 newline,
adamc@885 657 newline,
adamc@885 658 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 659 newline,
adamc@885 660 newline,
adamc@885 661
adamc@885 662 dmlCommon {loc = loc, dml = string "dml"},
adamc@885 663
adamc@885 664 string "uw_pop_cleanup(ctx);",
adamc@885 665 newline]
adamc@885 666
adamc@885 667 fun dmlPrepared {loc, id, dml, inputs} =
adamc@885 668 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 669 newline,
adamc@885 670 string "sqlite3_stmt *stmt = conn->p",
adamc@885 671 string (Int.toString id),
adamc@885 672 string ";",
adamc@885 673 newline,
adamc@885 674 newline,
adamc@885 675
adamc@885 676 string "if (stmt == NULL) {",
adamc@885 677 newline,
adamc@885 678 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 679 string (String.toString dml),
adamc@885 680 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adamc@885 681 string (String.toString dml),
adamc@885 682 string "\\n%s\", sqlite3_errmsg(conn->conn));",
adamc@885 683 newline,
adamc@885 684 string "conn->p",
adamc@885 685 string (Int.toString id),
adamc@885 686 string " = stmt;",
adamc@885 687 newline],
adamc@885 688 string "}",
adamc@885 689 newline,
adamc@885 690
adamc@885 691 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 692 newline,
adamc@885 693 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 694 newline,
adamc@885 695
adamc@885 696 p_inputs loc inputs,
adamc@885 697 newline,
adamc@885 698
adamc@885 699 dmlCommon {loc = loc, dml = box [string "\"",
adamc@885 700 string (String.toString dml),
adamc@885 701 string "\""]},
adamc@885 702
adamc@885 703 string "uw_pop_cleanup(ctx);",
adamc@885 704 newline,
adamc@885 705 string "uw_pop_cleanup(ctx);",
adamc@885 706 newline]
adamc@885 707
adamc@885 708 fun nextval {loc, seqE, seqName} =
adamc@885 709 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 710 newline,
adamc@885 711 string "char *insert = ",
adamc@885 712 case seqName of
adamc@886 713 SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES (NULL)\"")
adamc@885 714 | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ",
adamc@885 715 seqE,
adamc@885 716 string ", \" VALUES ()\"))"],
adamc@885 717 string ";",
adamc@885 718 newline,
adamc@885 719 string "char *delete = ",
adamc@885 720 case seqName of
adamc@885 721 SOME s => string ("\"DELETE FROM " ^ s ^ "\"")
adamc@885 722 | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ",
adamc@885 723 seqE,
adamc@885 724 string ")"],
adamc@885 725 string ";",
adamc@885 726 newline,
adamc@885 727 newline,
adamc@885 728
adamc@886 729 string "if (sqlite3_exec(conn->conn, insert, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' INSERT failed: %s\", sqlite3_errmsg(conn->conn));",
adamc@885 730 newline,
adamc@885 731 string "n = sqlite3_last_insert_rowid(conn->conn);",
adamc@885 732 newline,
adamc@886 733 string "if (sqlite3_exec(conn->conn, delete, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' DELETE failed: %s\", sqlite3_errmsg(conn->conn));",
adamc@885 734 newline]
adamc@885 735
adamc@885 736 fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
adamc@885 737
adamc@885 738 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
adamc@885 739 | ch =>
adamc@885 740 if Char.isPrint ch then
adamc@885 741 str ch
adamc@885 742 else
adamc@885 743 (ErrorMsg.error
adamc@885 744 "Non-printing character found in SQL string literal";
adamc@885 745 ""))
adamc@885 746 (String.toString s) ^ "'"
adamc@885 747
adamc@885 748 fun p_cast (s, _) = s
adamc@885 749
adamc@885 750 fun p_blank _ = "?"
adamc@885 751
adamc@885 752 val () = addDbms {name = "sqlite",
adamc@885 753 header = "sqlite3.h",
adamc@885 754 link = "-lsqlite3",
adamc@885 755 init = init,
adamc@885 756 p_sql_type = p_sql_type,
adamc@885 757 query = query,
adamc@885 758 queryPrepared = queryPrepared,
adamc@885 759 dml = dml,
adamc@885 760 dmlPrepared = dmlPrepared,
adamc@885 761 nextval = nextval,
adamc@885 762 nextvalPrepared = nextvalPrepared,
adamc@885 763 sqlifyString = sqlifyString,
adamc@885 764 p_cast = p_cast,
adamc@885 765 p_blank = p_blank,
adamc@885 766 supportsDeleteAs = false,
adamc@886 767 supportsUpdateAs = false,
adamc@886 768 createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTOINCREMENT)",
adamc@885 769 textKeysNeedLengths = false,
adamc@885 770 supportsNextval = false,
adamc@885 771 supportsNestedPrepared = false,
adamc@890 772 sqlPrefix = "",
adamc@890 773 supportsOctetLength = false}
adamc@885 774
adamc@885 775 end