USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep prettyprint
words namespaces slots slots.private classes mirrors
-classes.tuple combinators calendar.format symbols
-classes.singleton accessors quotations random ;
+classes.tuple combinators calendar.format classes.singleton
+accessors quotations random db.private ;
IN: db.types
-HOOK: persistent-table db ( -- hash )
-HOOK: compound db ( string obj -- hash )
+HOOK: persistent-table db-connection ( -- hash )
+HOOK: compound db-connection ( string obj -- hash )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
-+set-default+ ;
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
SYMBOL: IGNORE
: filter-ignores ( tuple specs -- specs' )
[ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
- [ slot-name>> swap member? not ] with filter ;
-
-ERROR: no-slot ;
-
-: offset-of-slot ( string tuple -- n )
- class superclasses [ "slots" word-prop ] map concat
- slot-named dup [ no-slot ] unless offset>> ;
-
-: get-slot-named ( name tuple -- value )
- tuck offset-of-slot slot ;
-
-: set-slot-named ( value name obj -- )
- tuck offset-of-slot set-slot ;
+ [ slot-name>> swap member? ] with reject ;
ERROR: not-persistent class ;
-: db-table ( class -- object )
+: db-table-name ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
: set-primary-key ( value tuple -- )
[
- class db-columns
+ class-of db-columns
find-primary-key first slot-name>>
] keep set-slot-named ;
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +db-assigned-id+? ] contains? ;
+ [ primary-key>> +db-assigned-id+? ] any? ;
: user-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +user-assigned-id+? ] contains? ;
+ [ primary-key>> +user-assigned-id+? ] any? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ;
dup normalize-spec ;
: spec>tuple ( class spec -- tuple )
- 3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
+ 3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
: number>string* ( n/string -- string )
dup number? [ number>string ] when ;
: remove-db-assigned-id ( specs -- obj )
- [ +db-assigned-id+? not ] filter ;
+ [ +db-assigned-id+? ] reject ;
: remove-relations ( specs -- newcolumns )
- [ relation? not ] filter ;
+ [ relation? ] reject ;
: remove-id ( specs -- obj )
- [ primary-key>> not ] filter ;
+ [ primary-key>> ] reject ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
ERROR: unknown-modifier modifier ;
: lookup-modifier ( obj -- string )
modifiers>> [ lookup-modifier ] map " " join
[ "" ] [ " " prepend ] if-empty ;
-: join-space ( string1 string2 -- new-string )
- " " swap 3append ;
-
-: paren ( string -- new-string )
- "(" swap ")" 3append ;
-
-HOOK: bind% db ( spec -- )
-HOOK: bind# db ( spec obj -- )
+HOOK: bind% db-connection ( spec -- )
+HOOK: bind# db-connection ( spec obj -- )
ERROR: no-column column ;
: >reference-string ( string pair -- string )
first2
- [ [ unparse join-space ] [ db-columns ] bi ] dip
+ [ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip
[ no-column ] unless*
- column-name>> paren append ;
+ column-name>> "(" ")" surround append ;