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 ;
22 M: sqlite-db dispose ( db -- ) db-dispose ;
24 TUPLE: sqlite-statement < statement ;
26 TUPLE: sqlite-result-set < result-set has-more? ;
28 M: sqlite-db <simple-statement> ( str in out -- obj )
29 <prepared-statement> ;
31 M: sqlite-db <prepared-statement> ( str in out -- obj )
32 sqlite-statement new-statement ;
34 : sqlite-maybe-prepare ( statement -- statement )
36 db get handle>> over sql>> sqlite-prepare
40 M: sqlite-statement dispose ( statement -- )
42 [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
44 M: sqlite-result-set dispose ( result-set -- )
47 : reset-bindings ( statement -- )
49 handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
51 M: sqlite-statement low-level-bind ( statement -- )
52 [ bind-params>> ] [ handle>> ] bi
53 [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
55 M: sqlite-statement bind-statement* ( statement -- )
57 dup bound?>> [ dup reset-bindings ] when
60 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
62 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
63 : <sqlite-low-level-binding> ( key value type -- obj )
64 sqlite-low-level-binding new
69 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
70 [ column-name>> ":" prepend ]
71 [ slot-name>> rot get-slot-named ]
72 [ type>> ] tri <sqlite-low-level-binding> ;
74 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
75 nip [ key>> ] [ value>> ] [ type>> ] tri
76 <sqlite-low-level-binding> ;
78 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
80 [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
82 [ [ key>> ] [ type>> ] bi ] dip
83 swap <sqlite-low-level-binding> ;
85 M: sqlite-statement bind-tuple ( tuple statement -- )
87 in-params>> [ sqlite-bind-conversion ] with map
88 ] keep bind-statement ;
90 : last-insert-id ( -- id )
91 db get handle>> sqlite3_last_insert_rowid
92 dup zero? [ "last-id failed" throw ] when ;
94 M: sqlite-db insert-tuple-set-key ( tuple statement -- )
95 execute-statement last-insert-id swap set-primary-key ;
97 M: sqlite-result-set #columns ( result-set -- n )
98 handle>> sqlite-#columns ;
100 M: sqlite-result-set row-column ( result-set n -- obj )
101 [ handle>> ] [ sqlite-column ] bi* ;
103 M: sqlite-result-set row-column-typed ( result-set n -- obj )
104 dup pick out-params>> nth type>>
105 [ handle>> ] 2dip sqlite-column-typed ;
107 M: sqlite-result-set advance-row ( result-set -- )
108 dup handle>> sqlite-next >>has-more? drop ;
110 M: sqlite-result-set more-rows? ( result-set -- ? )
113 M: sqlite-statement query-results ( query -- result-set )
115 dup handle>> sqlite-result-set new-result-set
118 M: sqlite-db create-sql-statement ( class -- statement )
121 "create table " 0% 0%
124 dup column-name>> [ "table-id" set ] [ 0% ] bi
126 dup type>> lookup-create-type 0%
133 [ "," 0% ] [ column-name>> 0% ] interleave
137 M: sqlite-db drop-sql-statement ( class -- statement )
138 [ "drop table " 0% 0% ";" 0% drop ] query-make ;
140 M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
144 remove-db-assigned-id
145 dup [ ", " 0% ] [ column-name>> 0% ] interleave
148 dup type>> +random-id+ = [
151 column-name>> ":" prepend dup 0%
153 ] [ type>> ] tri <generator-bind> 1,
161 M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
162 <insert-db-assigned-statement> ;
164 M: sqlite-db bind# ( spec obj -- )
166 [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
168 ] dip <literal-bind> 1, ;
170 M: sqlite-db bind% ( spec -- )
171 dup 1, column-name>> ":" prepend 0% ;
173 M: sqlite-db persistent-table ( -- assoc )
175 { +db-assigned-id+ { "integer" "integer" f } }
176 { +user-assigned-id+ { f f f } }
177 { +random-id+ { "integer" "integer" f } }
178 { +foreign-id+ { "integer" "integer" "references" } }
180 { +on-delete+ { f f "on delete" } }
181 { +restrict+ { f f "restrict" } }
182 { +cascade+ { f f "cascade" } }
183 { +set-null+ { f f "set null" } }
184 { +set-default+ { f f "set default" } }
186 { INTEGER { "integer" "integer" f } }
187 { BIG-INTEGER { "bigint" "bigint" f } }
188 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
189 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
190 { TEXT { "text" "text" f } }
191 { VARCHAR { "text" "text" f } }
192 { DATE { "date" "date" f } }
193 { TIME { "time" "time" f } }
194 { DATETIME { "datetime" "datetime" f } }
195 { TIMESTAMP { "timestamp" "timestamp" f } }
196 { DOUBLE { "real" "real" f } }
197 { BLOB { "blob" "blob" f } }
198 { FACTOR-BLOB { "blob" "blob" f } }
199 { URL { "text" "text" f } }
200 { +autoincrement+ { f f "autoincrement" } }
201 { +unique+ { f f "unique" } }
202 { +default+ { f f "default" } }
203 { +null+ { f f "null" } }
204 { +not-null+ { f f "not null" } }
205 { system-random-generator { f f f } }
206 { secure-random-generator { f f f } }
207 { random-generator { f f f } }
210 : insert-trigger ( -- string )
213 CREATE TRIGGER fki_${table}_${foreign-table}_id
214 BEFORE INSERT ON ${table}
216 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
217 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
220 ] with-string-writer ;
222 : insert-trigger-not-null ( -- string )
225 CREATE TRIGGER fki_${table}_${foreign-table}_id
226 BEFORE INSERT ON ${table}
228 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
229 WHERE NEW.${foreign-table-id} IS NOT NULL
230 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
233 ] with-string-writer ;
235 : update-trigger ( -- string )
238 CREATE TRIGGER fku_${table}_${foreign-table}_id
239 BEFORE UPDATE ON ${table}
241 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
242 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
245 ] with-string-writer ;
247 : update-trigger-not-null ( -- string )
250 CREATE TRIGGER fku_${table}_${foreign-table}_id
251 BEFORE UPDATE ON ${table}
253 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
254 WHERE NEW.${foreign-table-id} IS NOT NULL
255 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
258 ] with-string-writer ;
260 : delete-trigger-restrict ( -- string )
263 CREATE TRIGGER fkd_${table}_${foreign-table}_id
264 BEFORE DELETE ON ${foreign-table}
266 SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
267 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
270 ] with-string-writer ;
272 : delete-trigger-cascade ( -- string )
275 CREATE TRIGGER fkd_${table}_${foreign-table}_id
276 BEFORE DELETE ON ${foreign-table}
278 DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
281 ] with-string-writer ;
283 : can-be-null? ( -- ? )
284 "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
286 : delete-cascade? ( -- ? )
287 "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
289 : sqlite-trigger, ( string -- )
290 { } { } <simple-statement> 3, ;
292 : create-sqlite-triggers ( -- )
294 insert-trigger sqlite-trigger,
295 update-trigger sqlite-trigger,
297 insert-trigger-not-null sqlite-trigger,
298 update-trigger-not-null sqlite-trigger,
301 delete-trigger-cascade sqlite-trigger,
303 delete-trigger-restrict sqlite-trigger,
306 M: sqlite-db compound ( string seq -- new-string )
308 { "default" [ first number>string join-space ] }
310 [ >reference-string ] keep
311 first2 [ "foreign-table" set ]
312 [ "foreign-table-id" set ] bi*
313 create-sqlite-triggers