Merge branch 'master' into unicode
commit
b265c0d1dc
|
@ -4,12 +4,9 @@ USING: arrays assocs classes continuations kernel math
|
|||
namespaces sequences sequences.lib tuples words strings ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
|
||||
TUPLE: db handle insert-statements update-statements delete-statements ;
|
||||
: <db> ( handle -- obj )
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone H{ } clone H{ } clone
|
||||
db construct-boa ;
|
||||
|
||||
GENERIC: db-open ( db -- )
|
||||
|
@ -23,11 +20,10 @@ HOOK: db-close db ( handle -- )
|
|||
dup db-insert-statements dispose-statements
|
||||
dup db-update-statements dispose-statements
|
||||
dup db-delete-statements dispose-statements
|
||||
dup db-select-statements dispose-statements
|
||||
db-handle db-close
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
TUPLE: statement sql params handle bound? slot-names ;
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
|
||||
|
@ -115,5 +111,7 @@ HOOK: rollback-transaction db ( -- )
|
|||
dup string? [
|
||||
<simple-statement> [ execute-statement ] with-disposal
|
||||
] [
|
||||
[ [ sql-command ] each ] with-transaction
|
||||
! [
|
||||
[ sql-command ] each
|
||||
! ] with-transaction
|
||||
] if ;
|
||||
|
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs alien alien.syntax continuations io
|
||||
kernel math math.parser namespaces prettyprint quotations
|
||||
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 ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
|
@ -52,11 +53,19 @@ M: postgresql-result-set #columns ( result-set -- n )
|
|||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
|
||||
>r row-column r> sql-type>factor-type ;
|
||||
|
||||
M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
|
||||
{
|
||||
{ INTEGER [ string>number ] }
|
||||
{ BIG_INTEGER [ string>number ] }
|
||||
{ DOUBLE [ string>number ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
M: postgresql-statement insert-statement ( statement -- id )
|
||||
query-results [ break 0 row-column ] with-disposal ;
|
||||
query-results [ 0 row-column ] with-disposal string>number ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup statement-params [
|
||||
|
@ -202,7 +211,7 @@ M: postgresql-db drop-sql ( columns table -- seq )
|
|||
over native-id? [ drop-function , ] [ 2drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db insert-sql* ( columns table -- sql )
|
||||
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
|
||||
[
|
||||
"select add_" % %
|
||||
"(" %
|
||||
|
@ -210,7 +219,7 @@ M: postgresql-db insert-sql* ( columns table -- sql )
|
|||
")" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db update-sql* ( columns table -- sql )
|
||||
M: postgresql-db update-sql* ( columns table -- slot-names sql )
|
||||
[
|
||||
"update " %
|
||||
%
|
||||
|
@ -222,7 +231,7 @@ M: postgresql-db update-sql* ( columns table -- sql )
|
|||
[ primary-key? ] find nip second dup % " = $" % length 2 + #
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db delete-sql* ( columns table -- sql )
|
||||
M: postgresql-db delete-sql* ( columns table -- slot-names sql )
|
||||
[
|
||||
"delete from " %
|
||||
%
|
||||
|
@ -230,7 +239,7 @@ M: postgresql-db delete-sql* ( columns table -- sql )
|
|||
first second % " = $1" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db select-sql* ( columns table -- sql )
|
||||
M: postgresql-db select-sql ( columns table -- slot-names sql )
|
||||
drop ;
|
||||
|
||||
M: postgresql-db tuple>params ( columns tuple -- obj )
|
||||
|
|
|
@ -125,6 +125,8 @@ 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 ) ;
|
||||
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
|
@ -96,6 +96,14 @@ IN: db.sqlite.lib
|
|||
: sqlite-column ( handle index -- string )
|
||||
sqlite3_column_text ;
|
||||
|
||||
: sqlite-column-typed ( handle index type -- obj )
|
||||
{
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG_INTEGER [ sqlite3_column_int64 ] }
|
||||
{ TEXT [ sqlite3_column_text ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
} case ;
|
||||
|
||||
! TODO
|
||||
: sqlite-row ( handle -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
|
|
@ -63,6 +63,9 @@ M: sqlite-result-set #columns ( result-set -- n )
|
|||
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||
>r result-set-handle r> sqlite-column ;
|
||||
|
||||
M: sqlite-result-set row-column-typed ( result-set n type -- obj )
|
||||
>r result-set-handle r> sqlite-column-typed ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- )
|
||||
[ result-set-handle sqlite-next ] keep
|
||||
set-sqlite-result-set-has-more? ;
|
||||
|
@ -111,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
|
|||
")" %
|
||||
] "" make ;
|
||||
|
||||
: where-primary-key% ( columns -- )
|
||||
" where " %
|
||||
[ primary-key? ] find nip second dup % " = :" % % ;
|
||||
|
||||
M: sqlite-db update-sql* ( columns table -- sql )
|
||||
[
|
||||
"update " %
|
||||
|
@ -118,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
|
|||
" set " %
|
||||
dup remove-id
|
||||
[ ", " % ] [ second dup % " = :" % % ] interleave
|
||||
" where " %
|
||||
[ primary-key? ] find nip second dup % " = :" % %
|
||||
where-primary-key%
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db delete-sql* ( columns table -- sql )
|
||||
|
@ -130,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
|
|||
first second dup % " = :" % %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db select-sql* ( columns table -- sql )
|
||||
: select-interval ( interval name -- )
|
||||
;
|
||||
|
||||
: select-sequence ( seq name -- )
|
||||
;
|
||||
|
||||
M: sqlite-db select-sql ( columns table -- sql )
|
||||
[
|
||||
"select ROWID, " %
|
||||
swap [ ", " % ] [ second % ] interleave
|
||||
" from " %
|
||||
%
|
||||
" where ROWID = :ID" %
|
||||
over [ ", " % ] [ second % ] interleave
|
||||
" from " % %
|
||||
" where " %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db tuple>params ( columns tuple -- obj )
|
||||
|
|
|
@ -31,7 +31,7 @@ SYMBOL: the-person
|
|||
[ ] [ the-person get update-tuple ] unit-test
|
||||
|
||||
[ ] [ the-person get delete-tuple ] unit-test
|
||||
[ ] [ person drop-table ] unit-test ;
|
||||
; ! 1 [ ] [ person drop-table ] unit-test ;
|
||||
|
||||
: test-sqlite ( -- )
|
||||
"tuples-test.db" resource-path <sqlite-db> [
|
||||
|
@ -54,17 +54,17 @@ person "PERSON"
|
|||
"billy" 10 3.14 <person> the-person set
|
||||
|
||||
! test-sqlite
|
||||
test-postgresql
|
||||
test-postgresql
|
||||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" INTEGER +assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
} define-persistent
|
||||
! person "PERSON"
|
||||
! {
|
||||
! { "the-id" "ID" INTEGER +assigned-id+ }
|
||||
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
! { "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
! { "real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
! } define-persistent
|
||||
|
||||
1 "billy" 20 6.28 <assigned-person> the-person set
|
||||
! 1 "billy" 20 6.28 <assigned-person> the-person set
|
||||
|
||||
! test-sqlite
|
||||
! test-postgresql
|
||||
|
|
|
@ -41,10 +41,25 @@ TUPLE: no-slot-named ;
|
|||
HOOK: create-sql db ( columns table -- seq )
|
||||
HOOK: drop-sql db ( columns table -- seq )
|
||||
|
||||
HOOK: insert-sql* db ( columns table -- sql )
|
||||
HOOK: update-sql* db ( columns table -- sql )
|
||||
HOOK: delete-sql* db ( columns table -- sql )
|
||||
HOOK: select-sql* db ( columns table -- sql )
|
||||
HOOK: insert-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: update-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: delete-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: select-sql db ( tuple -- statement )
|
||||
|
||||
HOOK: row-column-typed db ( result-set n type -- sql )
|
||||
HOOK: sql-type>factor-type db ( obj type -- obj )
|
||||
HOOK: tuple>params db ( columns tuple -- obj )
|
||||
|
||||
|
||||
HOOK: make-slot-names* db ( quot -- seq )
|
||||
HOOK: column-slot-name% db ( spec -- )
|
||||
HOOK: column-bind-name% db ( spec -- )
|
||||
|
||||
: make-slots-names ( quot -- seq str )
|
||||
[ make-slot-names* ] "" make ; inline
|
||||
: slot-name% ( seq -- ) first % ;
|
||||
: column-name% ( seq -- ) second % ;
|
||||
: column-type% ( seq -- ) third % ;
|
||||
|
||||
: insert-sql ( columns class -- statement )
|
||||
db get db-insert-statements [ insert-sql* ] cache-statement ;
|
||||
|
@ -55,10 +70,6 @@ HOOK: select-sql* db ( columns table -- sql )
|
|||
: delete-sql ( columns class -- statement )
|
||||
db get db-delete-statements [ delete-sql* ] cache-statement ;
|
||||
|
||||
: select-sql ( columns class -- statement )
|
||||
db get db-select-statements [ select-sql* ] cache-statement ;
|
||||
|
||||
HOOK: tuple>params db ( columns tuple -- obj )
|
||||
|
||||
: tuple-statement ( columns tuple quot -- statement )
|
||||
>r [ tuple>params ] 2keep class r> call
|
||||
|
@ -90,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
|
|||
: delete-tuple ( tuple -- )
|
||||
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
|
||||
|
||||
! : select-tuple ( tuple -- )
|
||||
! [ select-sql ] bind-tuple do-query ;
|
||||
: select-tuple ( tuple -- )
|
||||
[ select-sql ] keep do-query ;
|
||||
|
||||
: persist ( tuple -- )
|
||||
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
|
||||
|
|
|
@ -100,7 +100,7 @@ M: math-inverse inverse
|
|||
[ drop swap-inverse ] [ pull-inverse ] if ;
|
||||
|
||||
M: pop-inverse inverse
|
||||
[ "pop-length" word-prop cut-slice swap ] keep
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ] keep
|
||||
"pop-inverse" word-prop compose call ;
|
||||
|
||||
: (undo) ( revquot -- )
|
||||
|
|
|
@ -17,14 +17,18 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
|
||||
|
||||
: clear-nth ( n seq -- ? )
|
||||
[ nth ] 2keep f -rot set-nth ;
|
||||
|
||||
: handle-fd ( fd task fdset mx -- )
|
||||
roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ;
|
||||
roll munge rot clear-nth
|
||||
[ swap handle-io-task ] [ 2drop ] if ;
|
||||
|
||||
: handle-fdset ( tasks fdset mx -- )
|
||||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
dup clear-bits
|
||||
! dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
|
@ -33,13 +37,19 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
: write-fdset/tasks
|
||||
{ mx-writes select-mx-write-fdset } get-slots ;
|
||||
|
||||
: init-fdsets ( mx -- read write except )
|
||||
: max-fd dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||
|
||||
: num-fds ( mx -- n )
|
||||
dup mx-reads max-fd swap mx-writes max-fd max 1+ ;
|
||||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ] keep
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r FD_SETSIZE over init-fdsets r> make-timeval
|
||||
swap >r dup init-fdsets r> make-timeval
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick handle-fdset
|
||||
dup write-fdset/tasks rot handle-fdset ;
|
||||
|
|
|
@ -59,5 +59,7 @@ M: string (profile.)
|
|||
: vocabs-profile. ( -- )
|
||||
"Call counts for all vocabularies:" print
|
||||
vocabs [
|
||||
dup words [ profile-counter ] map sum
|
||||
dup words
|
||||
[ "predicating" word-prop not ] subset
|
||||
[ profile-counter ] map sum
|
||||
] { } map>assoc counters. ;
|
||||
|
|
|
@ -9,6 +9,6 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
|
|||
[ assemble-data ] map ;
|
||||
|
||||
[ "http://www.foxnews.com/oreilly/" ] [
|
||||
"extra/xml/test/soap.xml" resource-path file>xml
|
||||
"extra/xml/tests/soap.xml" resource-path file>xml
|
||||
parse-result first first
|
||||
] unit-test
|
||||
|
|
|
@ -7,7 +7,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
|
|||
|
||||
! This is insufficient
|
||||
SYMBOL: xml-file
|
||||
[ ] [ "extra/xml/test/test.xml" resource-path
|
||||
[ ] [ "extra/xml/tests/test.xml" resource-path
|
||||
[ file>xml ] with-html-entities xml-file set ] unit-test
|
||||
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
|
||||
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
|
||||
|
|
Loading…
Reference in New Issue