basis/db/sqlite/sqlite.factor

   1 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays assocs classes compiler db hashtables
   4 io.files kernel math math.parser namespaces prettyprint
   5 sequences strings classes.tuple alien.c-types continuations
   6 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
   7 math.intervals io nmake accessors vectors math.ranges random
   8 math.bitwise db.queries destructors db.tuples.private interpolate
   9 io.streams.string multiline make db.private ;
  10 IN: db.sqlite
  11
  12 TUPLE: sqlite-db path ;
  13
  14 : <sqlite-db> ( path -- sqlite-db )
  15     sqlite-db new
  16         swap >>path ;
  17
  18 <PRIVATE
  19
  20 TUPLE: sqlite-db-connection < db-connection ;
  21
  22 : <sqlite-db-connection> ( handle -- db-connection )
  23     sqlite-db-connection new-db-connection
  24         swap >>handle ;
  25
  26 PRIVATE>
  27
  28 M: sqlite-db db-open ( db -- db-connection )
  29     path>> sqlite-open <sqlite-db-connection> ;
  30
  31 M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
  32
  33 TUPLE: sqlite-statement < statement ;
  34
  35 TUPLE: sqlite-result-set < result-set has-more? ;
  36
  37 M: sqlite-db-connection <simple-statement> ( str in out -- obj )
  38     <prepared-statement> ;
  39
  40 M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
  41     sqlite-statement new-statement ;
  42
  43 : sqlite-maybe-prepare ( statement -- statement )
  44     dup handle>> [
  45         db-connection get handle>> over sql>> sqlite-prepare
  46         >>handle
  47     ] unless ;
  48
  49 M: sqlite-statement dispose ( statement -- )
  50     handle>>
  51     [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
  52
  53 M: sqlite-result-set dispose ( result-set -- )
  54     f >>handle drop ;
  55
  56 : reset-bindings ( statement -- )
  57     sqlite-maybe-prepare
  58     handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
  59
  60 M: sqlite-statement low-level-bind ( statement -- )
  61     [ handle>> ] [ bind-params>> ] bi
  62     [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
  63
  64 M: sqlite-statement bind-statement* ( statement -- )
  65     sqlite-maybe-prepare
  66     dup bound?>> [ dup reset-bindings ] when
  67     low-level-bind ;
  68
  69 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
  70
  71 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
  72 : <sqlite-low-level-binding> ( key value type -- obj )
  73     sqlite-low-level-binding new
  74         swap >>type
  75         swap >>value
  76         swap >>key ;
  77
  78 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
  79     [ column-name>> ":" prepend ]
  80     [ slot-name>> rot get-slot-named ]
  81     [ type>> ] tri <sqlite-low-level-binding> ;
  82
  83 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
  84     nip [ key>> ] [ value>> ] [ type>> ] tri
  85     <sqlite-low-level-binding> ;
  86
  87 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
  88     tuck
  89     [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
  90     rot set-slot-named
  91     [ [ key>> ] [ type>> ] bi ] dip
  92     swap <sqlite-low-level-binding> ;
  93
  94 M: sqlite-statement bind-tuple ( tuple statement -- )
  95     [
  96         in-params>> [ sqlite-bind-conversion ] with map
  97     ] keep bind-statement ;
  98
  99 ERROR: sqlite-last-id-fail ;
 100
 101 : last-insert-id ( -- id )
 102     db-connection get handle>> sqlite3_last_insert_rowid
 103     dup zero? [ sqlite-last-id-fail ] when ;
 104
 105 M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
 106     execute-statement last-insert-id swap set-primary-key ;
 107
 108 M: sqlite-result-set #columns ( result-set -- n )
 109     handle>> sqlite-#columns ;
 110
 111 M: sqlite-result-set row-column ( result-set n -- obj )
 112     [ handle>> ] [ sqlite-column ] bi* ;
 113
 114 M: sqlite-result-set row-column-typed ( result-set n -- obj )
 115     dup pick out-params>> nth type>>
 116     [ handle>> ] 2dip sqlite-column-typed ;
 117
 118 M: sqlite-result-set advance-row ( result-set -- )
 119     dup handle>> sqlite-next >>has-more? drop ;
 120
 121 M: sqlite-result-set more-rows? ( result-set -- ? )
 122     has-more?>> ;
 123
 124 M: sqlite-statement query-results ( query -- result-set )
 125     sqlite-maybe-prepare
 126     dup handle>> sqlite-result-set new-result-set
 127     dup advance-row ;
 128
 129 M: sqlite-db-connection create-sql-statement ( class -- statement )
 130     [
 131         dupd
 132         "create table " 0% 0%
 133         "(" 0% [ ", " 0% ] [
 134             dup "sql-spec" set
 135             dup column-name>> [ "table-id" set ] [ 0% ] bi
 136             " " 0%
 137             dup type>> lookup-create-type 0%
 138             modifiers 0%
 139         ] interleave
 140
 141         ", " 0%
 142         find-primary-key
 143         "primary key(" 0%
 144         [ "," 0% ] [ column-name>> 0% ] interleave
 145         "));" 0%
 146     ] query-make ;
 147
 148 M: sqlite-db-connection drop-sql-statement ( class -- statement )
 149     [ "drop table " 0% 0% ";" 0% drop ] query-make ;
 150
 151 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
 152     [
 153         "insert into " 0% 0%
 154         "(" 0%
 155         remove-db-assigned-id
 156         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 157         ") values(" 0%
 158         [ ", " 0% ] [
 159             dup type>> +random-id+ = [
 160                 [ slot-name>> ]
 161                 [
 162                     column-name>> ":" prepend dup 0%
 163                     random-id-generator
 164                 ] [ type>> ] tri <generator-bind> 1,
 165             ] [
 166                 bind%
 167             ] if
 168         ] interleave
 169         ");" 0%
 170     ] query-make ;
 171
 172 M: sqlite-db-connection <insert-user-assigned-statement> ( tuple -- statement )
 173     <insert-db-assigned-statement> ;
 174
 175 M: sqlite-db-connection bind# ( spec obj -- )
 176     [
 177         [ column-name>> ":" next-sql-counter surround dup 0% ]
 178         [ type>> ] bi
 179     ] dip <literal-bind> 1, ;
 180
 181 M: sqlite-db-connection bind% ( spec -- )
 182     dup 1, column-name>> ":" prepend 0% ;
 183
 184 M: sqlite-db-connection persistent-table ( -- assoc )
 185     H{
 186         { +db-assigned-id+ { "integer" "integer" f } }
 187         { +user-assigned-id+ { f f f } }
 188         { +random-id+ { "integer" "integer" f } }
 189         { +foreign-id+ { "integer" "integer" "references" } }
 190
 191         { +on-update+ { f f "on update" } }
 192         { +on-delete+ { f f "on delete" } }
 193         { +restrict+ { f f "restrict" } }
 194         { +cascade+ { f f "cascade" } }
 195         { +set-null+ { f f "set null" } }
 196         { +set-default+ { f f "set default" } }
 197
 198         { BOOLEAN { "boolean" "boolean" f } }
 199         { INTEGER { "integer" "integer" f } }
 200         { BIG-INTEGER { "bigint" "bigint" f } }
 201         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 202         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 203         { TEXT { "text" "text" f } }
 204         { VARCHAR { "text" "text" f } }
 205         { DATE { "date" "date" f } }
 206         { TIME { "time" "time" f } }
 207         { DATETIME { "datetime" "datetime" f } }
 208         { TIMESTAMP { "timestamp" "timestamp" f } }
 209         { DOUBLE { "real" "real" f } }
 210         { BLOB { "blob" "blob" f } }
 211         { FACTOR-BLOB { "blob" "blob" f } }
 212         { URL { "text" "text" f } }
 213         { +autoincrement+ { f f "autoincrement" } }
 214         { +unique+ { f f "unique" } }
 215         { +default+ { f f "default" } }
 216         { +null+ { f f "null" } }
 217         { +not-null+ { f f "not null" } }
 218         { system-random-generator { f f f } }
 219         { secure-random-generator { f f f } }
 220         { random-generator { f f f } }
 221     } ;
 222
 223 : insert-trigger ( -- string )
 224     [
 225     <"
 226         CREATE TRIGGER fki_${table}_${foreign-table}_id
 227         BEFORE INSERT ON ${table}
 228         FOR EACH ROW BEGIN
 229             SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
 230             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 231         END;
 232     "> interpolate
 233     ] with-string-writer ;
 234
 235 : insert-trigger-not-null ( -- string )
 236     [
 237     <"
 238         CREATE TRIGGER fki_${table}_${foreign-table}_id
 239         BEFORE INSERT ON ${table}
 240         FOR EACH ROW BEGIN
 241             SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
 242             WHERE NEW.${foreign-table-id} IS NOT NULL
 243                 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 244         END;
 245     "> interpolate
 246     ] with-string-writer ;
 247
 248 : update-trigger ( -- string )
 249     [
 250     <"
 251         CREATE TRIGGER fku_${table}_${foreign-table}_id
 252         BEFORE UPDATE ON ${table}
 253         FOR EACH ROW BEGIN
 254             SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
 255             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 256         END;
 257     "> interpolate
 258     ] with-string-writer ;
 259
 260 : update-trigger-not-null ( -- string )
 261     [
 262     <"
 263         CREATE TRIGGER fku_${table}_${foreign-table}_id
 264         BEFORE UPDATE ON ${table}
 265         FOR EACH ROW BEGIN
 266             SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
 267             WHERE NEW.${foreign-table-id} IS NOT NULL
 268                 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 269         END;
 270     "> interpolate
 271     ] with-string-writer ;
 272
 273 : delete-trigger-restrict ( -- string )
 274     [
 275     <"
 276         CREATE TRIGGER fkd_${table}_${foreign-table}_id
 277         BEFORE DELETE ON ${foreign-table}
 278         FOR EACH ROW BEGIN
 279             SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
 280             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
 281         END;
 282     "> interpolate
 283     ] with-string-writer ;
 284
 285 : delete-trigger-cascade ( -- string )
 286     [
 287     <"
 288         CREATE TRIGGER fkd_${table}_${foreign-table}_id
 289         BEFORE DELETE ON ${foreign-table}
 290         FOR EACH ROW BEGIN
 291             DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
 292         END;
 293     "> interpolate
 294     ] with-string-writer ;
 295
 296 : can-be-null? ( -- ? )
 297     "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
 298
 299 : delete-cascade? ( -- ? )
 300     "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
 301
 302 : sqlite-trigger, ( string -- )
 303     { } { } <simple-statement> 3, ;
 304
 305 : create-sqlite-triggers ( -- )
 306     can-be-null? [
 307         insert-trigger sqlite-trigger,
 308         update-trigger sqlite-trigger,
 309     ] [
 310         insert-trigger-not-null sqlite-trigger,
 311         update-trigger-not-null sqlite-trigger,
 312     ] if
 313     delete-cascade? [
 314         delete-trigger-cascade sqlite-trigger,
 315     ] [
 316         delete-trigger-restrict sqlite-trigger,
 317     ] if ;
 318
 319 M: sqlite-db-connection compound ( string seq -- new-string )
 320     over {
 321         { "default" [ first number>string " " glue ] }
 322         { "references" [
 323             [ >reference-string ] keep
 324             first2 [ "foreign-table" set ]
 325             [ "foreign-table-id" set ] bi*
 326             create-sqlite-triggers
 327         ] }
 328         [ 2drop ]
 329     } case ;