steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-04-21 01:40:04 -05:00
parent bc95aa8585 411fb2f97d
commit 9d940ebe3c
13 changed files with 609 additions and 412 deletions

45
extra/db/db.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors ;
tools.walker accessors combinators.lib ;
IN: db
TUPLE: db
@ -11,7 +11,7 @@ TUPLE: db
update-statements
delete-statements ;
: construct-db ( class -- obj )
: new-db ( class -- obj )
new
H{ } clone >>insert-statements
H{ } clone >>update-statements
@ -20,7 +20,7 @@ TUPLE: db
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db )
construct-db make-db* ;
new-db make-db* ;
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
@ -36,17 +36,25 @@ HOOK: db-close db ( handle -- )
] with-variable ;
! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
TUPLE: nonthrowable-statement < statement ;
TUPLE: throwable-statement < statement ;
SINGLETON: throwable
SINGLETON: nonthrowable
: make-throwable ( obj -- obj' )
dup sequence? [
[ make-throwable ] map
] [
throwable >>type
] if ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
nonthrowable-statement construct-delegate
nonthrowable >>type
] if ;
TUPLE: result-set sql in-params out-params handle n max ;
@ -55,12 +63,14 @@ TUPLE: result-set sql in-params out-params handle n max ;
new
swap >>out-params
swap >>in-params
swap >>sql ;
swap >>sql
throwable >>type ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: low-level-bind ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
@ -70,20 +80,19 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
GENERIC: execute-statement ( statement -- )
GENERIC: execute-statement* ( statement type -- )
M: throwable-statement execute-statement ( statement -- )
M: throwable execute-statement* ( statement type -- )
drop query-results dispose ;
M: nonthrowable execute-statement* ( statement type -- )
drop [ query-results dispose ] [ 2drop ] recover ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
M: nonthrowable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
[ query-results dispose ] [ 2drop ] recover
dup type>> execute-statement*
] if ;
: bind-statement ( obj statement -- )

55
extra/db/postgresql/lib/lib.factor
View File

@ -4,8 +4,8 @@ USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary
io.streams.byte-array ;
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array inspector ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@ -23,12 +23,18 @@ IN: db.postgresql.lib
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
db get db-handle (postgresql-error-message) ;
db get handle>> (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
: postgresql-result-ok? ( n -- ? )
ERROR: postgresql-result-null ;
M: postgresql-result-null summary ( obj -- str )
drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? )
[ postgresql-result-null ] unless*
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
@ -37,8 +43,8 @@ IN: db.postgresql.lib
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
[ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ;
: type>oid ( symbol -- n )
@ -58,28 +64,22 @@ IN: db.postgresql.lib
} case ;
: param-types ( statement -- seq )
statement-in-params
[ sql-spec-type type>oid ] map
>c-uint-array ;
in-params>> [ type>> type>oid ] map >c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
: param-values ( statement -- seq seq2 )
[ statement-bind-params ]
[ statement-in-params ] bi
[ bind-params>> ] [ in-params>> ] bi
[
sql-spec-type {
type>> {
{ FACTOR-BLOB [
dup [
object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
] }
{ BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
[
drop number>string* dup [
malloc-char-string dup free-always
utf8 malloc-string dup free-always
] when 0
]
} case 2array
@ -90,22 +90,20 @@ IN: db.postgresql.lib
] if ;
: param-formats ( statement -- seq )
statement-in-params
[ sql-spec-type type>param-format ] map
>c-uint-array ;
in-params>> [ type>> type>param-format ] map >c-uint-array ;
: do-postgresql-bound-statement ( statement -- res )
[
>r db get db-handle r>
>r db get handle>> r>
{
[ statement-sql ]
[ statement-bind-params length ]
[ sql>> ]
[ bind-params>> length ]
[ param-types ]
[ param-values ]
[ param-formats ]
} cleave
0 PQexecParams dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
[ postgresql-result-error-message ] [ PQclear ] bi throw
] unless
] with-destructors ;
@ -113,8 +111,8 @@ IN: db.postgresql.lib
PQgetisnull 1 = ;
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue alien>char-string
dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
3dup PQgetvalue utf8 alien>string
dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
@ -167,4 +165,3 @@ M: postgresql-malloc-destructor dispose ( obj -- )
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull

220
extra/db/postgresql/postgresql.factor
View File

@ -5,19 +5,16 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib accessors ;
namespaces.lib accessors random db.queries ;
IN: db.postgresql
TUPLE: postgresql-db < db
host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement < throwable-statement ;
TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
postgresql-statement construct-statement ;
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r>
swap >>db
@ -42,11 +39,21 @@ M: postgresql-db dispose ( db -- )
M: postgresql-statement bind-statement* ( statement -- )
drop ;
GENERIC: postgresql-bind-conversion
M: sql-spec postgresql-bind-conversion ( tuple spec -- array )
slot-name>> swap get-slot-named ;
M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- array )
nip value>> ;
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- array )
nip quot>> call ;
M: postgresql-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[ sql-spec-slot-name swap get-slot-named ] with map
] keep set-statement-bind-params ;
tuck in-params>>
[ postgresql-bind-conversion ] with map
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
handle>> PQntuples ;
@ -54,15 +61,18 @@ M: postgresql-result-set #rows ( result-set -- n )
M: postgresql-result-set #columns ( result-set -- n )
handle>> PQnfields ;
: result-handle-n ( result-set -- handle n )
[ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ;
>r result-handle-n r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
dup pick result-set-out-params nth sql-spec-type
>r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ;
dup pick out-params>> nth type>>
>r >r result-handle-n r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-bind-params [
dup bind-params>> [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@ -72,67 +82,56 @@ M: postgresql-statement query-results ( query -- result-set )
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
dup result-set-n 1+ swap set-result-set-n ;
[ 1+ ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? )
dup result-set-n swap result-set-max < ;
[ n>> ] [ max>> ] bi < ;
M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear
f swap set-statement-handle ;
dup handle>> PQclear
f >>handle drop ;
M: postgresql-result-set dispose ( result-set -- )
dup result-set-handle PQclear
0 0 f roll {
set-result-set-n set-result-set-max set-result-set-handle
} set-slots ;
[ handle>> PQclear ]
[
0 >>n
0 >>max
f >>handle drop
] bi ;
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get handle>> "" r>
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
dup
>r db get handle>> f r>
[ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
>>handle drop ;
M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
postgresql-statement construct-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<postgresql-statement> dup prepare-statement ;
<simple-statement> dup prepare-statement ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: postgresql-db commit-transaction ( -- )
"COMMIT" sql-command ;
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
postgresql-counter [ inc ] keep get 0# ;
sql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db bind% ( spec -- )
1, bind-name% ;
bind-name% 1, ;
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off call ] { "" { } { } } nmake
<postgresql-statement> ; inline
M: postgresql-db bind# ( spec obj -- )
>r bind-name% f swap type>> r> <literal-bind> 1, ;
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
"(" 0%
[ ", " 0% ] [
dup sql-spec-column-name 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup sql-spec-type t lookup-type 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
] query-make ;
: create-function-sql ( class -- statement )
[
@ -141,7 +140,7 @@ M: postgresql-db bind% ( spec -- )
"(" 0%
over [ "," 0% ]
[
sql-spec-type f lookup-type 0%
type>> lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
@ -149,12 +148,12 @@ M: postgresql-db bind% ( spec -- )
"insert into " 0%
dup 0%
"(" 0%
over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
over [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
] postgresql-make ;
] query-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
@ -168,14 +167,14 @@ M: postgresql-db create-sql-statement ( class -- seq )
"drop function add_" 0% 0%
"(" 0%
remove-id
[ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
[ ", " 0% ] [ type>> lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
] query-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
] postgresql-make ;
] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
@ -192,107 +191,60 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
] query-make ;
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
dup [ ", " 0% ] [ column-name>> 0% ] interleave
")" 0%
" values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
dup remove-id
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
! tuple columns table
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
dup empty? [
drop
] [
" where " 0%
[ " and " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
] if ";" 0%
] postgresql-make ;
M: postgresql-db type-table ( -- hash )
M: postgresql-db persistent-table ( -- hashtable )
H{
{ +native-id+ "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ DOUBLE "real" }
{ DATE "date" }
{ TIME "time" }
{ DATETIME "timestamp" }
{ TIMESTAMP "timestamp" }
{ BLOB "bytea" }
{ FACTOR-BLOB "bytea" }
{ +native-id+ { "integer" "serial primary key" f } }
{ +assigned-id+ { f f "primary key" } }
{ +random-id+ { "bigint" "bigint primary key" f } }
{ TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" f } }
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
{ DOUBLE { "real" "real" f } }
{ DATE { "date" "date" f } }
{ TIME { "time" "time" f } }
{ DATETIME { "timestamp" "timestamp" f } }
{ TIMESTAMP { "timestamp" "timestamp" f } }
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
{ +null+ { f f "null" } }
{ +not-null+ { f f "not null" } }
{ system-random-generator { f f f } }
{ secure-random-generator { f f f } }
{ random-generator { f f f } }
} ;
M: postgresql-db create-type-table ( -- hash )
H{
{ +native-id+ "serial primary key" }
} ;
: postgresql-compound ( str n -- newstr )
M: postgresql-db compound ( str obj -- str' )
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
swap [ sql-spec-slot-name = ] with find nip
sql-spec-column-name paren append
swap [ slot-name>> = ] with find nip
column-name>> paren append
] }
[ "no compound found" 3array throw ]
} case ;
M: postgresql-db compound-modifier ( str seq -- newstr )
postgresql-compound ;
M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
} ;
M: postgresql-db compound-type ( str n -- newstr )
postgresql-compound ;

98
extra/db/queries/queries.factor Normal file
View File

@ -0,0 +1,98 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings
math.bitfields.lib namespaces.lib db db.tuples db.types
math.intervals ;
IN: db.queries
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains? [
make-retryable
] when ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
<simple-statement> maybe-make-retryable ;
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
M: db commit-transaction ( -- ) "COMMIT" sql-command ;
M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
M: db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
dup remove-id
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] query-make ;
M: db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
] query-make ;
M: db random-id-quot ( -- quot )
[ 63 [ 2^ random ] keep 1 - set-bit ] ;
GENERIC: where ( specs obj -- )
: interval-comparison ( ? str -- str )
"from" = " >" " <" ? swap [ "= " append ] when ;
: where-interval ( spec obj from/to -- )
pick column-name>> 0%
>r first2 r> interval-comparison 0%
bind# ;
: in-parens ( quot -- )
"(" 0% call ")" 0% ; inline
M: interval where ( spec obj -- )
[
[ from>> "from" where-interval " and " 0% ]
[ to>> "to" where-interval ] 2bi
] in-parens ;
M: sequence where ( spec obj -- )
[
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
: object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;
M: object where ( spec obj -- ) object-where ;
M: integer where ( spec obj -- ) object-where ;
M: string where ( spec obj -- ) object-where ;
: where-clause ( tuple specs -- )
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop ;
M: db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
dupd
[ slot-name>> swap get-slot-named ] with subset
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
] query-make ;

4
extra/db/sql/sql-tests.factor
View File

@ -1,7 +1,7 @@
USING: kernel namespaces db.sql sequences math ;
IN: db.sql.tests
TUPLE: person name age ;
! TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
@ -28,7 +28,7 @@ TUPLE: person name age ;
{ select
{ columns "salary" }
{ from "staff" }
{ where { "branchno" "b003" } }
{ where { "branchno" = "b003" } }
}
}
{ "branchno" > 3 } }

49
extra/db/sql/sql.factor
View File

@ -27,27 +27,27 @@ DEFER: sql%
: sql-array% ( array -- )
unclip
{
{ columns [ "," (sql-interleave) ] }
{ from [ "from" "," sql-interleave ] }
{ where [ "where" "and" sql-interleave ] }
{ group-by [ "group by" "," sql-interleave ] }
{ having [ "having" "," sql-interleave ] }
{ order-by [ "order by" "," sql-interleave ] }
{ offset [ "offset" sql% sql% ] }
{ limit [ "limit" sql% sql% ] }
{ select [ "(select" sql% sql% ")" sql% ] }
{ table [ sql% ] }
{ set [ "set" "," sql-interleave ] }
{ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ count [ "count" sql-function, ] }
{ sum [ "sum" sql-function, ] }
{ avg [ "avg" sql-function, ] }
{ min [ "min" sql-function, ] }
{ max [ "max" sql-function, ] }
{ \ columns [ "," (sql-interleave) ] }
{ \ from [ "from" "," sql-interleave ] }
{ \ where [ "where" "and" sql-interleave ] }
{ \ group-by [ "group by" "," sql-interleave ] }
{ \ having [ "having" "," sql-interleave ] }
{ \ order-by [ "order by" "," sql-interleave ] }
{ \ offset [ "offset" sql% sql% ] }
{ \ limit [ "limit" sql% sql% ] }
{ \ select [ "(select" sql% sql% ")" sql% ] }
{ \ table [ sql% ] }
{ \ set [ "set" "," sql-interleave ] }
{ \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ \ count [ "count" sql-function, ] }
{ \ sum [ "sum" sql-function, ] }
{ \ avg [ "avg" sql-function, ] }
{ \ min [ "min" sql-function, ] }
{ \ max [ "max" sql-function, ] }
[ sql% [ sql% ] each ]
} case ;
TUPLE: no-sql-match ;
ERROR: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
@ -55,15 +55,18 @@ TUPLE: no-sql-match ;
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
[ T{ no-sql-match } throw ]
{ [ dup quotation? ] [ call ] }
[ no-sql-match ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
{ insert [ "insert into" sql% ] }
{ update [ "update" sql% ] }
{ delete [ "delete" sql% ] }
{ select [ "select" sql% ] }
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;

13
extra/db/sqlite/ffi/ffi.factor
View File

@ -3,7 +3,7 @@
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ;
system combinators alien.c-types ;
IN: db.sqlite.ffi
<< "sqlite" {
@ -108,24 +108,31 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
"int" "sqlite" "sqlite3_bind_int64"
{ "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
: sqlite3-column-uint64 ( pStmt col -- uint64 )
"sqlite3_uint64" "sqlite" "sqlite3_column_int64"
{ "sqlite3_stmt*" "int" } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;

26
extra/db/sqlite/lib/lib.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
tools.walker ;
tools.walker io.backend ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
@ -23,7 +23,8 @@ IN: db.sqlite.lib
[ sqlite-error ]
} cond ;
: sqlite-open ( filename -- db )
: sqlite-open ( path -- db )
normalize-path
"void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
@ -32,7 +33,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare sqlite-check-result ] 2keep
[ sqlite3_prepare_v2 sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )
@ -51,6 +52,9 @@ IN: db.sqlite.lib
: sqlite-bind-int64 ( handle i n -- )
sqlite3_bind_int64 sqlite-check-result ;
: sqlite-bind-uint64 ( handle i n -- )
sqlite3-bind-uint64 sqlite-check-result ;
: sqlite-bind-double ( handle i x -- )
sqlite3_bind_double sqlite-check-result ;
@ -68,7 +72,10 @@ IN: db.sqlite.lib
parameter-index sqlite-bind-int ;
: sqlite-bind-int64-by-name ( handle name int64 -- )
parameter-index sqlite-bind-int ;
parameter-index sqlite-bind-int64 ;
: sqlite-bind-uint64-by-name ( handle name int64 -- )
parameter-index sqlite-bind-uint64 ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
@ -85,6 +92,8 @@ IN: db.sqlite.lib
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
@ -98,12 +107,15 @@ IN: db.sqlite.lib
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-clear-bindings ( handle -- )
sqlite3_clear_bindings sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
@ -120,10 +132,12 @@ IN: db.sqlite.lib
: sqlite-column-typed ( handle index type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ sqlite3_column_int64 ] }
{ +random-id+ [ sqlite3_column_int64 ] }
{ +native-id+ [ sqlite3_column_int64 ] }
{ +random-id+ [ sqlite3-column-uint64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] }
{ VARCHAR [ sqlite3_column_text ] }

180
extra/db/sqlite/sqlite.factor
View File

@ -4,8 +4,10 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
io namespaces.lib accessors ;
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib db.queries ;
USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@ -19,7 +21,7 @@ M: sqlite-db db-open ( db -- db )
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement < throwable-statement ;
TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ;
@ -42,28 +44,39 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
sqlite-maybe-prepare handle>> sqlite-reset ;
: reset-bindings ( statement -- )
sqlite-maybe-prepare
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
M: sqlite-statement low-level-bind ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
dup statement-bound? [ dup reset-bindings ] when
low-level-bind ;
GENERIC: sqlite-bind-conversion ( tuple obj -- array )
M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
[ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ]
[ type>> ] tri 3array ;
M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
in-params>>
[
[ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ]
[ type>> ] tri 3array
] with map
] keep
bind-statement ;
in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
@ -93,27 +106,19 @@ M: sqlite-statement query-results ( query -- result-set )
dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> t lookup-type 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
] query-make dup sql>> . ;
M: sqlite-db drop-sql-statement ( class -- statement )
[ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
[ "drop table " 0% 0% ";" 0% drop ] query-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
@ -122,91 +127,66 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
maybe-remove-id
dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
[ ", " 0% ] [
dup type>> +random-id+ = [
dup modifiers>> find-random-generator
[
[
column-name>> ":" prepend
dup 0% random-id-quot
] with-random
] curry
[ type>> ] bi <generator-bind> 1,
] [
bind%
] if
] interleave
");" 0%
] sqlite-make ;
] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
: where-clause ( specs -- )
" where " 0%
[ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
"update " 0%
0%
" set " 0%
dup remove-id
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind# ( spec obj -- )
>r
[ column-name>> ":" swap next-sql-counter 3append dup 0% ]
[ type>> ] bi
r> <literal-bind> 1, ;
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
[ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
M: sqlite-db modifier-table ( -- hashtable )
M: sqlite-db persistent-table ( -- assoc )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +random-id+ "primary key" }
! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
{ +native-id+ { "integer primary key" "integer primary key" f } }
{ +assigned-id+ { f f "primary key" } }
{ +random-id+ { "integer primary key" "integer primary key" f } }
{ INTEGER { "integer" "integer" "primary key" } }
{ BIG-INTEGER { "bigint" "bigint" } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ TEXT { "text" "text" } }
{ VARCHAR { "text" "text" } }
{ DATE { "date" "date" } }
{ TIME { "time" "time" } }
{ DATETIME { "datetime" "datetime" } }
{ TIMESTAMP { "timestamp" "timestamp" } }
{ DOUBLE { "real" "real" } }
{ BLOB { "blob" "blob" } }
{ FACTOR-BLOB { "blob" "blob" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
{ +null+ { f f "null" } }
{ +not-null+ { f f "not null" } }
{ system-random-generator { f f f } }
{ secure-random-generator { f f f } }
{ random-generator { f f f } }
} ;
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
M: sqlite-db compound-type ( str seq -- str' )
M: sqlite-db compound ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
[ 2drop ]
} case ;
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ +random-id+ "integer primary key" }
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DATE "date" }
{ TIME "time" }
{ DATETIME "datetime" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
{ BLOB "blob" }
{ FACTOR-BLOB "blob" }
} ;
M: sqlite-db create-type-table ( symbol -- str ) type-table ;

153
extra/db/tuples/tuples-tests.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces math
prettyprint tools.walker db.sqlite calendar
math.intervals db.postgresql ;
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint tools.walker calendar sequences db.sqlite
math.intervals db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@ -106,13 +106,6 @@ SYMBOL: person4
[ ] [ person drop-table ] unit-test ;
: make-native-person-table ( -- )
[ person drop-table ] [ drop ] recover
person create-table
T{ person f f "billy" 200 3.14 } insert-tuple
T{ person f f "johnny" 10 3.14 } insert-tuple
;
: native-person-schema ( -- )
person "PERSON"
{
@ -192,7 +185,6 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
@ -212,12 +204,9 @@ TUPLE: serialize-me id data ;
{ T{ serialize-me f 1 H{ { 1 2 } } } }
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
[ test-serialize ] test-sqlite
! [ test-serialize ] test-postgresql
TUPLE: exam id name score ;
: test-ranges ( -- )
: test-intervals ( -- )
exam "EXAM"
{
{ "id" "ID" +native-id+ }
@ -233,12 +222,84 @@ TUPLE: exam id name score ;
[ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
;
{
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
] unit-test
! [ test-ranges ] test-sqlite
[
{ }
] [
T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
] unit-test
[
{
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
] unit-test
[
{
T{ exam f 3 "Kenny" 60 }
}
] [
T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
] unit-test
[
{
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
] unit-test
[
{
T{ exam f 1 "Kyle" 100 }
T{ exam f 2 "Stan" 80 }
}
] [
T{ exam f f { "Stan" "Kyle" } } select-tuples
] unit-test
[
{
T{ exam f 1 "Kyle" 100 }
T{ exam f 2 "Stan" 80 }
T{ exam f 3 "Kenny" 60 }
}
] [
T{ exam f T{ range f 1 3 1 } } select-tuples
] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
bignum-test new
swap >>o
swap >>n
swap >>m ;
: test-bignum
bignum-test "BIGNUM_TEST"
{
{ "id" "ID" +native-id+ }
{ "m" "M" BIG-INTEGER }
{ "n" "N" UNSIGNED-BIG-INTEGER }
{ "o" "O" SIGNED-BIG-INTEGER }
} define-persistent
[ bignum-test drop-table ] ignore-errors
[ ] [ bignum-test ensure-table ] unit-test
[ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
! sqlite only
! [ T{ bignum-test f 1
! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
TUPLE: secret n message ;
C: <secret> secret
@ -246,24 +307,54 @@ C: <secret> secret
: test-random-id
secret "SECRET"
{
{ "n" "ID" +random-id+ }
{ "n" "ID" +random-id+ system-random-generator }
{ "message" "MESSAGE" TEXT }
} define-persistent
[ ] [ secret ensure-table ] unit-test
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
[ ] [ T{ secret } select-tuples ] unit-test
;
[ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
[ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
[ t ] [
T{ secret } select-tuples
first message>> "kilroy was here" head?
] unit-test
[ t ] [
T{ secret } select-tuples length 3 =
] unit-test ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ test-bignum ] test-sqlite
[ test-serialize ] test-sqlite
[ test-intervals ] test-sqlite
[ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
[ test-bignum ] test-postgresql
[ test-serialize ] test-postgresql
[ test-intervals ] test-postgresql
! [ test-random-id ] test-postgresql
TUPLE: does-not-persist ;
! [
! [ does-not-persist create-sql-statement ]
! [ class \ not-persistent = ] must-fail-with
! ] test-sqlite
[
[ does-not-persist create-sql-statement ]
[ class \ not-persistent = ] must-fail-with
] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer

62
extra/db/tuples/tuples.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
@ -13,15 +13,25 @@ IN: db.tuples
"db-columns" set-word-prop
"db-relations" set-word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ;
: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-relations ( class -- obj ) "db-relations" word-prop ;
ERROR: not-persistent ;
: db-table ( class -- obj )
"db-table" word-prop [ not-persistent ] unless* ;
: db-columns ( class -- obj )
"db-columns" word-prop ;
: db-relations ( class -- obj )
"db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ;
SYMBOL: sql-counter
: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
@ -39,6 +49,40 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
SINGLETON: retryable
: make-retryable ( obj -- obj' )
dup sequence? [
[ make-retryable ] map
] [
retryable >>type
] if ;
: regenerate-params ( statement -- statement )
dup
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
quot>> call over set-second
] [
drop
] if
] 2map >>bind-params ;
: handle-random-id ( statement -- )
dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
retryable >>type
random-id-quot >>quot
] when drop ;
M: retryable execute-statement* ( statement type -- )
drop
[
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class new [
[
@ -58,7 +102,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
] curry 2each ;
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
[ db-columns ] [ db-table ] bi ;
: with-disposals ( seq quot -- )
over sequence? [
@ -85,17 +129,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
[ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- )
! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key nonnative-id? [
insert-nonnative
] [
insert-native
] if ;
dup class db-columns find-primary-key nonnative-id?
[ insert-nonnative ] [ insert-native ] if ;
: update-tuple ( tuple -- )
dup class

113
extra/db/types/types.factor
View File

@ -4,16 +4,21 @@ USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols
classes.singleton ;
classes.singleton accessors quotations random ;
IN: db.types
HOOK: modifier-table db ( -- hash )
HOOK: compound-modifier db ( str seq -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- hash )
HOOK: persistent-table db ( -- hash )
HOOK: compound db ( str obj -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
HOOK: random-id-quot db ( -- quot )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
TUPLE: literal-bind key type value ;
C: <literal-bind> literal-bind
TUPLE: generator-bind key quot type ;
C: <generator-bind> generator-bind
SINGLETON: +native-id+
SINGLETON: +assigned-id+
@ -24,50 +29,54 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: find-random-generator ( seq -- obj )
[
{
random-generator
system-random-generator
secure-random-generator
} member?
] find nip [ system-random-generator ] unless* ;
: primary-key? ( spec -- ? )
sql-spec-primary-key +primary-key+? ;
primary-key>> +primary-key+? ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+? ;
primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? )
sql-spec-primary-key +nonnative-id+? ;
primary-key>> +nonnative-id+? ;
: normalize-spec ( spec -- )
dup sql-spec-type dup +primary-key+? [
swap set-sql-spec-primary-key
dup type>> dup +primary-key+? [
>>primary-key drop
] [
drop dup sql-spec-modifiers [
drop dup modifiers>> [
+primary-key+?
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
[ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
[ primary-key>> ] find nip ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*
{
set-sql-spec-class
set-sql-spec-slot-name
set-sql-spec-column-name
set-sql-spec-type
set-sql-spec-modifiers
} sql-spec construct
3 f pad-right
[ first3 ] keep 3 tail
sql-spec new
swap >>modifiers
swap >>type
swap >>column-name
swap >>slot-name
swap >>class
dup normalize-spec ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
TUPLE: no-sql-modifier ;
: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
@ -78,40 +87,40 @@ TUPLE: no-sql-modifier ;
[ relation? not ] subset ;
: remove-id ( specs -- obj )
[ sql-spec-primary-key not ] subset ;
[ primary-key>> not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: lookup-modifier ( obj -- str )
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "unknown modifier" throw ] unless
] if ;
ERROR: unknown-modifier ;
: lookup-type* ( obj -- str )
: lookup-modifier ( obj -- str )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
[ persistent-table at* [ unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type ;
: (lookup-type) ( obj -- str )
persistent-table at* [ no-sql-type ] unless ;
: lookup-type ( obj -- str )
dup array? [
first lookup-type*
unclip (lookup-type) first nip
] [
type-table at*
[ no-sql-type ] unless
(lookup-type) first
] if ;
: lookup-create-type ( obj -- str )
dup array? [
unclip lookup-create-type swap compound-type
unclip (lookup-type) second swap compound
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
(lookup-type) second
] if ;
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
@ -125,11 +134,11 @@ TUPLE: no-sql-modifier ;
" " swap 3append ;
: modifiers ( spec -- str )
sql-spec-modifiers
[ lookup-modifier ] map " " join
modifiers>> [ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
class "slots" word-prop slot-named slot-spec-offset ;
@ -145,6 +154,6 @@ HOOK: bind% db ( spec -- )
: tuple>params ( specs tuple -- obj )
[
>r dup sql-spec-type swap sql-spec-slot-name r>
>r [ type>> ] [ slot-name>> ] bi r>
get-slot-named swap
] curry { } map>assoc ;

3
extra/sequences/lib/lib.factor
View File

@ -201,9 +201,6 @@ USE: continuations
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
: ?head* ( seq n -- seq/f ) (head) ?subseq ;
: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline