Merge branch 'master' of git://factorcode.org/git/factor
commit
9d940ebe3c
extra
db
postgresql
queries
sqlite
types
sequences/lib
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
@ -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 } }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ) ;
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Reference in New Issue