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