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

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

db4
Slava Pestov 2008-02-27 19:25:03 -06:00
parent 27c9b31288 3fcac9bd3d
commit 2c56031400
9 changed files with 191 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
extra/db/db.factor
View File

@ -12,9 +12,9 @@ TUPLE: db handle ;
db construct-boa ; db construct-boa ;
GENERIC: make-db* ( seq class -- db ) GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- ) GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- ) HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) : dispose-statements ( seq -- )
[ dispose drop ] assoc-each ; [ dispose drop ] assoc-each ;
@ -28,6 +28,9 @@ HOOK: db-close db ( handle -- )
] with-variable ; ] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: result-set sql params handle n max ;
: <statement> ( sql in out -- statement ) : <statement> ( sql in out -- statement )
{ {
set-statement-sql set-statement-sql
@ -35,17 +38,11 @@ TUPLE: statement handle sql in-params out-params bind-params bound? ;
set-statement-out-params set-statement-out-params
} statement construct ; } statement construct ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
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* ( obj statement -- ) GENERIC: bind-statement* ( statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: bind-tuple ( tuple statement -- ) GENERIC: bind-tuple ( tuple statement -- )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set ) GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n ) GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n ) GENERIC: #columns ( result-set -- n )
@ -53,6 +50,7 @@ GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ) GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? ) GENERIC: more-rows? ( result-set -- ? )
! must be called from within with-disposal
: execute-statement ( statement -- ) : execute-statement ( statement -- )
dup sequence? [ dup sequence? [
[ execute-statement ] each [ execute-statement ] each
@ -61,9 +59,8 @@ GENERIC: more-rows? ( result-set -- ? )
] if ; ] if ;
: bind-statement ( obj statement -- ) : bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-bind-params ] keep [ set-statement-bind-params ] keep
[ bind-statement* ] keep
t swap set-statement-bound? ; t swap set-statement-bound? ;
: init-result-set ( result-set -- ) : init-result-set ( result-set -- )

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

@ -38,10 +38,7 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- ) M: postgresql-db dispose ( db -- )
db-handle PQfinish ; db-handle PQfinish ;
M: postgresql-statement bind-statement* ( seq statement -- ) M: postgresql-statement bind-statement* ( statement -- )
set-statement-bind-params ;
M: postgresql-statement reset-statement ( statement -- )
drop ; drop ;
M: postgresql-statement bind-tuple ( tuple statement -- ) M: postgresql-statement bind-tuple ( tuple statement -- )

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

@ -4,7 +4,8 @@ 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 tuples alien.c-types prettyprint sequences strings tuples 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 tools.walker ; words combinators.lib db.types combinators tools.walker
combinators.cleave ;
IN: db.sqlite IN: db.sqlite
TUPLE: sqlite-db path ; TUPLE: sqlite-db path ;
@ -29,14 +30,13 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ; <prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj ) M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle
{ {
set-statement-sql set-statement-sql
set-statement-in-params set-statement-in-params
set-statement-out-params set-statement-out-params
set-statement-handle
} statement construct } statement construct
dup statement-handle over statement-sql sqlite-prepare db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ; sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- ) M: sqlite-statement dispose ( statement -- )
@ -45,20 +45,32 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ; f swap set-result-set-handle ;
: sqlite-bind ( specs handle -- ) : sqlite-bind ( triples handle -- )
swap [ sqlite-bind-type ] with each ; swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( obj statement -- ) : reset-statement ( statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ; statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi sqlite-bind ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[
[ sql-spec-column-name ":" swap append ]
[ sql-spec-slot-name rot get-slot-named ]
[ sql-spec-type ] tri 3array
] with map
] keep
[ set-statement-bind-params ] 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
dup zero? [ "last-id failed" throw ] when ; dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-tuple* ( tuple statement -- ) M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ; execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set #columns ( result-set -- n )
@ -78,7 +90,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ; sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set> dup statement-handle sqlite-result-set <result-set>
dup advance-row ; dup advance-row ;
@ -127,7 +138,7 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
: where-primary-key% ( specs -- ) : where-primary-key% ( specs -- )
" where " 0% " where " 0%
find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ; find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement ) M: sqlite-db <update-tuple-statement> ( class -- statement )
[ [
@ -135,7 +146,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0% 0%
" set " 0% " set " 0%
dup remove-id dup remove-id
[ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
where-primary-key% where-primary-key%
] sqlite-make ; ] sqlite-make ;
@ -144,7 +155,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0% "delete from " 0% 0%
" where " 0% " where " 0%
find-primary-key find-primary-key
sql-spec-column-name dup 0% " = " 0% bind% dup sql-spec-column-name 0% " = " 0% bind%
] sqlite-make ; ] sqlite-make ;
! : select-interval ( interval name -- ) ; ! : select-interval ( interval name -- ) ;
@ -152,8 +163,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
M: sqlite-db bind% ( spec -- ) M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ; dup 1, sql-spec-column-name ":" swap append 0% ;
! dup 1, sql-spec-column-name
! dup 0% " = " 0% ":" swap append 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement ) M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[ [
@ -201,7 +210,3 @@ M: sqlite-db type-table ( -- assoc )
M: sqlite-db create-type-table M: sqlite-db create-type-table
type-table ; type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;

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

@ -22,8 +22,9 @@ SYMBOL: the-person2
: test-tuples ( -- ) : test-tuples ( -- )
[ person drop-table ] [ drop ] recover [ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test [ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ the-person1 get insert-tuple ] unit-test [ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person1 get person-the-id ] unit-test [ 1 ] [ the-person1 get person-the-id ] unit-test
@ -108,11 +109,11 @@ annotation "ANNOTATION"
{ "contents" "CONTENTS" TEXT } { "contents" "CONTENTS" TEXT }
} define-persistent } define-persistent
{ "localhost" "postgres" "" "factor-test" } postgresql-db [ ! { "localhost" "postgres" "" "factor-test" } postgresql-db [
[ paste drop-table ] [ drop ] recover ! [ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover ! [ annotation drop-table ] [ drop ] recover
[ paste drop-table ] [ drop ] recover ! [ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover ! [ annotation drop-table ] [ drop ] recover
[ ] [ paste create-table ] unit-test ! [ ] [ paste create-table ] unit-test
[ ] [ annotation create-table ] unit-test ! [ ] [ annotation create-table ] unit-test
] with-db ! ] with-db

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

@ -63,16 +63,24 @@ HOOK: insert-tuple* db ( tuple statement -- )
: sql-props ( class -- columns table ) : sql-props ( class -- columns table )
dup db-columns swap db-table ; dup db-columns swap db-table ;
: create-table ( class -- ) create-sql-statement execute-statement ; : with-disposals ( seq quot -- )
: drop-table ( class -- ) drop-sql-statement execute-statement ; [ with-disposal ] curry each ;
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: insert-native ( tuple -- ) : insert-native ( tuple -- )
dup class <insert-native-statement> dup class <insert-native-statement> [
[ bind-tuple ] 2keep insert-tuple* ; [ bind-tuple ] 2keep dup . insert-tuple*
] with-disposal ;
: insert-assigned ( tuple -- ) : insert-assigned ( tuple -- )
dup class <insert-assigned-statement> dup class <insert-assigned-statement> [
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement
] with-disposal ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
dup class db-columns find-primary-key assigned-id? [ dup class db-columns find-primary-key assigned-id? [
@ -82,19 +90,21 @@ HOOK: insert-tuple* db ( tuple statement -- )
] if ; ] if ;
: update-tuple ( tuple -- ) : update-tuple ( tuple -- )
dup class <update-tuple-statement> dup class <update-tuple-statement> [
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement
] with-disposal ;
: update-tuples ( seq -- ) ! : update-tuples ( seq -- )
<update-tuples-statement> execute-statement ; ! <update-tuples-statement> execute-statement ;
: delete-tuple ( tuple -- ) : delete-tuple ( tuple -- )
dup class <delete-tuple-statement> dup class <delete-tuple-statement> [
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement
] with-disposal ;
: setup-select ( tuple -- statement ) : select-tuples ( tuple -- tuple )
dup dup class <select-by-slots-statement> dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep ; [ bind-tuple ] keep query-tuples
] with-disposal ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; : select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

52
extra/unix/stat/macosx/macosx.factor Normal file
View File

@ -0,0 +1,52 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! Mac OS X ppc
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__uint32_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "__int64_t" "st_qspare0" }
{ "__int64_t" "st_qspare1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: S_IFMT OCT: 170000 ; ! These bits determine file type.
: S_IFDIR OCT: 40000 ; ! Directory.
: S_IFCHR OCT: 20000 ; ! Character device.
: S_IFBLK OCT: 60000 ; ! Block device.
: S_IFREG OCT: 100000 ; ! Regular file.
: S_IFIFO OCT: 010000 ; ! FIFO.
: S_IFLNK OCT: 120000 ; ! Symbolic link.
: S_IFSOCK OCT: 140000 ; ! Socket.
: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;

29
extra/unix/types/linux/linux.factor Normal file
View File

@ -0,0 +1,29 @@
USING: alien.syntax ;
IN: unix.types
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulong __ulongword_type
TYPEDEF: uint __uword_type
TYPEDEF: long __slongword_type
TYPEDEF: int __sword_type
TYPEDEF: uint __u32_type
TYPEDEF: int __s32_type
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: __uquad_type dev_t
TYPEDEF: __ulongword_type ino_t
TYPEDEF: __u32_type mode_t
TYPEDEF: __uword_type nlink_t
TYPEDEF: __u32_type uid_t
TYPEDEF: __u32_type gid_t
TYPEDEF: __slongword_type off_t
TYPEDEF: __slongword_type blksize_t
TYPEDEF: __slongword_type blkcnt_t
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
TYPEDEF: __slongword_type time_t

26
extra/unix/types/macosx/macosx.factor Normal file
View File

@ -0,0 +1,26 @@
IN: unix.types
! Darwin 9.1.0 ppc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
TYPEDEF: longlong __int64_t
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: __int32_t dev_t
TYPEDEF: __uint32_t ino_t
TYPEDEF: __uint16_t mode_t
TYPEDEF: __uint16_t nlink_t
TYPEDEF: __uint32_t uid_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t

14
extra/unix/types/types.factor Normal file
View File

@ -0,0 +1,14 @@
USING: kernel system alien.syntax combinators vocabs.loader ;
IN: unix.types
TYPEDEF: void* caddr_t
os
{
{ "linux" [ "unix.types.linux" require ] }
{ "macosx" [ "unix.types.macosx" require ] }
[ drop ]
}
case