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 fry
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 db.private sequences.deep ;
12 TUPLE: sqlite-db path ;
14 : <sqlite-db> ( path -- sqlite-db )
20 TUPLE: sqlite-db-connection < db-connection ;
22 : <sqlite-db-connection> ( handle -- db-connection )
23 sqlite-db-connection new-db-connection
28 M: sqlite-db db-open ( db -- db-connection )
29 path>> sqlite-open <sqlite-db-connection> ;
31 M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
33 TUPLE: sqlite-statement < statement ;
35 TUPLE: sqlite-result-set < result-set has-more? ;
37 M: sqlite-db-connection <simple-statement> ( str in out -- obj )
38 <prepared-statement> ;
40 M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
41 sqlite-statement new-statement ;
43 : sqlite-maybe-prepare ( statement -- statement )
45 db-connection get handle>> over sql>> sqlite-prepare
49 M: sqlite-statement dispose ( statement -- )
51 [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
53 M: sqlite-result-set dispose ( result-set -- )
56 : reset-bindings ( statement -- )
58 handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
60 M: sqlite-statement low-level-bind ( statement -- )
61 [ handle>> ] [ bind-params>> ] bi
62 [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
64 M: sqlite-statement bind-statement* ( statement -- )
66 dup bound?>> [ dup reset-bindings ] when
69 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
71 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
72 : <sqlite-low-level-binding> ( key value type -- obj )
73 sqlite-low-level-binding new
78 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
79 [ column-name>> ":" prepend ]
80 [ slot-name>> rot get-slot-named ]
81 [ type>> ] tri <sqlite-low-level-binding> ;
83 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
84 nip [ key>> ] [ value>> ] [ type>> ] tri
85 <sqlite-low-level-binding> ;
87 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
89 [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
91 [ [ key>> ] [ type>> ] bi ] dip
92 swap <sqlite-low-level-binding> ;
94 M: sqlite-statement bind-tuple ( tuple statement -- )
96 in-params>> [ sqlite-bind-conversion ] with map
97 ] keep bind-statement ;
99 ERROR: sqlite-last-id-fail ;
101 : last-insert-id ( -- id )
102 db-connection get handle>> sqlite3_last_insert_rowid
103 dup zero? [ sqlite-last-id-fail ] when ;
105 M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
106 execute-statement last-insert-id swap set-primary-key ;
108 M: sqlite-result-set #columns ( result-set -- n )
109 handle>> sqlite-#columns ;
111 M: sqlite-result-set row-column ( result-set n -- obj )
112 [ handle>> ] [ sqlite-column ] bi* ;
114 M: sqlite-result-set row-column-typed ( result-set n -- obj )
115 dup pick out-params>> nth type>>
116 [ handle>> ] 2dip sqlite-column-typed ;
118 M: sqlite-result-set advance-row ( result-set -- )
119 dup handle>> sqlite-next >>has-more? drop ;
121 M: sqlite-result-set more-rows? ( result-set -- ? )
124 M: sqlite-statement query-results ( query -- result-set )
126 dup handle>> sqlite-result-set new-result-set
129 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
133 remove-db-assigned-id
134 dup [ ", " 0% ] [ column-name>> 0% ] interleave
137 dup type>> +random-id+ = [
140 column-name>> ":" prepend dup 0%
142 ] [ type>> ] tri <generator-bind> 1,
150 M: sqlite-db-connection <insert-user-assigned-statement> ( tuple -- statement )
151 <insert-db-assigned-statement> ;
153 M: sqlite-db-connection bind# ( spec obj -- )
155 [ column-name>> ":" next-sql-counter surround dup 0% ]
157 ] dip <literal-bind> 1, ;
159 M: sqlite-db-connection bind% ( spec -- )
160 dup 1, column-name>> ":" prepend 0% ;
162 M: sqlite-db-connection persistent-table ( -- assoc )
164 { +db-assigned-id+ { "integer" "integer" f } }
165 { +user-assigned-id+ { f f f } }
166 { +random-id+ { "integer" "integer" f } }
167 { +foreign-id+ { "integer" "integer" "references" } }
169 { +on-update+ { f f "on update" } }
170 { +on-delete+ { f f "on delete" } }
171 { +restrict+ { f f "restrict" } }
172 { +cascade+ { f f "cascade" } }
173 { +set-null+ { f f "set null" } }
174 { +set-default+ { f f "set default" } }
176 { BOOLEAN { "boolean" "boolean" f } }
177 { INTEGER { "integer" "integer" f } }
178 { BIG-INTEGER { "bigint" "bigint" f } }
179 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
180 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
181 { TEXT { "text" "text" f } }
182 { VARCHAR { "text" "text" f } }
183 { DATE { "date" "date" f } }
184 { TIME { "time" "time" f } }
185 { DATETIME { "datetime" "datetime" f } }
186 { TIMESTAMP { "timestamp" "timestamp" f } }
187 { DOUBLE { "real" "real" f } }
188 { BLOB { "blob" "blob" f } }
189 { FACTOR-BLOB { "blob" "blob" f } }
190 { URL { "text" "text" f } }
191 { +autoincrement+ { f f "autoincrement" } }
192 { +unique+ { f f "unique" } }
193 { +default+ { f f "default" } }
194 { +null+ { f f "null" } }
195 { +not-null+ { f f "not null" } }
196 { system-random-generator { f f f } }
197 { secure-random-generator { f f f } }
198 { random-generator { f f f } }
201 : insert-trigger ( -- string )
204 CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
205 BEFORE INSERT ON ${table-name}
207 SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
208 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
211 ] with-string-writer ;
213 : insert-trigger-not-null ( -- string )
216 CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
217 BEFORE INSERT ON ${table-name}
219 SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
220 WHERE NEW.${foreign-table-id} IS NOT NULL
221 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
224 ] with-string-writer ;
226 : drop-insert-trigger ( -- string )
229 DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
231 ] with-string-writer ;
233 : update-trigger ( -- string )
236 CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
237 BEFORE UPDATE ON ${table-name}
239 SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
240 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
243 ] with-string-writer ;
245 : update-trigger-not-null ( -- string )
248 CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
249 BEFORE UPDATE ON ${table-name}
251 SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
252 WHERE NEW.${foreign-table-id} IS NOT NULL
253 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
256 ] with-string-writer ;
258 : drop-update-trigger ( -- string )
261 DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
263 ] with-string-writer ;
265 : delete-trigger-restrict ( -- string )
268 CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
269 BEFORE DELETE ON ${foreign-table-name}
271 SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
272 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
275 ] with-string-writer ;
277 : drop-delete-trigger-restrict ( -- string )
280 DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
282 ] with-string-writer ;
284 : delete-trigger-cascade ( -- string )
287 CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
288 BEFORE DELETE ON ${foreign-table-name}
290 DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
293 ] with-string-writer ;
295 : drop-delete-trigger-cascade ( -- string )
298 DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
300 ] with-string-writer ;
302 : can-be-null? ( -- ? )
303 "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
305 : delete-cascade? ( -- ? )
306 "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
308 : sqlite-trigger, ( string -- )
309 { } { } <simple-statement> 3, ;
311 : create-sqlite-triggers ( -- )
313 insert-trigger sqlite-trigger,
314 update-trigger sqlite-trigger,
316 insert-trigger-not-null sqlite-trigger,
317 update-trigger-not-null sqlite-trigger,
320 delete-trigger-cascade sqlite-trigger,
322 delete-trigger-restrict sqlite-trigger,
325 : drop-sqlite-triggers ( -- )
326 drop-insert-trigger sqlite-trigger,
327 drop-update-trigger sqlite-trigger,
329 drop-delete-trigger-cascade sqlite-trigger,
331 drop-delete-trigger-restrict sqlite-trigger,
334 : db-triggers ( sql-specs word -- )
336 [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
338 [ class>> db-table-name "db-table" set ]
339 [ column-name>> "table-id" set ]
341 modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
343 [ second db-table-name "foreign-table-name" set ]
344 [ third "foreign-table-id" set ] bi
351 : sqlite-create-table ( sql-specs class-name -- )
353 "create table " 0% 0%
356 dup column-name>> [ "table-id" set ] [ 0% ] bi
358 dup type>> lookup-create-type 0%
366 [ "," 0% ] [ column-name>> 0% ] interleave
372 M: sqlite-db-connection create-sql-statement ( class -- statement )
375 [ sqlite-create-table ]
376 [ drop \ create-sqlite-triggers db-triggers ] 2bi
379 M: sqlite-db-connection drop-sql-statement ( class -- statements )
381 [ nip "drop table " 0% 0% ";" 0% ]
382 [ drop \ drop-sqlite-triggers db-triggers ] 2bi
385 M: sqlite-db-connection compound ( string seq -- new-string )
387 { "default" [ first number>string " " glue ] }
388 { "references" [ >reference-string ] }