diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 849f88023f..182f04a367 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -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 ; diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index 732033fb75..cd799d477e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -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 ; \ No newline at end of file +! : stop-loop ( -- ) f >loop-flag ; diff --git a/extra/db/db.factor b/extra/db/db.factor new file mode 100644 index 0000000000..b765924cd6 --- /dev/null +++ b/extra/db/db.factor @@ -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 ( 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: db ( str -- statement ) +HOOK: 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 ; + +: ( 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 ) + [ do-query ] with-disposal ; + +: sql-command ( sql -- ) + [ 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 ; diff --git a/extra/postgresql/authors.txt b/extra/db/postgresql/authors.txt similarity index 100% rename from extra/postgresql/authors.txt rename to extra/db/postgresql/authors.txt diff --git a/extra/postgresql/libpq/libpq.factor b/extra/db/postgresql/ffi/ffi.factor similarity index 56% rename from extra/postgresql/libpq/libpq.factor rename to extra/db/postgresql/ffi/ffi.factor index faeb3f9aa4..dbaa70c625 100644 --- a/extra/postgresql/libpq/libpq.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -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 ( ) ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor new file mode 100644 index 0000000000..a940a42ae4 --- /dev/null +++ b/extra/db/postgresql/lib/lib.factor @@ -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 ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor new file mode 100644 index 0000000000..c5a5155d12 --- /dev/null +++ b/extra/db/postgresql/postgresql-tests.factor @@ -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" ; +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" + [ + { "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 diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor new file mode 100644 index 0000000000..df778cc80d --- /dev/null +++ b/extra/db/postgresql/postgresql.factor @@ -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 ; +: ( statement -- postgresql-statement ) + postgresql-statement construct-delegate ; + +: ( 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 swap set-delegate ; + +M: postgresql-db dispose ( db -- ) + db-handle PQfinish ; + +: with-postgresql ( host ust pass db quot -- ) + >r 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 + 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 ( sql -- statement ) + { set-statement-sql } statement construct + ; + +M: postgresql-db ( sql -- statement ) + { set-statement-sql } statement construct + ; + +M: postgresql-db begin-transaction ( -- ) + "BEGIN" sql-command ; + +M: postgresql-db commit-transaction ( -- ) + "COMMIT" sql-command ; + +M: postgresql-db rollback-transaction ( -- ) + "ROLLBACK" sql-command ; diff --git a/extra/db/sqlite/authors.txt b/extra/db/sqlite/authors.txt new file mode 100644 index 0000000000..26093b451b --- /dev/null +++ b/extra/db/sqlite/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Doug Coleman diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor new file mode 100644 index 0000000000..609c597b35 --- /dev/null +++ b/extra/db/sqlite/ffi/ffi.factor @@ -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 ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor new file mode 100644 index 0000000000..e5f8425d92 --- /dev/null +++ b/extra/db/sqlite/lib/lib.factor @@ -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*" + [ 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*" "void*" + [ 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? ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor new file mode 100644 index 0000000000..f64b8d1104 --- /dev/null +++ b/extra/db/sqlite/sqlite-tests.factor @@ -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" + [ + { { ":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 diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor new file mode 100644 index 0000000000..49462dcc50 --- /dev/null +++ b/extra/db/sqlite/sqlite.factor @@ -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 + +M: sqlite-db db-open ( db -- ) + dup sqlite-db-path sqlite-open + 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 r> with-db ; inline + +TUPLE: sqlite-statement ; +C: sqlite-statement + +TUPLE: sqlite-result-set ; +: ( query -- sqlite-result-set ) + dup statement-handle sqlite-result-set ; + +M: sqlite-db ( str -- obj ) + ; + +M: sqlite-db ( str -- obj ) + db get db-handle over sqlite-prepare + { set-statement-sql set-statement-handle } statement construct + [ 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 ; + +M: sqlite-db begin-transaction ( -- ) + "BEGIN" sql-command ; + +M: sqlite-db commit-transaction ( -- ) + "COMMIT" sql-command ; + +M: sqlite-db rollback-transaction ( -- ) + "ROLLBACK" sql-command ; diff --git a/extra/db/sqlite/test.txt b/extra/db/sqlite/test.txt new file mode 100644 index 0000000000..e4487d30f9 --- /dev/null +++ b/extra/db/sqlite/test.txt @@ -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'); diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index dde2c7d205..8e6d8257a4 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -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 ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 1bd9e18d98..755f36a538 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ; - diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 8dcaa7223d..70503236f6 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -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 -- ) diff --git a/extra/postgresql/postgresql-tests.factor b/extra/postgresql/postgresql-tests.factor deleted file mode 100644 index c725882b67..0000000000 --- a/extra/postgresql/postgresql-tests.factor +++ /dev/null @@ -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 - diff --git a/extra/postgresql/postgresql.factor b/extra/postgresql/postgresql.factor deleted file mode 100644 index 9d85b6a77e..0000000000 --- a/extra/postgresql/postgresql.factor +++ /dev/null @@ -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 ; - diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 65b0d1beb0..d89c5eec89 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -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 diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index ee9e2a0381..8129ec17f8 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -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 ; diff --git a/misc/factor.sh b/misc/factor.sh index 39a15f93dc..032b0b3184 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -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