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

Merge branch 'master' into unicode

db4
Daniel Ehrenberg 2008-02-16 00:54:18 -06:00
parent 7325d56b67 c1e7ee6bc6
commit b265c0d1dc
12 changed files with 102 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
extra/db/db.factor
View File

@ -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 ;

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

@ -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 )

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

@ -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 ) ;

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

@ -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 ;

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

@ -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 )

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

@ -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

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

@ -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 ;

2
extra/inverse/inverse.factor
View File

@ -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 -- )

18
extra/io/unix/select/select.factor
View File

@ -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 ;

4
extra/tools/profiler/profiler.factor
View File

@ -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. ;

2
extra/xml/tests/soap.factor
View File

@ -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

2
extra/xml/tests/test.factor
View File

@ -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