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-03 16:14:07 -06:00
parent ddf39459f2 d6185e224a
commit 7bc7f469c7
22 changed files with 923 additions and 246 deletions

23
extra/assocs/lib/lib.factor
View File

@ -1,9 +1,6 @@
USING: assocs kernel vectors sequences ;
USING: assocs kernel vectors sequences namespaces ;
IN: assocs.lib
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: >set ( seq -- hash )
[ dup ] H{ } map>assoc ;
@ -19,5 +16,19 @@ IN: assocs.lib
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
: at-peek ( key assoc -- value ? )
at* dup >r [ peek ] when r> ;
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: peek-at* ( key assoc -- obj ? )
at* dup [ >r peek r> ] when ;
: peek-at ( key assoc -- obj )
peek-at* drop ;
: >multi-assoc ( assoc -- new-assoc )
[ 1vector ] assoc-map ;
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;

4
extra/automata/automata.factor
View File

@ -1,6 +1,6 @@
USING: kernel math math.parser random arrays hashtables assocs sequences
vars strings.lib ;
vars ;
IN: automata
@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
! : stop-loop ( -- ) f >loop-flag ;
! : stop-loop ( -- ) f >loop-flag ;

104
extra/db/db.factor Normal file
View File

@ -0,0 +1,104 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ;
IN: db
TUPLE: db handle ;
C: <db> db ( handle -- obj )
! HOOK: db-create db ( str -- )
! HOOK: db-drop db ( str -- )
GENERIC: db-open ( db -- )
GENERIC: db-close ( db -- )
TUPLE: statement sql params handle bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: rebind-statement ( obj statement -- )
GENERIC: execute-statement ( statement -- )
: bind-statement ( obj statement -- )
2dup dup statement-bound? [
rebind-statement
] [
bind-statement*
] if
tuck set-statement-params
t swap set-statement-bound? ;
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
: init-result-set ( result-set -- )
dup #rows over set-result-set-max
-1 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
{
set-result-set-sql
set-result-set-params
set-result-set-handle
} result-set construct r> construct-delegate ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
: query-each ( statement quot -- )
over advance-row [
2drop
] [
[ call ] 2keep query-each
] if ; inline
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
: with-db ( db quot -- )
[
over db-open
[ db swap with-variable ] curry with-disposal
] with-scope ;
: do-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
<simple-statement> [ execute-statement ] with-disposal ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
HOOK: rollback-transaction db ( -- )
: in-transaction? ( -- ? ) in-transaction get ;
: with-transaction ( quot -- )
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;

0
extra/postgresql/authors.txt → extra/db/postgresql/authors.txt
View File

226
extra/postgresql/libpq/libpq.factor → extra/db/postgresql/ffi/ffi.factor
View File

@ -1,12 +1,10 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! adapted from libpq-fe.h version 7.4.7
! tested on debian linux with postgresql 7.4.7
! Updated to 8.1
! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;
IN: postgresql.libpq
IN: db.postgresql.ffi
<<
"postgresql" {
@ -17,45 +15,44 @@ IN: postgresql.libpq
>>
! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline
: CONNECTION_BAD HEX: 1 ; inline
: CONNECTION_STARTED HEX: 2 ; inline
: CONNECTION_MADE HEX: 3 ; inline
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
: CONNECTION_AUTH_OK HEX: 5 ; inline
: CONNECTION_SETENV HEX: 6 ; inline
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
: CONNECTION_NEEDED HEX: 8 ; inline
: CONNECTION_OK HEX: 0 ; inline
: CONNECTION_BAD HEX: 1 ; inline
: CONNECTION_STARTED HEX: 2 ; inline
: CONNECTION_MADE HEX: 3 ; inline
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
: CONNECTION_AUTH_OK HEX: 5 ; inline
: CONNECTION_SETENV HEX: 6 ; inline
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
: CONNECTION_NEEDED HEX: 8 ; inline
! PostgresPollingStatusType
: PGRES_POLLING_FAILED HEX: 0 ; inline
: PGRES_POLLING_READING HEX: 1 ; inline
: PGRES_POLLING_WRITING HEX: 2 ; inline
: PGRES_POLLING_OK HEX: 3 ; inline
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
: PGRES_POLLING_FAILED HEX: 0 ; inline
: PGRES_POLLING_READING HEX: 1 ; inline
: PGRES_POLLING_WRITING HEX: 2 ; inline
: PGRES_POLLING_OK HEX: 3 ; inline
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
! ExecStatusType;
: PGRES_EMPTY_QUERY HEX: 0 ; inline
: PGRES_COMMAND_OK HEX: 1 ; inline
: PGRES_TUPLES_OK HEX: 2 ; inline
: PGRES_COPY_OUT HEX: 3 ; inline
: PGRES_COPY_IN HEX: 4 ; inline
: PGRES_BAD_RESPONSE HEX: 5 ; inline
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
: PGRES_FATAL_ERROR HEX: 7 ; inline
: PGRES_EMPTY_QUERY HEX: 0 ; inline
: PGRES_COMMAND_OK HEX: 1 ; inline
: PGRES_TUPLES_OK HEX: 2 ; inline
: PGRES_COPY_OUT HEX: 3 ; inline
: PGRES_COPY_IN HEX: 4 ; inline
: PGRES_BAD_RESPONSE HEX: 5 ; inline
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
: PGRES_FATAL_ERROR HEX: 7 ; inline
! PGTransactionStatusType;
: PQTRANS_IDLE HEX: 0 ; inline
: PQTRANS_ACTIVE HEX: 1 ; inline
: PQTRANS_INTRANS HEX: 2 ; inline
: PQTRANS_INERROR HEX: 3 ; inline
: PQTRANS_UNKNOWN HEX: 4 ; inline
: PQTRANS_IDLE HEX: 0 ; inline
: PQTRANS_ACTIVE HEX: 1 ; inline
: PQTRANS_INTRANS HEX: 2 ; inline
: PQTRANS_INERROR HEX: 3 ; inline
: PQTRANS_UNKNOWN HEX: 4 ; inline
! PGVerbosity;
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
@ -81,7 +78,6 @@ LIBRARY: postgresql
! Exported functions of libpq
! === in fe-connect.c ===
! make a new client connection to the backend
! Asynchronous (non-blocking)
@ -91,12 +87,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
! Synchronous (blocking)
FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
char* pgoptions, char* pgtty,
char* dbName,
char* login, char* pwd ) ;
char* pgoptions, char* pgtty,
char* dbName,
char* login, char* pwd ) ;
: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
f f PQsetdbLogin ;
f f PQsetdbLogin ;
! close the current connection and free the PGconn data structure
FUNCTION: void PQfinish ( PGconn* conn ) ;
@ -112,7 +108,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
! parameters
!
! Asynchronous (non-blocking)
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
! Synchronous (blocking)
@ -125,7 +121,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
! issue a cancel request
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
! Accessor functions for PGconn objects
FUNCTION: char* PQdb ( PGconn* conn ) ;
@ -138,14 +134,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ;
FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
FUNCTION: char* PQparameterStatus ( PGconn* conn,
char* paramName ) ;
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
FUNCTION: int PQServerVersion ( PGconn* conn ) ;
char* paramName ) ;
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
! FUNCTION: int PQServerVersion ( PGconn* conn ) ;
FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
FUNCTION: int PQsocket ( PGconn* conn ) ;
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
FUNCTION: int PQsocket ( PGconn* conn ) ;
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
! May not be compiled into libpq
! Get the SSL structure associated with a connection
@ -156,7 +152,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
! Set verbosity for PQerrorMessage and PQresultErrorMessage
FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
PGVerbosity verbosity ) ;
PGVerbosity verbosity ) ;
! Enable/disable tracing
FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
@ -171,11 +167,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Override default notice handling routines
! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
! PQnoticeReceiver proc,
! void* arg ) ;
! PQnoticeReceiver proc,
! void* arg ) ;
! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
! PQnoticeProcessor proc,
! void* arg ) ;
! PQnoticeProcessor proc,
! void* arg ) ;
! END BROKEN
! === in fe-exec.c ===
@ -183,83 +179,83 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Simple synchronous query
FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
FUNCTION: PGresult* PQexecParams ( PGconn* conn,
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
char* stmtName,
int nParams,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* stmtName,
int nParams,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
! Interface for multiple-result or asynchronous queries
FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
FUNCTION: int PQsendQueryParams ( PGconn* conn,
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
char* stmtName,
int nParams,
char** paramValues,
int *paramLengths,
int *paramFormats,
int resultFormat ) ;
char* stmtName,
int nParams,
char** paramValues,
int *paramLengths,
int *paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
! Routines for managing an asynchronous query
FUNCTION: int PQisBusy ( PGconn* conn ) ;
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
FUNCTION: int PQisBusy ( PGconn* conn ) ;
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
! LISTEN/NOTIFY support
FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
! Routines for copy in/out
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
! Deprecated routines for copy in/out
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQendcopy ( PGconn* conn ) ;
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQendcopy ( PGconn* conn ) ;
! Set blocking/nonblocking connection to the backend
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
! Force the write buffer to be written (or at least try)
FUNCTION: int PQflush ( PGconn* conn ) ;
FUNCTION: int PQflush ( PGconn* conn ) ;
!
! * "Fast path" interface --- not really recommended for application
! * use
!
FUNCTION: PGresult* PQfn ( PGconn* conn,
int fnid,
int* result_buf,
int* result_len,
int result_is_int,
PQArgBlock* args,
int nargs ) ;
int fnid,
int* result_buf,
int* result_len,
int result_is_int,
PQArgBlock* args,
int nargs ) ;
! Accessor functions for PGresult objects
FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
@ -313,7 +309,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
! These forms are deprecated!
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
size_t* bytealen ) ;
size_t* bytealen ) ;
! === in fe-print.c ===
@ -332,30 +328,28 @@ FUNCTION: void PQprintTuples ( PGresult* res,
int printAttName,
int terseOutput,
int width ) ;
! === in fe-lobj.c ===
! Large-object access routines
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
! === in fe-misc.c ===
! Determine length of multibyte encoded char at *s
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
! Determine display length of multibyte encoded char at *s
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
! Get encoding id from environment variable PGCLIENTENCODING
FUNCTION: int PQenv2encoding ( ) ;
FUNCTION: int PQenv2encoding ( ) ;

44
extra/db/postgresql/lib/lib.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
PQresultErrorMessage [ CHAR: \n = ] right-trim
] if ;
: postgres-result-error ( res -- )
postgresql-result-error-message [ throw ] when* ;
: postgresql-error-message ( -- str )
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
: postgresql-result-ok? ( n -- ? )
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
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
] unless ;
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params [ malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;

110
extra/db/postgresql/postgresql-tests.factor Normal file
View File

@ -0,0 +1,110 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db ;
IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
IN: temporary
[ ] [ test-db [ ] with-db ] unit-test
[ ] [
test-db [
[ "drop table person;" sql-command ] catch drop
"create table person (name varchar(30), country varchar(30));"
sql-command
"insert into person values('John', 'America');" sql-command
"insert into person values('Jane', 'New Zealand');" sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test-db [
"select * from person" sql-query
] with-db
] unit-test
[
{ { "John" "America" } }
] [
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
{ "Jane" "New Zealand" }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ "John" "America" }
swap do-bound-query
] with-disposal
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
] [
test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-db
] unit-test-fails
[ 3 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-db
] unit-test
[ 5 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test

105
extra/db/postgresql/postgresql.factor Normal file
View File

@ -0,0 +1,105 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
kernel math namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement -- postgresql-statement )
postgresql-statement construct-delegate ;
: <postgresql-db> ( host user pass db -- obj )
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} postgresql-db construct ;
M: postgresql-db db-open ( db -- )
dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
postgresql-db-pgtty
postgresql-db-db
postgresql-db-user
postgresql-db-pass
} get-slots connect-postgres <db> swap set-delegate ;
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-params ;
M: postgresql-statement rebind-statement ( seq statement -- )
bind-statement* ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ;
M: postgresql-result-set row-column ( result-set n -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
M: postgresql-statement execute-statement ( statement -- )
query-results dispose ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
dup do-postgresql-statement
] if*
postgresql-result-set <result-set>
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- ? )
dup increment-n swap result-set-max >= ;
M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear
f swap set-statement-handle ;
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 ;
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-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 ;

2
extra/db/sqlite/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Chris Double
Doug Coleman

130
extra/db/sqlite/ffi/ffi.factor Normal file
View File

@ -0,0 +1,130 @@
! Copyright (C) 2005 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
!
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped yet. Only those directly involving
! executing SQL calls and obtaining results.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ;
IN: db.sqlite.ffi
<<
"sqlite" {
{ [ winnt? ] [ "sqlite3.dll" ] }
{ [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
{ [ unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library >>
! Return values from sqlite functions
: SQLITE_OK 0 ; inline ! Successful result
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
: SQLITE_PERM 3 ; inline ! Access permission denied
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
: SQLITE_BUSY 5 ; inline ! The database file is locked
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
: SQLITE_AUTH 23 ; inline ! Authorization denied
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
: sqlite-error-messages ( -- seq ) {
"Successful result"
"SQL error or missing database"
"An internal logic error in SQLite"
"Access permission denied"
"Callback routine requested an abort"
"The database file is locked"
"A table in the database is locked"
"A malloc() failed"
"Attempt to write a readonly database"
"Operation terminated by sqlite_interrupt()"
"Some kind of disk I/O error occurred"
"The database disk image is malformed"
"(Internal Only) Table or record not found"
"Insertion failed because database is full"
"Unable to open the database file"
"Database lock protocol error"
"(Internal Only) Database table is empty"
"The database schema changed"
"Too much data for one row of a table"
"Abort due to contraint violation"
"Data type mismatch"
"Library used incorrectly"
"Uses OS features not supported on host"
"Authorization denied"
"Auxiliary database format error"
"2nd parameter to sqlite3_bind out of range"
"File opened that is not a database file"
} ;
: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
! Return values from the sqlite3_column_type function
: SQLITE_INTEGER 1 ; inline
: SQLITE_FLOAT 2 ; inline
: SQLITE_TEXT 3 ; inline
: SQLITE_BLOB 4 ; inline
: SQLITE_NULL 5 ; inline
! Values for the 'destructor' parameter of the 'bind' routines.
: SQLITE_STATIC 0 ; inline
: SQLITE_TRANSIENT -1 ; inline
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( 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: int 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_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
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: 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 ) ;

85
extra/db/sqlite/lib/lib.factor Normal file
View File

@ -0,0 +1,85 @@
! Copyright (C) 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types assocs kernel math math.parser sequences
db.sqlite.ffi ;
IN: db.sqlite.lib
TUPLE: sqlite-error n message ;
: sqlite-check-result ( result -- )
dup SQLITE_OK = [
drop
] [
dup sqlite-error-messages nth
sqlite-error construct-boa throw
] if ;
: sqlite-open ( filename -- db )
"void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
: sqlite-close ( db -- )
sqlite3_close sqlite-check-result ;
: sqlite-last-insert-rowid ( db -- rowid )
sqlite3_last_insert_rowid ;
: sqlite-prepare ( db sql -- statement )
#! TODO: Support multiple statements in the SQL string.
dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-text ( statement index text -- )
dup number? [ number>string ] when
dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
: sqlite-bind-parameter-index ( statement name -- index )
sqlite3_bind_parameter_index ;
: sqlite-bind-text-by-name ( statement name text -- )
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
: sqlite-bind-assoc ( statement assoc -- )
swap [
-rot sqlite-bind-text-by-name
] curry assoc-each ;
: sqlite-finalize ( statement -- )
sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( statement -- )
sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
: sqlite-column ( statement index -- string )
sqlite3_column_text ;
: sqlite-row ( statement -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
! 2dup sqlite3_column_type .
! SQLITE_INTEGER 1
! SQLITE_FLOAT 2
! SQLITE_TEXT 3
! SQLITE_BLOB 4
! SQLITE_NULL 5
: step-complete? ( step-result -- bool )
dup SQLITE_ROW = [
drop f
] [
dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
] if ;
: sqlite-step ( prepared -- )
dup sqlite3_step step-complete? [
drop
] [
sqlite-step
] if ;
: sqlite-next ( prepared -- ? )
sqlite3_step step-complete? ;

110
extra/db/sqlite/sqlite-tests.factor Normal file
View File

@ -0,0 +1,110 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db db.sql sequences
continuations ;
IN: temporary
! "sqlite3 -init test.txt test.db"
IN: scratchpad
: test.db "extra/db/sqlite/test.db" resource-path ;
IN: temporary
: (create-db) ( -- str )
[
"sqlite3 -init " %
test.db %
" " %
test.db %
] "" make ;
: create-db ( -- ) (create-db) run-process drop ;
[ ] [ test.db delete-file ] unit-test
[ ] [ create-db ] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test.db [
"select * from person" sql-query
] with-sqlite
] unit-test
[
{ { "John" "America" } }
] [
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" } { ":country" "New Zealand" } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { ":name" "John" } { ":country" "America" } }
swap do-bound-query
] with-disposal
] with-sqlite
] unit-test
[
{
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-sqlite
] unit-test
[
{
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
test.db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-sqlite
] unit-test-fails
[ 3 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test
[
] [
test.db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-sqlite
] unit-test
[ 5 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test

74
extra/db/sqlite/sqlite.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db db.sql
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi ;
IN: db.sqlite
TUPLE: sqlite-db path ;
C: <sqlite-db> sqlite-db
M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
M: sqlite-db dispose ( obj -- )
dup db-handle sqlite-close
f over set-db-handle
f swap set-delegate ;
: with-sqlite ( path quot -- )
>r <sqlite-db> r> with-db ; inline
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare
{ set-statement-sql set-statement-handle } statement construct
<sqlite-statement> [ set-delegate ] keep ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
M: sqlite-statement bind-statement* ( assoc statement -- )
statement-handle swap sqlite-bind-assoc ;
M: sqlite-statement rebind-statement ( assoc statement -- )
dup statement-handle sqlite-reset
statement-handle swap sqlite-bind-assoc ;
M: sqlite-statement execute-statement ( statement -- )
statement-handle sqlite-next drop ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
M: sqlite-result-set advance-row ( result-set -- handle ? )
result-set-handle sqlite-next ;
M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ;
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- )
"COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;

3
extra/db/sqlite/test.txt Normal file
View File

@ -0,0 +1,3 @@
create table person (name varchar(30), country varchar(30));
insert into person values('John', 'America');
insert into person values('Jane', 'New Zealand');

4
extra/http/client/client.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting
continuations ;
continuations assocs.lib ;
IN: http.client
: parse-host ( url -- host port )
@ -44,7 +44,7 @@ DEFER: http-get-stream
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
dispose "Location" swap at nip http-get-stream
dispose "location" swap peek-at nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )

6
extra/http/http.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ascii io.utf8 ;
sequences strings splitting ascii io.utf8 assocs.lib
namespaces unicode.case ;
IN: http
: header-line ( line -- )
": " split1 dup [ swap set ] [ 2drop ] if ;
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
@ -71,4 +72,3 @@ IN: http
hash>query %
] if
] "" make ;

28
extra/http/server/responders/responders.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
strings io.server ;
strings io.server vectors assocs.lib ;
IN: http.server.responders
@ -10,8 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts
SYMBOL: responders
: >header ( value key -- multi-hash )
H{ } clone [ insert-at ] keep ;
: print-header ( alist -- )
[ swap write ": " write print ] assoc-each nl ;
[ swap write ": " write print ] multi-assoc-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
@ -20,7 +23,7 @@ SYMBOL: responders
: error-head ( error -- )
dup log-error response
H{ { "Content-Type" "text/html" } } print-header nl ;
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
: httpd-error ( error -- )
#! This must be run from handle-request
@ -36,7 +39,7 @@ SYMBOL: responders
: serving-content ( mime -- )
"200 Document follows" response
"Content-Type" associate print-header ;
"Content-Type" >header print-header ;
: serving-html "text/html" serving-content ;
@ -46,7 +49,7 @@ SYMBOL: responders
: serving-text "text/plain" serving-content ;
: redirect ( to response -- )
response "Location" associate print-header ;
response "Location" >header print-header ;
: permanent-redirect ( to -- )
"301 Moved Permanently" redirect ;
@ -84,14 +87,14 @@ SYMBOL: max-post-request
: log-headers ( hash -- )
[
drop {
"User-Agent"
"Referer"
"X-Forwarded-For"
"Host"
"user-agent"
"referer"
"x-forwarded-for"
"host"
} member?
] assoc-subset [
": " swap 3append log-message
] assoc-each ;
] multi-assoc-each ;
: prepare-url ( url -- url )
#! This is executed in the with-request namespace.
@ -122,7 +125,8 @@ SYMBOL: max-post-request
: query-param ( key -- value ) "query" get at ;
: header-param ( key -- value ) "header" get at ;
: header-param ( key -- value )
"header" get peek-at ;
: host ( -- string )
#! The host the current responder was called from.
@ -130,7 +134,7 @@ SYMBOL: max-post-request
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over at responders get set-at ;
"responder" over at responders get set-at ;
: make-responder ( quot -- )
#! quot has stack effect ( url -- )

42
extra/postgresql/postgresql-tests.factor
View File

@ -1,42 +0,0 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
IN: postgresql-test
USING: kernel postgresql alien continuations io prettyprint
sequences namespaces ;
: test-connection ( host port pgopts pgtty db user pass -- bool )
[ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
! just a basic demo
"localhost" "" "" "" "test" "postgres" "" [
"drop table animal" do-command
"create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
"insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
do-command
"select * from animal where name = 'Mufasa'" [ ] do-query
"select * from animal where name = 'Mufasa'"
[
result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
] do-query
"insert into animal (species, name, age) values ('lion', 'Simba', 1)"
do-command
"select * from animal"
[
"Animal table:" print
result>seq print-table
] do-query
! intentional errors
! [ "select asdf from animal"
! [ ] do-query ] catch [ "caught: " write print ] when*
! "select asdf from animal" [ ] do-query
! "aofijweafew" do-command
] with-postgres

61
extra/postgresql/postgresql.factor
View File

@ -1,61 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! adapted from libpq-fe.h version 7.4.7
! tested on debian linux with postgresql 7.4.7
USING: arrays alien alien.syntax continuations io
kernel math namespaces postgresql.libpq prettyprint
quotations sequences debugger ;
IN: postgresql
SYMBOL: db
SYMBOL: query-res
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
: with-postgres ( host port pgopts pgtty db user pass quot -- )
[ >r connect-postgres db set r>
[ db get PQfinish ] [ ] cleanup ] with-scope ; inline
: postgres-error ( ret -- ret )
dup zero? [ PQresultErrorMessage throw ] when ;
: (do-query) ( PGconn query -- PGresult* )
! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
PQexec
dup PQresultStatus PGRES_COMMAND_OK =
over PQresultStatus PGRES_TUPLES_OK =
or [
[ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
] unless ;
: (do-command) ( PGconn query -- PGresult* )
[ (do-query) ] catch
[
swap
"non-fatal error: " print
"\tQuery: " write "'" write write "'" print
"\t" write print
] when* drop ;
: do-command ( str -- )
1quotation \ (do-command) add db get swap call ;
: prepare ( str quot word -- conn quot )
rot 1quotation swap append swap append db get swap ;
: do-query ( str quot -- )
[ (do-query) query-res set ] prepare catch
[ rethrow ] [ query-res get PQclear ] if* ;
: result>seq ( -- seq )
query-res get [ PQnfields ] keep PQntuples
[ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
: print-table ( seq -- )
[ [ write bl ] each "\n" write ] each ;

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

@ -141,6 +141,9 @@ PRIVATE>
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq

2
extra/unicode/case/case.factor
View File

@ -1,6 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces
assocs.lib unicode.normalize math unicode.categories combinators
assocs ;
assocs strings splitting ;
IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ;

3
misc/factor.sh
View File

@ -289,7 +289,7 @@ install_libraries() {
}
usage() {
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap"
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
}
case "$1" in
@ -299,5 +299,6 @@ case "$1" in
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;;
esac