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