! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
+io.files kernel math math.parser namespaces prettyprint fry
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+io.streams.string multiline make db.private sequences.deep ;
IN: db.sqlite
TUPLE: sqlite-db path ;
dup handle>> sqlite-result-set new-result-set
dup advance-row ;
-M: sqlite-db-connection create-sql-statement ( class -- statement )
- [
- dupd
- "create table " 0% 0%
- "(" 0% [ ", " 0% ] [
- dup "sql-spec" set
- dup column-name>> [ "table-id" set ] [ 0% ] bi
- " " 0%
- dup type>> lookup-create-type 0%
- modifiers 0%
- ] interleave
-
- find-primary-key [
- ", " 0%
- "primary key(" 0%
- [ "," 0% ] [ column-name>> 0% ] interleave
- ")" 0%
- ] unless-empty
- ");" 0%
- ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
[
"insert into " 0% 0%
: insert-trigger ( -- string )
[
<"
- CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
: insert-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
"> interpolate
] with-string-writer ;
+: drop-insert-trigger ( -- string )
+ [
+ <"
+ DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+ "> interpolate
+ ] with-string-writer ;
+
: update-trigger ( -- string )
[
<"
- CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
: update-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
"> interpolate
] with-string-writer ;
+: drop-update-trigger ( -- string )
+ [
+ <"
+ DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+ "> interpolate
+ ] with-string-writer ;
+
: delete-trigger-restrict ( -- string )
[
<"
- CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
"> interpolate
] with-string-writer ;
+: drop-delete-trigger-restrict ( -- string )
+ [
+ <"
+ DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+ "> interpolate
+ ] with-string-writer ;
+
: delete-trigger-cascade ( -- string )
[
<"
- CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
"> interpolate
] with-string-writer ;
+: drop-delete-trigger-cascade ( -- string )
+ [
+ <"
+ DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+ "> interpolate
+ ] with-string-writer ;
+
: can-be-null? ( -- ? )
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
delete-trigger-restrict sqlite-trigger,
] if ;
+: drop-sqlite-triggers ( -- )
+ drop-insert-trigger sqlite-trigger,
+ drop-update-trigger sqlite-trigger,
+ delete-cascade? [
+ drop-delete-trigger-cascade sqlite-trigger,
+ ] [
+ drop-delete-trigger-restrict sqlite-trigger,
+ ] if ;
+
+: db-triggers ( sql-specs word -- )
+ '[
+ [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ class>> db-table-name "db-table" set ]
+ [ column-name>> "table-id" set ]
+ [
+ modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ second db-table-name "foreign-table-name" set ]
+ [ third "foreign-table-id" set ] bi
+ _ execute
+ ] each
+ ] tri
+ ] each
+ ] call ;
+
+: sqlite-create-table ( sql-specs class-name -- )
+ [
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup "sql-spec" set
+ dup column-name>> [ "table-id" set ] [ 0% ] bi
+ " " 0%
+ dup type>> lookup-create-type 0%
+ modifiers 0%
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " 0%
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ ")" 0%
+ ] unless-empty
+ ");" 0%
+ ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement ( class -- statement )
+ [
+ ! specs name
+ [ sqlite-create-table ]
+ [ drop \ create-sqlite-triggers db-triggers ] 2bi
+ ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement ( class -- statements )
+ [
+ [ nip "drop table " 0% 0% ";" 0% ]
+ [ drop \ drop-sqlite-triggers db-triggers ] 2bi
+ ] query-make ;
+
M: sqlite-db-connection compound ( string seq -- new-string )
over {
{ "default" [ first number>string " " glue ] }
- { "references" [
- [ >reference-string ] keep
- first2 [ db-table-name "foreign-table-name" set ]
- [ "foreign-table-id" set ] bi*
- create-sqlite-triggers
- ] }
+ { "references" [ >reference-string ] }
[ 2drop ]
} case ;
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private ;
+destructors mirrors sets db.types db.private fry
+combinators.short-circuit ;
IN: db.tuples
HOOK: create-sql-statement db-connection ( class -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
- [ [ slot-name>> ] dip set-slot-named ] curry 2each
+ '[ slot-name>> _ set-slot-named ] 2each
] keep ;
: query-tuples ( exemplar-tuple statement -- seq )
M: tuple >query <query> swap >>tuple ;
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+ dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+ no-defined-persistent
+ ] unless ;
+
: create-table ( class -- )
+ ensure-defined-persistent
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
+ ensure-defined-persistent
drop-sql-statement [ execute-statement ] with-disposals ;
: recreate-table ( class -- )
+ ensure-defined-persistent
[
- [ drop-sql-statement [ execute-statement ] with-disposals
- ] curry ignore-errors
+ '[
+ _ drop-sql-statement [ execute-statement ] with-disposals
+ ] ignore-errors
] [ create-table ] bi ;
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+ ensure-defined-persistent
+ '[ _ create-table ] ignore-errors ;
: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key db-assigned-id-spec?
+ dup class ensure-defined-persistent
+ db-columns find-primary-key db-assigned-id-spec?
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
: update-tuple ( tuple -- )
- dup class
+ dup class ensure-defined-persistent
db-connection get update-statements>> [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )
- dup dup class <delete-tuples-statement> [
+ dup
+ dup class ensure-defined-persistent
+ <delete-tuples-statement> [
[ bind-tuple ] keep execute-statement
] with-disposal ;
>query [ tuple>> ] [ query>statement ] bi do-select ;
: select-tuple ( query/tuple -- tuple/f )
- >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
- [ f ] [ first ] if-empty ;
+ >query 1 >>limit [ tuple>> ] [ query>statement ] bi
+ do-select [ f ] [ first ] if-empty ;
: count-tuples ( query/tuple -- n )
>query [ tuple>> ] [ <count-statement> ] bi do-count