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 ;
12 TUPLE: sqlite-db < db path ;
14 : <sqlite-db> ( path -- sqlite-db )
18 M: sqlite-db db-open ( db -- db )
19 dup path>> sqlite-open >>handle ;
21 M: sqlite-db db-close ( handle -- ) sqlite-close ;
23 TUPLE: sqlite-statement < statement ;
25 TUPLE: sqlite-result-set < result-set has-more? ;
27 M: sqlite-db <simple-statement> ( str in out -- obj )
28 <prepared-statement> ;
30 M: sqlite-db <prepared-statement> ( str in out -- obj )
31 sqlite-statement new-statement ;
33 : sqlite-maybe-prepare ( statement -- statement )
35 db get handle>> over sql>> sqlite-prepare
39 M: sqlite-statement dispose ( statement -- )
41 [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
43 M: sqlite-result-set dispose ( result-set -- )
46 : reset-bindings ( statement -- )
48 handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
50 M: sqlite-statement low-level-bind ( statement -- )
51 [ handle>> ] [ bind-params>> ] bi
52 [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
54 M: sqlite-statement bind-statement* ( statement -- )
56 dup bound?>> [ dup reset-bindings ] when
59 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
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
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> ;
73 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
74 nip [ key>> ] [ value>> ] [ type>> ] tri
75 <sqlite-low-level-binding> ;
77 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
79 [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
81 [ [ key>> ] [ type>> ] bi ] dip
82 swap <sqlite-low-level-binding> ;
84 M: sqlite-statement bind-tuple ( tuple statement -- )
86 in-params>> [ sqlite-bind-conversion ] with map
87 ] keep bind-statement ;
89 ERROR: sqlite-last-id-fail ;
91 : last-insert-id ( -- id )
92 db get handle>> sqlite3_last_insert_rowid
93 dup zero? [ sqlite-last-id-fail ] when ;
95 M: sqlite-db insert-tuple-set-key ( tuple statement -- )
96 execute-statement last-insert-id swap set-primary-key ;
98 M: sqlite-result-set #columns ( result-set -- n )
99 handle>> sqlite-#columns ;
101 M: sqlite-result-set row-column ( result-set n -- obj )
102 [ handle>> ] [ sqlite-column ] bi* ;
104 M: sqlite-result-set row-column-typed ( result-set n -- obj )
105 dup pick out-params>> nth type>>
106 [ handle>> ] 2dip sqlite-column-typed ;
108 M: sqlite-result-set advance-row ( result-set -- )
109 dup handle>> sqlite-next >>has-more? drop ;
111 M: sqlite-result-set more-rows? ( result-set -- ? )
114 M: sqlite-statement query-results ( query -- result-set )
116 dup handle>> sqlite-result-set new-result-set
119 M: sqlite-db create-sql-statement ( class -- statement )
122 "create table " 0% 0%
125 dup column-name>> [ "table-id" set ] [ 0% ] bi
127 dup type>> lookup-create-type 0%
134 [ "," 0% ] [ column-name>> 0% ] interleave
138 M: sqlite-db drop-sql-statement ( class -- statement )
139 [ "drop table " 0% 0% ";" 0% drop ] query-make ;
141 M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
145 remove-db-assigned-id
146 dup [ ", " 0% ] [ column-name>> 0% ] interleave
149 dup type>> +random-id+ = [
152 column-name>> ":" prepend dup 0%
154 ] [ type>> ] tri <generator-bind> 1,
162 M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
163 <insert-db-assigned-statement> ;
165 M: sqlite-db bind# ( spec obj -- )
167 [ column-name>> ":" next-sql-counter surround dup 0% ]
169 ] dip <literal-bind> 1, ;
171 M: sqlite-db bind% ( spec -- )
172 dup 1, column-name>> ":" prepend 0% ;
174 M: sqlite-db persistent-table ( -- assoc )
176 { +db-assigned-id+ { "integer" "integer" f } }
177 { +user-assigned-id+ { f f f } }
178 { +random-id+ { "integer" "integer" f } }
179 { +foreign-id+ { "integer" "integer" "references" } }
181 { +on-update+ { f f "on update" } }
182 { +on-delete+ { f f "on delete" } }
183 { +restrict+ { f f "restrict" } }
184 { +cascade+ { f f "cascade" } }
185 { +set-null+ { f f "set null" } }
186 { +set-default+ { f f "set default" } }
188 { BOOLEAN { "boolean" "boolean" f } }
189 { INTEGER { "integer" "integer" f } }
190 { BIG-INTEGER { "bigint" "bigint" f } }
191 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
192 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
193 { TEXT { "text" "text" f } }
194 { VARCHAR { "text" "text" f } }
195 { DATE { "date" "date" f } }
196 { TIME { "time" "time" f } }
197 { DATETIME { "datetime" "datetime" f } }
198 { TIMESTAMP { "timestamp" "timestamp" f } }
199 { DOUBLE { "real" "real" f } }
200 { BLOB { "blob" "blob" f } }
201 { FACTOR-BLOB { "blob" "blob" f } }
202 { URL { "text" "text" f } }
203 { +autoincrement+ { f f "autoincrement" } }
204 { +unique+ { f f "unique" } }
205 { +default+ { f f "default" } }
206 { +null+ { f f "null" } }
207 { +not-null+ { f f "not null" } }
208 { system-random-generator { f f f } }
209 { secure-random-generator { f f f } }
210 { random-generator { f f f } }
213 : insert-trigger ( -- string )
216 CREATE TRIGGER fki_${table}_${foreign-table}_id
217 BEFORE INSERT ON ${table}
219 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
220 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
223 ] with-string-writer ;
225 : insert-trigger-not-null ( -- string )
228 CREATE TRIGGER fki_${table}_${foreign-table}_id
229 BEFORE INSERT ON ${table}
231 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
232 WHERE NEW.${foreign-table-id} IS NOT NULL
233 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
236 ] with-string-writer ;
238 : update-trigger ( -- string )
241 CREATE TRIGGER fku_${table}_${foreign-table}_id
242 BEFORE UPDATE ON ${table}
244 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
245 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
248 ] with-string-writer ;
250 : update-trigger-not-null ( -- string )
253 CREATE TRIGGER fku_${table}_${foreign-table}_id
254 BEFORE UPDATE ON ${table}
256 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
257 WHERE NEW.${foreign-table-id} IS NOT NULL
258 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
261 ] with-string-writer ;
263 : delete-trigger-restrict ( -- string )
266 CREATE TRIGGER fkd_${table}_${foreign-table}_id
267 BEFORE DELETE ON ${foreign-table}
269 SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
270 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
273 ] with-string-writer ;
275 : delete-trigger-cascade ( -- string )
278 CREATE TRIGGER fkd_${table}_${foreign-table}_id
279 BEFORE DELETE ON ${foreign-table}
281 DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
284 ] with-string-writer ;
286 : can-be-null? ( -- ? )
287 "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
289 : delete-cascade? ( -- ? )
290 "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
292 : sqlite-trigger, ( string -- )
293 { } { } <simple-statement> 3, ;
295 : create-sqlite-triggers ( -- )
297 insert-trigger sqlite-trigger,
298 update-trigger sqlite-trigger,
300 insert-trigger-not-null sqlite-trigger,
301 update-trigger-not-null sqlite-trigger,
304 delete-trigger-cascade sqlite-trigger,
306 delete-trigger-restrict sqlite-trigger,
309 M: sqlite-db compound ( string seq -- new-string )
311 { "default" [ first number>string " " glue ] }
313 [ >reference-string ] keep
314 first2 [ "foreign-table" set ]
315 [ "foreign-table-id" set ] bi*
316 create-sqlite-triggers