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