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

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

db4
slava 2008-04-21 06:14:03 -05:00
parent a471eab19a 3af81b2262
commit a7757e1b96
14 changed files with 644 additions and 417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
extra/db/db.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib classes.tuple words strings namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors ; tools.walker accessors combinators.lib ;
IN: db IN: db
TUPLE: db TUPLE: db
@ -11,7 +11,7 @@ TUPLE: db
update-statements update-statements
delete-statements ; delete-statements ;
: construct-db ( class -- obj ) : new-db ( class -- obj )
new new
H{ } clone >>insert-statements H{ } clone >>insert-statements
H{ } clone >>update-statements H{ } clone >>update-statements
@ -20,7 +20,7 @@ TUPLE: db
GENERIC: make-db* ( seq class -- db ) GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) : make-db ( seq class -- db )
construct-db make-db* ; new-db make-db* ;
GENERIC: db-open ( db -- db ) GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- ) HOOK: db-close db ( handle -- )
@ -36,17 +36,25 @@ HOOK: db-close db ( handle -- )
] with-variable ; ] with-variable ;
! TUPLE: sql sql in-params out-params ; ! 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: simple-statement < statement ;
TUPLE: prepared-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' ) : make-nonthrowable ( obj -- obj' )
dup sequence? [ dup sequence? [
[ make-nonthrowable ] map [ make-nonthrowable ] map
] [ ] [
nonthrowable-statement construct-delegate nonthrowable >>type
] if ; ] if ;
TUPLE: result-set sql in-params out-params handle n max ; 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 new
swap >>out-params swap >>out-params
swap >>in-params swap >>in-params
swap >>sql ; swap >>sql
throwable >>type ;
HOOK: <simple-statement> db ( str in out -- statement ) HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement ) HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- ) GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- ) GENERIC: bind-statement* ( statement -- )
GENERIC: low-level-bind ( statement -- )
GENERIC: bind-tuple ( tuple statement -- ) GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set ) GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n ) GENERIC: #rows ( result-set -- n )
@ -70,20 +80,19 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- ) GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( 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? [ dup sequence? [
[ execute-statement ] each [ execute-statement ] each
] [ ] [
query-results dispose dup type>> execute-statement*
] if ;
M: nonthrowable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
[ query-results dispose ] [ 2drop ] recover
] if ; ] if ;
: bind-statement ( obj statement -- ) : 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 quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary accessors strings serialize io.encodings.binary io.encodings.utf8
io.streams.byte-array ; alien.strings io.streams.byte-array inspector ;
IN: db.postgresql.lib IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f ) : postgresql-result-error-message ( res -- str/f )
@ -23,12 +23,18 @@ IN: db.postgresql.lib
"\n" split [ [ blank? ] trim ] map "\n" join ; "\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str ) : postgresql-error-message ( -- str )
db get db-handle (postgresql-error-message) ; db get handle>> (postgresql-error-message) ;
: postgresql-error ( res -- res ) : postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ; 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 PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
@ -37,8 +43,8 @@ IN: db.postgresql.lib
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res ) : do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ; ] unless ;
: type>oid ( symbol -- n ) : type>oid ( symbol -- n )
@ -58,28 +64,22 @@ IN: db.postgresql.lib
} case ; } case ;
: param-types ( statement -- seq ) : param-types ( statement -- seq )
statement-in-params in-params>> [ type>> type>oid ] map >c-uint-array ;
[ sql-spec-type type>oid ] map
>c-uint-array ;
: malloc-byte-array/length : malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ; [ malloc-byte-array dup free-always ] [ length ] bi ;
: param-values ( statement -- seq seq2 ) : param-values ( statement -- seq seq2 )
[ statement-bind-params ] [ bind-params>> ] [ in-params>> ] bi
[ statement-in-params ] bi
[ [
sql-spec-type { type>> {
{ FACTOR-BLOB [ { FACTOR-BLOB [
dup [ dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
object>bytes ] }
malloc-byte-array/length ] [ 0 ] if ] } { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
[ [
drop number>string* dup [ drop number>string* dup [
malloc-char-string dup free-always utf8 malloc-string dup free-always
] when 0 ] when 0
] ]
} case 2array } case 2array
@ -90,22 +90,20 @@ IN: db.postgresql.lib
] if ; ] if ;
: param-formats ( statement -- seq ) : param-formats ( statement -- seq )
statement-in-params in-params>> [ type>> type>param-format ] map >c-uint-array ;
[ sql-spec-type type>param-format ] map
>c-uint-array ;
: do-postgresql-bound-statement ( statement -- res ) : do-postgresql-bound-statement ( statement -- res )
[ [
>r db get db-handle r> >r db get handle>> r>
{ {
[ statement-sql ] [ sql>> ]
[ statement-bind-params length ] [ bind-params>> length ]
[ param-types ] [ param-types ]
[ param-values ] [ param-values ]
[ param-formats ] [ param-formats ]
} cleave } cleave
0 PQexecParams dup postgresql-result-ok? [ 0 PQexecParams dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ] unless
] with-destructors ; ] with-destructors ;
@ -113,8 +111,8 @@ IN: db.postgresql.lib
PQgetisnull 1 = ; PQgetisnull 1 = ;
: pq-get-string ( handle row column -- obj ) : pq-get-string ( handle row column -- obj )
3dup PQgetvalue alien>char-string 3dup PQgetvalue utf8 alien>string
dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj ) : pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ; pq-get-string dup [ string>number ] when ;
@ -167,4 +165,3 @@ M: postgresql-malloc-destructor dispose ( obj -- )
dup [ bytes>object ] when ] } dup [ bytes>object ] when ] }
[ no-sql-type ] [ no-sql-type ]
} case ; } case ;
! PQgetlength PQgetisnull

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

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

@ -27,27 +27,27 @@ DEFER: sql%
: sql-array% ( array -- ) : sql-array% ( array -- )
unclip unclip
{ {
{ columns [ "," (sql-interleave) ] } { \ columns [ "," (sql-interleave) ] }
{ from [ "from" "," sql-interleave ] } { \ from [ "from" "," sql-interleave ] }
{ where [ "where" "and" sql-interleave ] } { \ where [ "where" "and" sql-interleave ] }
{ group-by [ "group by" "," sql-interleave ] } { \ group-by [ "group by" "," sql-interleave ] }
{ having [ "having" "," sql-interleave ] } { \ having [ "having" "," sql-interleave ] }
{ order-by [ "order by" "," sql-interleave ] } { \ order-by [ "order by" "," sql-interleave ] }
{ offset [ "offset" sql% sql% ] } { \ offset [ "offset" sql% sql% ] }
{ limit [ "limit" sql% sql% ] } { \ limit [ "limit" sql% sql% ] }
{ select [ "(select" sql% sql% ")" sql% ] } { \ select [ "(select" sql% sql% ")" sql% ] }
{ table [ sql% ] } { \ table [ sql% ] }
{ set [ "set" "," sql-interleave ] } { \ set [ "set" "," sql-interleave ] }
{ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ count [ "count" sql-function, ] } { \ count [ "count" sql-function, ] }
{ sum [ "sum" sql-function, ] } { \ sum [ "sum" sql-function, ] }
{ avg [ "avg" sql-function, ] } { \ avg [ "avg" sql-function, ] }
{ min [ "min" sql-function, ] } { \ min [ "min" sql-function, ] }
{ max [ "max" sql-function, ] } { \ max [ "max" sql-function, ] }
[ sql% [ sql% ] each ] [ sql% [ sql% ] each ]
} case ; } case ;
TUPLE: no-sql-match ; ERROR: no-sql-match ;
: sql% ( obj -- ) : sql% ( obj -- )
{ {
{ [ dup string? ] [ " " 0% 0% ] } { [ dup string? ] [ " " 0% 0% ] }
@ -55,15 +55,18 @@ TUPLE: no-sql-match ;
{ [ dup number? ] [ number>string sql% ] } { [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] } { [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] }
[ T{ no-sql-match } throw ] { [ dup quotation? ] [ call ] }
[ no-sql-match ]
} cond ; } cond ;
: parse-sql ( obj -- sql in-spec out-spec in out ) : parse-sql ( obj -- sql in-spec out-spec in out )
[ [
unclip { unclip {
{ insert [ "insert into" sql% ] } { \ create [ "create table" sql% ] }
{ update [ "update" sql% ] } { \ drop [ "drop table" sql% ] }
{ delete [ "delete" sql% ] } { \ insert [ "insert into" sql% ] }
{ select [ "select" sql% ] } { \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ "select" sql% ] }
} case [ sql% ] each } case [ sql% ] each
] { "" { } { } { } { } } nmake ; ] { "" { } { } { } { } } 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. ! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped. ! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ; system combinators alien.c-types ;
IN: db.sqlite.ffi IN: db.sqlite.ffi
<< "sqlite" { << "sqlite" {
@ -108,24 +108,31 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( 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_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( 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_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_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; 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 ) ; 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_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_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_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: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( 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: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( 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 ) ; 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: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( 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 ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;

24
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 namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary io.streams.byte-array byte-arrays io.encodings.binary
tools.walker ; tools.walker io.backend ;
IN: db.sqlite.lib IN: db.sqlite.lib
: sqlite-error ( n -- * ) : sqlite-error ( n -- * )
@ -23,7 +23,8 @@ IN: db.sqlite.lib
[ sqlite-error ] [ sqlite-error ]
} cond ; } cond ;
: sqlite-open ( filename -- db ) : sqlite-open ( path -- db )
normalize-path
"void*" <c-object> "void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ; [ sqlite3_open sqlite-check-result ] keep *void* ;
@ -32,7 +33,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle ) : sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object> dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare sqlite-check-result ] 2keep [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
drop *void* ; drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index ) : sqlite-bind-parameter-index ( handle name -- index )
@ -51,6 +52,9 @@ IN: db.sqlite.lib
: sqlite-bind-int64 ( handle i n -- ) : sqlite-bind-int64 ( handle i n -- )
sqlite3_bind_int64 sqlite-check-result ; sqlite3_bind_int64 sqlite-check-result ;
: sqlite-bind-uint64 ( handle i n -- )
sqlite3-bind-uint64 sqlite-check-result ;
: sqlite-bind-double ( handle i x -- ) : sqlite-bind-double ( handle i x -- )
sqlite3_bind_double sqlite-check-result ; sqlite3_bind_double sqlite-check-result ;
@ -68,7 +72,10 @@ IN: db.sqlite.lib
parameter-index sqlite-bind-int ; parameter-index sqlite-bind-int ;
: sqlite-bind-int64-by-name ( handle name int64 -- ) : 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 -- ) : sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ; parameter-index sqlite-bind-double ;
@ -85,6 +92,8 @@ IN: db.sqlite.lib
{ {
{ INTEGER [ sqlite-bind-int-by-name ] } { INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-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 ] } { TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] }
@ -98,12 +107,15 @@ IN: db.sqlite.lib
sqlite-bind-blob-by-name sqlite-bind-blob-by-name
] } ] }
{ +native-id+ [ sqlite-bind-int-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] } { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ] [ no-sql-type ]
} case ; } case ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset 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-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; : sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
@ -121,9 +133,11 @@ IN: db.sqlite.lib
dup array? [ first ] when dup array? [ first ] when
{ {
{ +native-id+ [ sqlite3_column_int64 ] } { +native-id+ [ sqlite3_column_int64 ] }
{ +random-id+ [ sqlite3_column_int64 ] } { +random-id+ [ sqlite3-column-uint64 ] }
{ INTEGER [ sqlite3_column_int ] } { INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] } { BIG-INTEGER [ sqlite3_column_int64 ] }
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
{ DOUBLE [ sqlite3_column_double ] } { DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] } { TEXT [ sqlite3_column_text ] }
{ VARCHAR [ 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 hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors ; io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib db.queries ;
USE: tools.walker
IN: db.sqlite IN: db.sqlite
TUPLE: sqlite-db < db path ; 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 db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ; M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement < throwable-statement ; TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ; TUPLE: sqlite-result-set < result-set has-more? ;
@ -42,28 +44,39 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
f >>handle drop ; f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- ) : reset-statement ( statement -- )
sqlite-maybe-prepare handle>> sqlite-reset ; 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 -- ) M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when dup statement-bound? [ dup reset-bindings ] when
[ statement-bind-params ] [ statement-handle ] bi low-level-bind ;
sqlite-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 -- ) M: sqlite-statement bind-tuple ( tuple statement -- )
[ [
in-params>> in-params>> [ sqlite-bind-conversion ] with map
[ ] keep bind-statement ;
[ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ]
[ type>> ] tri 3array
] with map
] keep
bind-statement ;
: last-insert-id ( -- id ) : last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid 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 handle>> sqlite-result-set construct-result-set
dup advance-row ; 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 ) M: sqlite-db create-sql-statement ( class -- statement )
[ [
"create table " 0% 0% "create table " 0% 0%
"(" 0% [ ", " 0% ] [ "(" 0% [ ", " 0% ] [
dup column-name>> 0% dup column-name>> 0%
" " 0% " " 0%
dup type>> t lookup-type 0% dup type>> lookup-create-type 0%
modifiers 0% modifiers 0%
] interleave ");" 0% ] interleave ");" 0%
] sqlite-make ; ] query-make dup sql>> . ;
M: sqlite-db drop-sql-statement ( class -- statement ) 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 ) M: sqlite-db <insert-native-statement> ( tuple -- statement )
[ [
@ -122,91 +127,66 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
maybe-remove-id maybe-remove-id
dup [ ", " 0% ] [ column-name>> 0% ] interleave dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0% ") 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% ");" 0%
] sqlite-make ; ] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement ) M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ; <insert-native-statement> ;
: where-primary-key% ( specs -- ) M: sqlite-db bind# ( spec obj -- )
" where " 0% >r
find-primary-key dup column-name>> 0% " = " 0% bind% ; [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
[ type>> ] bi
: where-clause ( specs -- ) r> <literal-bind> 1, ;
" 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 -- ) M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ; dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement ) M: sqlite-db persistent-table ( -- assoc )
[
"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 )
H{ H{
{ +native-id+ "primary key" } { +native-id+ { "integer primary key" "integer primary key" f } }
{ +assigned-id+ "primary key" } { +assigned-id+ { f f "primary key" } }
{ +random-id+ "primary key" } { +random-id+ { "integer primary key" "integer primary key" f } }
! { +nonnative-id+ "primary key" } { INTEGER { "integer" "integer" "primary key" } }
{ +autoincrement+ "autoincrement" } { BIG-INTEGER { "bigint" "bigint" } }
{ +unique+ "unique" } { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ +default+ "default" } { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ +null+ "null" } { TEXT { "text" "text" } }
{ +not-null+ "not null" } { 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 ( str seq -- str' )
M: sqlite-db compound-type ( str seq -- str' )
over { over {
{ "default" [ first number>string join-space ] } { "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ] [ 2drop ]
} case ; } 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 ;

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

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math db.types continuations namespaces math math.ranges
prettyprint tools.walker db.sqlite calendar prettyprint tools.walker calendar sequences db.sqlite
math.intervals db.postgresql ; math.intervals db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real TUPLE: person the-id the-name the-number the-real
@ -106,13 +106,6 @@ SYMBOL: person4
[ ] [ person drop-table ] unit-test ; [ ] [ 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 ( -- ) : native-person-schema ( -- )
person "PERSON" person "PERSON"
{ {
@ -192,7 +185,6 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-repeated-insert : test-repeated-insert
[ ] [ person ensure-table ] unit-test [ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test [ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ; [ 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 H{ { 1 2 } } } }
] [ T{ serialize-me f 1 } select-tuples ] unit-test ; ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
[ test-serialize ] test-sqlite
! [ test-serialize ] test-postgresql
TUPLE: exam id name score ; TUPLE: exam id name score ;
: test-ranges ( -- ) : test-intervals ( -- )
exam "EXAM" exam "EXAM"
{ {
{ "id" "ID" +native-id+ } { "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 f "Cartman" 41 } insert-tuple ] unit-test
[ [
{
T{ exam f 3 "Kenny" 60 } T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 } 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 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 ; TUPLE: secret n message ;
C: <secret> secret C: <secret> secret
@ -246,27 +307,59 @@ C: <secret> secret
: test-random-id : test-random-id
secret "SECRET" secret "SECRET"
{ {
{ "n" "ID" +random-id+ } { "n" "ID" +random-id+ system-random-generator }
{ "message" "MESSAGE" TEXT } { "message" "MESSAGE" TEXT }
} define-persistent } define-persistent
[ ] [ secret ensure-table ] unit-test [ ] [ secret ensure-table ] unit-test
[ ] [ f "kilroy was here" <secret> insert-tuple ] 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 [ t ] [
[ native-person-schema test-tuples ] test-sqlite T{ secret } select-tuples
[ assigned-person-schema test-tuples ] test-sqlite first message>> "kilroy was here" head?
[ assigned-person-schema test-repeated-insert ] test-sqlite ] unit-test
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer [ t ] [
! \ update-tuple must-infer T{ secret } select-tuples length 3 =
! \ delete-tuple must-infer ] unit-test ;
! \ select-tuple must-infer
! \ define-persistent must-infer [ 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
! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
\ update-tuple must-infer
\ delete-tuple must-infer
\ select-tuple must-infer
\ define-persistent must-infer

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces 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 math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ; mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples IN: db.tuples
@ -13,15 +13,25 @@ IN: db.tuples
"db-columns" set-word-prop "db-columns" set-word-prop
"db-relations" set-word-prop ; "db-relations" set-word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ; ERROR: not-persistent ;
: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-relations ( class -- obj ) "db-relations" word-prop ; : 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 -- ) : set-primary-key ( key tuple -- )
[ [
class db-columns find-primary-key sql-spec-slot-name class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ; ] keep set-slot-named ;
SYMBOL: sql-counter
: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
! returns a sequence of prepared-statements ! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj ) HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-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 -- ) 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 ) : resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class new [ dup first sql-spec-class new [
[ [
@ -58,7 +102,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
] curry 2each ; ] curry 2each ;
: sql-props ( class -- columns table ) : sql-props ( class -- columns table )
dup db-columns swap db-table ; [ db-columns ] [ db-table ] bi ;
: with-disposals ( seq quot -- ) : with-disposals ( seq quot -- )
over sequence? [ over sequence? [
@ -85,17 +129,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
[ bind-tuple ] 2keep insert-tuple* ; [ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- ) : insert-nonnative ( tuple -- )
! TODO logic here for unique ids
dup class dup class
db get db-insert-statements [ <insert-nonnative-statement> ] cache db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
dup class db-columns find-primary-key nonnative-id? [ dup class db-columns find-primary-key nonnative-id?
insert-nonnative [ insert-nonnative ] [ insert-native ] if ;
] [
insert-native
] if ;
: update-tuple ( tuple -- ) : update-tuple ( tuple -- )
dup class 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 sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols mirrors classes.tuple combinators calendar.format symbols
classes.singleton ; classes.singleton accessors quotations random ;
IN: db.types IN: db.types
HOOK: modifier-table db ( -- hash ) HOOK: persistent-table db ( -- hash )
HOOK: compound-modifier db ( str seq -- hash ) HOOK: compound db ( str obj -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- 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: +native-id+
SINGLETON: +assigned-id+ SINGLETON: +assigned-id+
@ -24,50 +29,54 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ; +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 -- ? ) : primary-key? ( spec -- ? )
sql-spec-primary-key +primary-key+? ; primary-key>> +primary-key+? ;
: native-id? ( spec -- ? ) : native-id? ( spec -- ? )
sql-spec-primary-key +native-id+? ; primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? ) : nonnative-id? ( spec -- ? )
sql-spec-primary-key +nonnative-id+? ; primary-key>> +nonnative-id+? ;
: normalize-spec ( spec -- ) : normalize-spec ( spec -- )
dup sql-spec-type dup +primary-key+? [ dup type>> dup +primary-key+? [
swap set-sql-spec-primary-key >>primary-key drop
] [ ] [
drop dup sql-spec-modifiers [ drop dup modifiers>> [
+primary-key+? +primary-key+?
] deep-find ] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if* [ >>primary-key drop ] [ drop ] if*
] if ; ] if ;
: find-primary-key ( specs -- obj ) : find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ; [ primary-key>> ] find nip ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple ) : spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail* 3 f pad-right
{ [ first3 ] keep 3 tail
set-sql-spec-class sql-spec new
set-sql-spec-slot-name swap >>modifiers
set-sql-spec-column-name swap >>type
set-sql-spec-type swap >>column-name
set-sql-spec-modifiers swap >>slot-name
} sql-spec construct swap >>class
dup normalize-spec ; 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 ) : number>string* ( n/str -- str )
dup number? [ number>string ] when ; dup number? [ number>string ] when ;
@ -78,40 +87,40 @@ TUPLE: no-sql-modifier ;
[ relation? not ] subset ; [ relation? not ] subset ;
: remove-id ( specs -- obj ) : remove-id ( specs -- obj )
[ sql-spec-primary-key not ] subset ; [ primary-key>> not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html ! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB ! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types: ! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: lookup-modifier ( obj -- str ) ERROR: unknown-modifier ;
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "unknown modifier" throw ] unless
] if ;
: 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? [ dup array? [
first lookup-type* unclip (lookup-type) first nip
] [ ] [
type-table at* (lookup-type) first
[ no-sql-type ] unless
] if ; ] if ;
: lookup-create-type ( obj -- str ) : lookup-create-type ( obj -- str )
dup array? [ dup array? [
unclip lookup-create-type swap compound-type unclip (lookup-type) second swap compound
] [ ] [
dup create-type-table at* (lookup-type) second
[ nip ] [ drop lookup-type* ] if
] if ; ] if ;
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr ) : single-quote ( str -- newstr )
"'" swap "'" 3append ; "'" swap "'" 3append ;
@ -125,11 +134,11 @@ TUPLE: no-sql-modifier ;
" " swap 3append ; " " swap 3append ;
: modifiers ( spec -- str ) : modifiers ( spec -- str )
sql-spec-modifiers modifiers>> [ lookup-modifier ] map " " join
[ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ; dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- ) HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n ) : offset-of-slot ( str obj -- n )
class "slots" word-prop slot-named slot-spec-offset ; class "slots" word-prop slot-named slot-spec-offset ;
@ -145,6 +154,6 @@ HOOK: bind% db ( spec -- )
: tuple>params ( specs tuple -- obj ) : 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 get-slot-named swap
] curry { } map>assoc ; ] curry { } map>assoc ;

24
extra/project-euler/148/148.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences sequences.lib ;
IN: project-euler.148
<PRIVATE
: sum-1toN ( n -- sum )
dup 1+ * 2/ ; inline
: >base7 ( x -- y )
[ dup 0 > ] [ 7 /mod ] [ ] unfold nip ;
: (use-digit) ( prev x index -- next )
[ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
PRIVATE>
: (euler148) ( x -- y )
>base7 0 [ (use-digit) ] reduce-index ;
: euler148 ( -- y )
10 9 ^ (euler148) ;

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

@ -35,6 +35,10 @@ MACRO: firstn ( n -- )
#! quot: ( elt index -- obj ) #! quot: ( elt index -- obj )
prepare-index 2map ; inline prepare-index 2map ; inline
: reduce-index ( seq identity quot -- )
#! quot: ( prev elt index -- next )
swapd each-index ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- ) : each-percent ( seq quot -- )
@ -197,9 +201,6 @@ USE: continuations
>r >r 0 max r> r> >r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ; [ 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 ) : accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline V{ } clone [ [ push ] curry compose ] keep ; inline