1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs db kernel math math.parser
4 sequences continuations sequences.deep prettyprint
5 words namespaces slots slots.private classes mirrors
6 classes.tuple combinators calendar.format classes.singleton
7 accessors quotations random db.private ;
10 HOOK: persistent-table db-connection ( -- hash )
11 HOOK: compound db-connection ( string obj -- hash )
13 TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
15 TUPLE: literal-bind key type value ;
16 C: <literal-bind> literal-bind
18 TUPLE: generator-bind slot-name key generator-singleton type ;
19 C: <generator-bind> generator-bind
20 SINGLETON: random-id-generator
22 TUPLE: low-level-binding value ;
23 C: <low-level-binding> low-level-binding
25 SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
26 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
28 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
29 +foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
30 +set-null+ +set-default+ ;
34 : filter-ignores ( tuple specs -- specs' )
35 [ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
36 [ slot-name>> swap member? not ] with filter ;
40 : offset-of-slot ( string tuple -- n )
41 class superclasses [ "slots" word-prop ] map concat
42 slot-named dup [ no-slot ] unless offset>> ;
44 : get-slot-named ( name tuple -- value )
45 [ nip ] [ offset-of-slot ] 2bi slot ;
47 : set-slot-named ( value name obj -- )
48 [ nip ] [ offset-of-slot ] 2bi set-slot ;
50 ERROR: not-persistent class ;
52 : db-table ( class -- object )
53 dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
55 : db-columns ( class -- object )
56 superclasses [ "db-columns" word-prop ] map concat ;
58 : db-relations ( class -- object )
59 "db-relations" word-prop ;
61 : find-primary-key ( specs -- seq )
62 [ primary-key>> ] filter ;
64 : set-primary-key ( value tuple -- )
67 find-primary-key first slot-name>>
68 ] keep set-slot-named ;
70 : primary-key? ( spec -- ? )
71 primary-key>> +primary-key+? ;
73 : db-assigned-id-spec? ( specs -- ? )
74 [ primary-key>> +db-assigned-id+? ] contains? ;
76 : user-assigned-id-spec? ( specs -- ? )
77 [ primary-key>> +user-assigned-id+? ] contains? ;
79 : normalize-spec ( spec -- )
80 dup type>> dup +primary-key+? [
83 drop dup modifiers>> [
86 [ >>primary-key drop ] [ drop ] if*
89 : db-assigned? ( class -- ? )
90 db-columns find-primary-key db-assigned-id-spec? ;
92 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
94 SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
95 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
96 FACTOR-BLOB NULL URL ;
98 : <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
107 : spec>tuple ( class spec -- tuple )
108 3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
110 : number>string* ( n/string -- string )
111 dup number? [ number>string ] when ;
113 : remove-db-assigned-id ( specs -- obj )
114 [ +db-assigned-id+? not ] filter ;
116 : remove-relations ( specs -- newcolumns )
117 [ relation? not ] filter ;
119 : remove-id ( specs -- obj )
120 [ primary-key>> not ] filter ;
122 ! SQLite Types: http://www.sqlite.org/datatype3.html
123 ! NULL INTEGER REAL TEXT BLOB
125 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
127 : ?at ( obj assoc -- value/obj ? )
128 dupd at* [ [ nip ] [ drop ] if ] keep ;
130 ERROR: unknown-modifier modifier ;
132 : lookup-modifier ( obj -- string )
134 { [ dup array? ] [ unclip lookup-modifier swap compound ] }
135 [ persistent-table ?at [ unknown-modifier ] unless third ]
138 ERROR: no-sql-type type ;
140 : (lookup-type) ( obj -- string )
141 persistent-table ?at [ no-sql-type ] unless ;
143 : lookup-type ( obj -- string )
145 unclip (lookup-type) first nip
150 : lookup-create-type ( obj -- string )
152 unclip (lookup-type) second swap compound
157 : modifiers ( spec -- string )
158 modifiers>> [ lookup-modifier ] map " " join
159 [ "" ] [ " " prepend ] if-empty ;
161 HOOK: bind% db-connection ( spec -- )
162 HOOK: bind# db-connection ( spec obj -- )
164 ERROR: no-column column ;
166 : >reference-string ( string pair -- string )
168 [ [ unparse " " glue ] [ db-columns ] bi ] dip
169 swap [ column-name>> = ] with find nip
170 [ no-column ] unless*
171 column-name>> "(" ")" surround append ;