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