Mercurial > urweb

annotate src/sqlite.sml @ 2102:0bd46c9e363f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Return to working version mode
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Jan 2015 10:28:36 -0500
parents 6745eafff617
children 661b531f55bd
rev   line source
adam@1656 1 (* Copyright (c) 2009-2010, 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
adam@1682 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@1014 39 | Char => "text"
adamc@885 40 | Bool => "integer"
adamc@887 41 | Time => "text"
adamc@885 42 | Blob => "blob"
adamc@885 43 | Channel => "integer"
adamc@885 44 | Client => "integer"
adamc@885 45 | Nullable t => p_sql_type t
adamc@885 46
adamc@885 47 val ident = String.translate (fn #"'" => "PRIME"
adamc@885 48 | ch => str ch)
adamc@885 49
adamc@885 50 fun checkRel (table, checkNullable) (s, xts) =
adamc@885 51 let
adamc@885 52 val q = "SELECT COUNT(*) FROM sqlite_master WHERE type = '" ^ table ^ "' AND name = '"
adamc@885 53 ^ s ^ "'"
adamc@885 54 in
adamc@885 55 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 56 string q,
adamc@885 57 string "\", -1, &stmt, NULL) != SQLITE_OK) {",
adamc@885 58 newline,
adamc@885 59 box [string "sqlite3_close(conn->conn);",
adamc@885 60 newline,
adamc@1266 61 string "uw_error(ctx, FATAL, \"Query preparation failed:<br />",
adamc@885 62 string q,
adamc@885 63 string "\");",
adamc@885 64 newline],
adamc@885 65 string "}",
adamc@885 66 newline,
adamc@885 67 newline,
adamc@885 68
adamc@885 69 string "while ((res = sqlite3_step(stmt)) == SQLITE_BUSY)",
adamc@885 70 newline,
adamc@885 71 box [string "sleep(1);",
adamc@885 72 newline],
adamc@885 73 newline,
adamc@885 74 string "if (res == SQLITE_DONE) {",
adamc@885 75 newline,
adamc@885 76 box [string "sqlite3_finalize(stmt);",
adamc@885 77 newline,
adamc@885 78 string "sqlite3_close(conn->conn);",
adamc@885 79 newline,
adamc@1266 80 string "uw_error(ctx, FATAL, \"No row returned:<br />",
adamc@885 81 string q,
adamc@885 82 string "\");",
adamc@885 83 newline],
adamc@885 84 string "}",
adamc@885 85 newline,
adamc@885 86 newline,
adamc@885 87 string "if (res != SQLITE_ROW) {",
adamc@885 88 newline,
adamc@885 89 box [string "sqlite3_finalize(stmt);",
adamc@885 90 newline,
adamc@885 91 string "sqlite3_close(conn->conn);",
adamc@885 92 newline,
adamc@1266 93 string "uw_error(ctx, FATAL, \"Error getting row:<br />",
adamc@885 94 string q,
adamc@885 95 string "\");",
adamc@885 96 newline],
adamc@885 97 string "}",
adamc@885 98 newline,
adamc@885 99 newline,
adamc@885 100
adamc@885 101 string "if (sqlite3_column_count(stmt) != 1) {",
adamc@885 102 newline,
adamc@885 103 box [string "sqlite3_finalize(stmt);",
adamc@885 104 newline,
adamc@885 105 string "sqlite3_close(conn->conn);",
adamc@885 106 newline,
adamc@1266 107 string "uw_error(ctx, FATAL, \"Bad column count:<br />",
adamc@885 108 string q,
adamc@885 109 string "\");",
adamc@885 110 newline],
adamc@885 111 string "}",
adamc@885 112 newline,
adamc@885 113 newline,
adamc@885 114
adamc@885 115 string "if (sqlite3_column_int(stmt, 0) != 1) {",
adamc@885 116 newline,
adamc@885 117 box [string "sqlite3_finalize(stmt);",
adamc@885 118 newline,
adamc@885 119 string "sqlite3_close(conn->conn);",
adamc@885 120 newline,
adamc@885 121 string "uw_error(ctx, FATAL, \"Table '",
adamc@885 122 string s,
adamc@885 123 string "' does not exist.\");",
adamc@885 124 newline],
adamc@885 125 string "}",
adamc@885 126 newline,
adamc@885 127 newline,
adamc@885 128 string "sqlite3_finalize(stmt);",
adamc@885 129 newline]
adamc@885 130 end
adamc@885 131
adamc@885 132 fun init {dbstring, prepared = ss, tables, views, sequences} =
adamc@885 133 let
adamc@885 134 val db = ref dbstring
adamc@885 135 in
adamc@885 136 app (fn s =>
adamc@885 137 case String.fields (fn ch => ch = #"=") s of
adamc@885 138 [name, value] =>
adamc@885 139 (case name of
adamc@885 140 "dbname" => db := value
adamc@885 141 | _ => ())
adamc@885 142 | _ => ()) (String.tokens Char.isSpace dbstring);
adamc@885 143
adamc@885 144 box [string "typedef struct {",
adamc@885 145 newline,
adamc@885 146 box [string "sqlite3 *conn;",
adamc@885 147 newline,
adamc@885 148 p_list_sepi (box [])
adamc@885 149 (fn i => fn _ =>
adamc@885 150 box [string "sqlite3_stmt *p",
adamc@885 151 string (Int.toString i),
adamc@885 152 string ";",
adamc@885 153 newline])
adamc@885 154 ss],
adamc@885 155 string "} uw_conn;",
adamc@885 156 newline,
adamc@885 157 newline,
adamc@885 158
adamc@1094 159 string "static void uw_client_init(void) {",
adamc@885 160 newline,
adamc@885 161 box [string "uw_sqlfmtInt = \"%lld%n\";",
adamc@885 162 newline,
adam@1920 163 string "uw_sqlfmtFloat = \"%.16g%n\";",
adamc@885 164 newline,
adamc@885 165 string "uw_Estrings = 0;",
adamc@885 166 newline,
adam@1834 167 string "uw_sql_type_annotations = 0;",
adam@1834 168 newline,
adamc@885 169 string "uw_sqlsuffixString = \"\";",
adamc@885 170 newline,
adamc@1011 171 string "uw_sqlsuffixChar = \"\";",
adamc@1011 172 newline,
adamc@885 173 string "uw_sqlsuffixBlob = \"\";",
adamc@885 174 newline,
adamc@885 175 string "uw_sqlfmtUint4 = \"%u%n\";",
adamc@885 176 newline],
adamc@885 177 string "}",
adamc@885 178 newline,
adamc@885 179 newline,
adamc@885 180
adamc@885 181 if #persistent (currentProtocol ()) then
adamc@885 182 box [string "static void uw_db_validate(uw_context ctx) {",
adamc@885 183 newline,
adamc@885 184 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 185 newline,
adamc@885 186 string "sqlite3_stmt *stmt;",
adamc@885 187 newline,
adamc@885 188 string "int res;",
adamc@885 189 newline,
adamc@885 190 newline,
adamc@885 191 p_list_sep newline (checkRel ("table", true)) tables,
adamc@885 192 p_list_sep newline (fn name => checkRel ("table", true)
adamc@885 193 (name, [("id", Settings.Client)])) sequences,
adamc@885 194 p_list_sep newline (checkRel ("view", false)) views,
adamc@885 195 string "}",
adamc@885 196 newline,
adamc@885 197 newline,
adamc@885 198
adamc@885 199 string "static void uw_db_prepare(uw_context ctx) {",
adamc@885 200 newline,
adamc@885 201 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 202 newline,
adamc@885 203 newline,
adamc@885 204
adamc@885 205 p_list_sepi newline (fn i => fn (s, n) =>
adamc@885 206 let
adamc@885 207 fun uhoh this s args =
adamc@885 208 box [p_list_sepi (box [])
adamc@885 209 (fn j => fn () =>
adamc@885 210 box [string
adamc@885 211 "sqlite3_finalize(conn->p",
adamc@885 212 string (Int.toString j),
adamc@885 213 string ");",
adamc@885 214 newline])
adamc@885 215 (List.tabulate (i, fn _ => ())),
adamc@885 216 box (if this then
adamc@885 217 [string
adamc@885 218 "sqlite3_finalize(conn->p",
adamc@885 219 string (Int.toString i),
adamc@885 220 string ");",
adamc@885 221 newline]
adamc@885 222 else
adamc@885 223 []),
adamc@885 224 string "sqlite3_close(conn->conn);",
adamc@885 225 newline,
adamc@885 226 string "uw_error(ctx, FATAL, \"",
adamc@885 227 string s,
adamc@885 228 string "\"",
adamc@885 229 p_list_sep (box []) (fn s => box [string ", ",
adamc@885 230 string s]) args,
adamc@885 231 string ");",
adamc@885 232 newline]
adamc@885 233 in
adamc@885 234 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 235 string (Prim.toCString s),
adamc@885 236 string "\", -1, &conn->p",
adamc@885 237 string (Int.toString i),
adamc@885 238 string ", NULL) != SQLITE_OK) {",
adamc@885 239 newline,
adamc@886 240 box [string "char msg[1024];",
adamc@886 241 newline,
adamc@886 242 string "strncpy(msg, sqlite3_errmsg(conn->conn), 1024);",
adamc@886 243 newline,
adamc@886 244 string "msg[1023] = 0;",
adamc@886 245 newline,
adamc@886 246 uhoh false ("Error preparing statement: "
adam@1656 247 ^ Prim.toCString s ^ "<br />%s") ["msg"]],
adamc@885 248 string "}",
adamc@885 249 newline]
adamc@885 250 end)
adamc@885 251 ss,
adamc@885 252
adamc@885 253 string "}"]
adamc@885 254 else
adamc@885 255 box [string "static void uw_db_prepare(uw_context ctx) { }",
adamc@885 256 newline,
adamc@885 257 string "static void uw_db_validate(uw_context ctx) { }"],
adamc@885 258 newline,
adamc@885 259 newline,
adam@1682 260
adamc@1094 261 string "static void uw_db_init(uw_context ctx) {",
adamc@885 262 newline,
adamc@885 263 string "sqlite3 *sqlite;",
adamc@885 264 newline,
adamc@1115 265 string "sqlite3_stmt *stmt;",
adamc@1115 266 newline,
adamc@885 267 string "uw_conn *conn;",
adamc@885 268 newline,
adamc@885 269 newline,
adamc@885 270 string "if (sqlite3_open(\"",
adamc@885 271 string (!db),
adamc@885 272 string "\", &sqlite) != SQLITE_OK) uw_error(ctx, FATAL, ",
adamc@885 273 string "\"Can't open SQLite database.\");",
adamc@885 274 newline,
adamc@885 275 newline,
adamc@1115 276 string "if (uw_database_max < SIZE_MAX) {",
adamc@1115 277 newline,
adamc@1115 278 box [string "char buf[100];",
adamc@1115 279 newline,
adamc@1115 280 newline,
adamc@1115 281
adamc@1115 282 string "sprintf(buf, \"PRAGMA max_page_count = %llu\", (unsigned long long)(uw_database_max / 1024));",
adamc@1115 283 newline,
adamc@1115 284 newline,
adamc@1115 285
adamc@1115 286 string "if (sqlite3_prepare_v2(sqlite, buf, -1, &stmt, NULL) != SQLITE_OK) {",
adamc@1115 287 newline,
adamc@1115 288 box [string "sqlite3_close(sqlite);",
adamc@1115 289 newline,
adamc@1115 290 string "uw_error(ctx, FATAL, \"Can't prepare max_page_count query for SQLite database\");",
adamc@1115 291 newline],
adamc@1115 292 string "}",
adamc@1115 293 newline,
adamc@1115 294 newline,
adamc@1115 295
adamc@1115 296 string "if (sqlite3_step(stmt) != SQLITE_ROW) {",
adamc@1115 297 newline,
adamc@1115 298 box [string "sqlite3_finalize(stmt);",
adamc@1115 299 newline,
adamc@1115 300 string "sqlite3_close(sqlite);",
adamc@1115 301 newline,
adamc@1115 302 string "uw_error(ctx, FATAL, \"Can't set max_page_count parameter for SQLite database\");",
adamc@1115 303 newline],
adamc@1115 304 string "}",
adamc@1115 305 newline,
adamc@1115 306 newline,
adamc@1115 307
adamc@1115 308 string "sqlite3_finalize(stmt);",
adamc@1115 309 newline],
adamc@1115 310 string "}",
adamc@1115 311 newline,
adamc@1115 312 newline,
adam@1682 313
adamc@885 314 string "conn = calloc(1, sizeof(uw_conn));",
adamc@885 315 newline,
adamc@885 316 string "conn->conn = sqlite;",
adamc@885 317 newline,
adamc@885 318 string "uw_set_db(ctx, conn);",
adamc@885 319 newline,
adamc@885 320 string "uw_db_validate(ctx);",
adamc@885 321 newline,
adamc@885 322 string "uw_db_prepare(ctx);",
adamc@885 323 newline,
adamc@885 324 string "}",
adamc@885 325 newline,
adamc@885 326 newline,
adamc@885 327
adamc@1094 328 string "static void uw_db_close(uw_context ctx) {",
adamc@885 329 newline,
adamc@885 330 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 331 newline,
adamc@885 332 p_list_sepi (box [])
adamc@885 333 (fn i => fn _ =>
adamc@885 334 box [string "if (conn->p",
adamc@885 335 string (Int.toString i),
adamc@885 336 string ") sqlite3_finalize(conn->p",
adamc@885 337 string (Int.toString i),
adamc@885 338 string ");",
adamc@885 339 newline])
adamc@885 340 ss,
adamc@885 341 string "sqlite3_close(conn->conn);",
adamc@885 342 newline,
adamc@885 343 string "}",
adamc@885 344 newline,
adamc@885 345 newline,
adamc@885 346
adam@1936 347 string "static int uw_db_begin(uw_context ctx, int could_write) {",
adamc@885 348 newline,
adamc@885 349 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 350 newline,
adamc@885 351 newline,
adamc@885 352 string "if (sqlite3_exec(conn->conn, \"BEGIN\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 353 newline,
adamc@885 354 box [string "return 0;",
adamc@885 355 newline],
adamc@885 356 string "else {",
adamc@885 357 newline,
adamc@1266 358 box [string "fprintf(stderr, \"Begin error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 359 newline,
adamc@885 360 string "return 1;",
adamc@885 361 newline],
adamc@885 362 string "}",
adamc@885 363 newline,
adamc@885 364 string "}",
adamc@885 365 newline,
adamc@1094 366 string "static int uw_db_commit(uw_context ctx) {",
adamc@885 367 newline,
adamc@885 368 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 369 newline,
adamc@885 370 string "if (sqlite3_exec(conn->conn, \"COMMIT\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 371 newline,
adamc@885 372 box [string "return 0;",
adamc@885 373 newline],
adamc@885 374 string "else {",
adamc@885 375 newline,
adamc@1266 376 box [string "fprintf(stderr, \"Commit error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 377 newline,
adamc@885 378 string "return 1;",
adamc@885 379 newline],
adamc@885 380 string "}",
adamc@885 381 newline,
adamc@885 382 string "}",
adamc@885 383 newline,
adamc@885 384 newline,
adamc@885 385
adamc@1094 386 string "static int uw_db_rollback(uw_context ctx) {",
adamc@885 387 newline,
adamc@885 388 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 389 newline,
adamc@885 390 string "if (sqlite3_exec(conn->conn, \"ROLLBACK\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 391 newline,
adamc@885 392 box [string "return 0;",
adamc@885 393 newline],
adamc@885 394 string "else {",
adamc@885 395 newline,
adamc@1266 396 box [string "fprintf(stderr, \"Rollback error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 397 newline,
adamc@885 398 string "return 1;",
adamc@885 399 newline],
adamc@885 400 string "}",
adamc@885 401 newline,
adamc@885 402 string "}",
adamc@885 403 newline,
adamc@885 404 newline]
adamc@885 405 end
adamc@885 406
adam@1352 407 val fmt = "\"%Y-%m-%d %H:%M:%S\""
adam@1352 408
adamc@885 409 fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
adamc@885 410 let
adamc@885 411 fun p_unsql t =
adamc@885 412 case t of
adamc@885 413 Int => box [string "sqlite3_column_int64(stmt, ", string (Int.toString i), string ")"]
adamc@885 414 | Float => box [string "sqlite3_column_double(stmt, ", string (Int.toString i), string ")"]
adamc@885 415 | String =>
adamc@885 416 if wontLeakStrings then
adamc@1014 417 box [string "(uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string ")"]
adamc@885 418 else
adamc@1014 419 box [string "uw_strdup(ctx, (uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
adamc@1014 420 | Char => box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")[0]"]
adamc@885 421 | Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adam@1352 422 | Time => box [string "uw_Basis_stringToTimef_error(ctx, ",
adam@1352 423 string fmt,
adam@1352 424 string ", (uw_Basis_string)sqlite3_column_text(stmt, ",
adam@1352 425 string (Int.toString i),
adam@1352 426 string "))"]
adamc@885 427 | Blob => box [string "({",
adamc@885 428 newline,
adamc@890 429 string "char *data = (char *)sqlite3_column_blob(stmt, ",
adamc@885 430 string (Int.toString i),
adamc@885 431 string ");",
adamc@885 432 newline,
adamc@890 433 string "int len = sqlite3_column_bytes(stmt, ",
adamc@885 434 string (Int.toString i),
adamc@890 435 string ");",
adamc@890 436 newline,
adamc@890 437 string "uw_Basis_blob b = {len, uw_memdup(ctx, data, len)};",
adamc@885 438 newline,
adamc@885 439 string "b;",
adamc@885 440 newline,
adamc@885 441 string "})"]
adamc@886 442 | Channel => box [string "({",
adamc@886 443 newline,
adamc@886 444 string "sqlite3_int64 n = sqlite3_column_int64(stmt, ",
adamc@886 445 string (Int.toString i),
adamc@886 446 string ");",
adamc@886 447 newline,
adamc@886 448 string "uw_Basis_channel ch = {n >> 32, n & 0xFFFFFFFF};",
adamc@886 449 newline,
adamc@886 450 string "ch;",
adamc@886 451 newline,
adamc@886 452 string "})"]
adamc@885 453 | Client => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adamc@885 454
adamc@885 455 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@885 456
adamc@885 457 fun getter t =
adamc@885 458 case t of
adamc@885 459 Nullable t =>
adamc@885 460 box [string "(sqlite3_column_type(stmt, ",
adamc@885 461 string (Int.toString i),
adamc@885 462 string ") == SQLITE_NULL ? NULL : ",
adamc@885 463 case t of
adamc@885 464 String => getter t
adamc@885 465 | _ => box [string "({",
adamc@885 466 newline,
adamc@885 467 string (p_sql_ctype t),
adamc@885 468 space,
adamc@885 469 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@885 470 string (p_sql_ctype t),
adamc@885 471 string "));",
adamc@885 472 newline,
adamc@885 473 string "*tmp = ",
adamc@885 474 getter t,
adamc@885 475 string ";",
adamc@885 476 newline,
adamc@885 477 string "tmp;",
adamc@885 478 newline,
adamc@885 479 string "})"],
adamc@885 480 string ")"]
adamc@885 481 | _ =>
adamc@885 482 box [string "(sqlite3_column_type(stmt, ",
adamc@885 483 string (Int.toString i),
adamc@885 484 string ") == SQLITE_NULL ? ",
adamc@885 485 box [string "({",
adamc@885 486 string (p_sql_ctype t),
adamc@885 487 space,
adamc@885 488 string "tmp;",
adamc@885 489 newline,
adamc@885 490 string "uw_error(ctx, FATAL, \"",
adamc@885 491 string (ErrorMsg.spanToString loc),
adamc@885 492 string ": Unexpectedly NULL field #",
adamc@885 493 string (Int.toString i),
adamc@885 494 string "\");",
adamc@885 495 newline,
adamc@885 496 string "tmp;",
adamc@885 497 newline,
adamc@885 498 string "})"],
adamc@885 499 string " : ",
adamc@885 500 p_unsql t,
adamc@885 501 string ")"]
adamc@885 502 in
adamc@885 503 getter t
adamc@885 504 end
adamc@885 505
adamc@885 506 fun queryCommon {loc, query, cols, doCols} =
adamc@885 507 box [string "int r;",
adamc@885 508 newline,
adamc@885 509
adamc@885 510 string "sqlite3_reset(stmt);",
adamc@885 511 newline,
adamc@885 512
adamc@885 513 string "uw_end_region(ctx);",
adamc@885 514 newline,
adamc@885 515 string "while ((r = sqlite3_step(stmt)) == SQLITE_ROW) {",
adamc@885 516 newline,
adamc@885 517 doCols p_getcol,
adamc@885 518 string "}",
adamc@885 519 newline,
adamc@885 520 newline,
adamc@885 521
adamc@885 522 string "if (r == SQLITE_BUSY) {",
adamc@885 523 box [string "sleep(1);",
adamc@885 524 newline,
adamc@885 525 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 526 newline],
adamc@885 527 string "}",
adamc@885 528 newline,
adamc@885 529 newline,
adamc@885 530
adamc@885 531 string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
adamc@885 532 string (ErrorMsg.spanToString loc),
adamc@1266 533 string ": query step failed: %s<br />%s\", ",
adamc@885 534 query,
adamc@885 535 string ", sqlite3_errmsg(conn->conn));",
adamc@885 536 newline,
adamc@885 537 newline]
adamc@885 538
adamc@885 539 fun query {loc, cols, doCols} =
adamc@885 540 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 541 newline,
adamc@886 542 string "sqlite3_stmt *stmt;",
adamc@885 543 newline,
adamc@885 544 newline,
adamc@1266 545 string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", sqlite3_errmsg(conn->conn), query);",
adamc@885 546 newline,
adamc@885 547 newline,
adamc@885 548 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 549 newline,
adamc@885 550 newline,
adamc@885 551
adamc@885 552 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
adamc@885 553
adamc@885 554 string "uw_pop_cleanup(ctx);",
adamc@885 555 newline]
adamc@885 556
adamc@1014 557 val p_pre_inputs =
adamc@1014 558 p_list_sepi (box [])
adamc@1014 559 (fn i => fn t =>
adamc@1014 560 case t of
adamc@1014 561 Char => box [string "char arg",
adamc@1014 562 string (Int.toString (i + 1)),
adamc@1014 563 string "s = {arg",
adamc@1014 564 string (Int.toString (i + 1)),
adamc@1014 565 string ", 0};",
adamc@1014 566 newline]
adamc@1014 567 | _ => box [])
adamc@1014 568
adamc@885 569 fun p_inputs loc =
adamc@885 570 p_list_sepi (box [])
adamc@885 571 (fn i => fn t =>
adamc@885 572 let
adamc@885 573 fun bind (t, arg) =
adamc@885 574 case t of
adamc@885 575 Int => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 576 string (Int.toString (i + 1)),
adamc@885 577 string ", ",
adamc@885 578 arg,
adamc@885 579 string ")"]
adamc@885 580 | Float => box [string "sqlite3_bind_double(stmt, ",
adamc@885 581 string (Int.toString (i + 1)),
adamc@885 582 string ", ",
adamc@885 583 arg,
adamc@1014 584 string ")"]
adamc@885 585 | String => box [string "sqlite3_bind_text(stmt, ",
adamc@885 586 string (Int.toString (i + 1)),
adamc@885 587 string ", ",
adamc@885 588 arg,
adamc@885 589 string ", -1, SQLITE_TRANSIENT)"]
adamc@1014 590 | Char => box [string "sqlite3_bind_text(stmt, ",
adamc@1014 591 string (Int.toString (i + 1)),
adamc@1014 592 string ", ",
adamc@1014 593 arg,
adamc@1014 594 string "s, -1, SQLITE_TRANSIENT)"]
adamc@885 595 | Bool => box [string "sqlite3_bind_int(stmt, ",
adamc@885 596 string (Int.toString (i + 1)),
adamc@885 597 string ", ",
adamc@885 598 arg,
adamc@885 599 string ")"]
adamc@887 600 | Time => box [string "sqlite3_bind_text(stmt, ",
adamc@885 601 string (Int.toString (i + 1)),
adam@1359 602 string ", uw_Basis_timef(ctx, ",
adam@1352 603 string fmt,
adam@1352 604 string ", ",
adamc@885 605 arg,
adamc@887 606 string "), -1, SQLITE_TRANSIENT)"]
adamc@885 607 | Blob => box [string "sqlite3_bind_blob(stmt, ",
adamc@885 608 string (Int.toString (i + 1)),
adamc@885 609 string ", ",
adamc@885 610 arg,
adamc@885 611 string ".data, ",
adamc@885 612 arg,
adamc@890 613 string ".size, SQLITE_TRANSIENT)"]
adamc@886 614 | Channel => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 615 string (Int.toString (i + 1)),
adamc@886 616 string ", ((sqlite3_int64)",
adamc@885 617 arg,
adamc@886 618 string ".cli << 32) | ",
adamc@886 619 arg,
adamc@886 620 string ".chn)"]
adamc@885 621 | Client => box [string "sqlite3_bind_int(stmt, ",
adamc@885 622 string (Int.toString (i + 1)),
adamc@885 623 string ", ",
adamc@885 624 arg,
adamc@885 625 string ")"]
adamc@885 626 | Nullable t => box [string "(",
adamc@885 627 arg,
adamc@885 628 string " == NULL ? sqlite3_bind_null(stmt, ",
adamc@885 629 string (Int.toString (i + 1)),
adamc@885 630 string ") : ",
adamc@885 631 bind (t, case t of
adamc@885 632 String => arg
adamc@885 633 | _ => box [string "(*", arg, string ")"]),
adamc@885 634 string ")"]
adamc@885 635 in
adamc@885 636 box [string "if (",
adamc@885 637 bind (t, box [string "arg", string (Int.toString (i + 1))]),
adamc@885 638 string " != SQLITE_OK) uw_error(ctx, FATAL, \"",
adamc@885 639 string (ErrorMsg.spanToString loc),
adamc@885 640 string ": Error binding parameter #",
adamc@885 641 string (Int.toString (i + 1)),
adamc@885 642 string ": %s\", sqlite3_errmsg(conn->conn));",
adamc@885 643 newline]
adamc@885 644 end)
adamc@885 645
adamc@885 646 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
adamc@885 647 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 648 newline,
adamc@1014 649 p_pre_inputs inputs,
adamc@885 650 if nested then
adamc@885 651 box [string "sqlite3_stmt *stmt;",
adamc@885 652 newline]
adamc@885 653 else
adamc@885 654 box [string "sqlite3_stmt *stmt = conn->p",
adamc@885 655 string (Int.toString id),
adamc@885 656 string ";",
adamc@885 657 newline,
adamc@885 658 newline,
adamc@885 659
adamc@885 660 string "if (stmt == NULL) {",
adamc@885 661 newline],
adamc@885 662
adamc@885 663 string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 664 string (Prim.toCString query),
adamc@885 665 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adam@1656 666 string (Prim.toCString query),
adamc@1266 667 string "<br />%s\", sqlite3_errmsg(conn->conn));",
adamc@885 668 newline,
adamc@885 669 if nested then
adamc@885 670 box [string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 671 newline]
adamc@885 672 else
adamc@885 673 box [string "conn->p",
adamc@885 674 string (Int.toString id),
adamc@885 675 string " = stmt;",
adamc@885 676 newline,
adamc@885 677 string "}",
adamc@885 678 newline,
adamc@885 679 newline,
adamc@885 680 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 681 newline,
adamc@885 682 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 683 newline],
adamc@885 684 newline,
adamc@885 685
adamc@885 686 p_inputs loc inputs,
adamc@885 687 newline,
adamc@885 688
adamc@885 689 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
adam@1656 690 string (Prim.toCString query),
adamc@885 691 string "\""]},
adamc@885 692
adamc@885 693 string "uw_pop_cleanup(ctx);",
adamc@885 694 newline,
adamc@885 695 if nested then
adamc@885 696 box []
adamc@885 697 else
adamc@885 698 box [string "uw_pop_cleanup(ctx);",
adamc@885 699 newline]]
adamc@885 700
adam@1293 701 fun dmlCommon {loc, dml, mode} =
adamc@885 702 box [string "int r;",
adamc@885 703 newline,
adamc@885 704
adamc@885 705 string "if ((r = sqlite3_step(stmt)) == SQLITE_BUSY) {",
adamc@885 706 box [string "sleep(1);",
adamc@885 707 newline,
adamc@885 708 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 709 newline],
adamc@885 710 string "}",
adamc@885 711 newline,
adamc@885 712 newline,
adamc@885 713
adam@1293 714 string "if (r != SQLITE_DONE) ",
adam@1293 715 case mode of
adam@1293 716 Settings.Error => box [string "uw_error(ctx, FATAL, \"",
adam@1293 717 string (ErrorMsg.spanToString loc),
adam@1293 718 string ": DML step failed: %s<br />%s\", ",
adam@1293 719 dml,
adam@1293 720 string ", sqlite3_errmsg(conn->conn));"]
adam@1295 721 | Settings.None => string "uw_set_error_message(ctx, sqlite3_errmsg(conn->conn));",
adamc@885 722 newline]
adamc@885 723
adam@1293 724 fun dml (loc, mode) =
adamc@885 725 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 726 newline,
adamc@886 727 string "sqlite3_stmt *stmt;",
adamc@885 728 newline,
adamc@885 729 newline,
adamc@1266 730 string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", dml, sqlite3_errmsg(conn->conn));",
adamc@885 731 newline,
adamc@885 732 newline,
adamc@885 733 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 734 newline,
adamc@885 735 newline,
adamc@885 736
adam@1293 737 dmlCommon {loc = loc, dml = string "dml", mode = mode},
adamc@885 738
adamc@885 739 string "uw_pop_cleanup(ctx);",
adamc@885 740 newline]
adamc@885 741
adam@1293 742 fun dmlPrepared {loc, id, dml, inputs, mode = mode} =
adamc@885 743 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 744 newline,
adamc@1014 745 p_pre_inputs inputs,
adamc@885 746 string "sqlite3_stmt *stmt = conn->p",
adamc@885 747 string (Int.toString id),
adamc@885 748 string ";",
adamc@885 749 newline,
adamc@885 750 newline,
adamc@885 751
adamc@885 752 string "if (stmt == NULL) {",
adamc@885 753 newline,
adamc@885 754 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 755 string (Prim.toCString dml),
adamc@885 756 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adam@1656 757 string (Prim.toCString dml),
adamc@1266 758 string "<br />%s\", sqlite3_errmsg(conn->conn));",
adamc@885 759 newline,
adamc@885 760 string "conn->p",
adamc@885 761 string (Int.toString id),
adamc@885 762 string " = stmt;",
adamc@885 763 newline],
adamc@885 764 string "}",
adamc@885 765 newline,
adamc@885 766
adamc@885 767 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 768 newline,
adamc@885 769 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 770 newline,
adamc@885 771
adamc@885 772 p_inputs loc inputs,
adamc@885 773 newline,
adamc@885 774
adamc@885 775 dmlCommon {loc = loc, dml = box [string "\"",
adam@1656 776 string (Prim.toCString dml),
adam@1293 777 string "\""], mode = mode},
adamc@885 778
adamc@885 779 string "uw_pop_cleanup(ctx);",
adamc@885 780 newline,
adamc@885 781 string "uw_pop_cleanup(ctx);",
adamc@885 782 newline]
adamc@885 783
adamc@885 784 fun nextval {loc, seqE, seqName} =
adamc@885 785 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 786 newline,
adamc@885 787 string "char *insert = ",
adamc@885 788 case seqName of
adamc@886 789 SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES (NULL)\"")
adamc@885 790 | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ",
adamc@885 791 seqE,
adamc@885 792 string ", \" VALUES ()\"))"],
adamc@885 793 string ";",
adamc@885 794 newline,
adamc@885 795 string "char *delete = ",
adamc@885 796 case seqName of
adamc@885 797 SOME s => string ("\"DELETE FROM " ^ s ^ "\"")
adamc@885 798 | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ",
adamc@885 799 seqE,
adamc@885 800 string ")"],
adamc@885 801 string ";",
adamc@885 802 newline,
adamc@885 803 newline,
adamc@885 804
adamc@886 805 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 806 newline,
adamc@885 807 string "n = sqlite3_last_insert_rowid(conn->conn);",
adamc@885 808 newline,
adamc@886 809 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 810 newline]
adamc@885 811
adamc@885 812 fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
adamc@1073 813 fun setval _ = raise Fail "SQLite.setval called"
adamc@885 814
adamc@885 815 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
adam@1285 816 | #"\000" => ""
adam@1285 817 | ch => str ch)
adam@1285 818 s ^ "'"
adamc@885 819
adamc@885 820 fun p_cast (s, _) = s
adamc@885 821
adamc@885 822 fun p_blank _ = "?"
adamc@885 823
adamc@885 824 val () = addDbms {name = "sqlite",
adam@1682 825 randomFunction = "RANDOM",
adam@1464 826 header = Config.sqheader,
adamc@885 827 link = "-lsqlite3",
adamc@885 828 init = init,
adamc@885 829 p_sql_type = p_sql_type,
adamc@885 830 query = query,
adamc@885 831 queryPrepared = queryPrepared,
adamc@885 832 dml = dml,
adamc@885 833 dmlPrepared = dmlPrepared,
adamc@885 834 nextval = nextval,
adamc@885 835 nextvalPrepared = nextvalPrepared,
adamc@1073 836 setval = setval,
adamc@885 837 sqlifyString = sqlifyString,
adamc@885 838 p_cast = p_cast,
adamc@885 839 p_blank = p_blank,
adamc@885 840 supportsDeleteAs = false,
adamc@886 841 supportsUpdateAs = false,
adamc@886 842 createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTOINCREMENT)",
adamc@885 843 textKeysNeedLengths = false,
adamc@885 844 supportsNextval = false,
adamc@885 845 supportsNestedPrepared = false,
adamc@890 846 sqlPrefix = "",
adamc@1014 847 supportsOctetLength = false,
adamc@1014 848 trueString = "1",
adamc@1196 849 falseString = "0",
adamc@1196 850 onlyUnion = false,
adam@1777 851 nestedRelops = false,
adam@1777 852 windowFunctions = false}
adamc@885 853
adamc@885 854 end