--- /dev/null
+Doug Coleman
--- /dev/null
+IN: db.tests\r
+USING: tools.test db kernel ;\r
+\r
+{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
+{ 1 1 } [ [ ] query-map ] must-infer-as\r
+{ 2 0 } [ [ ] with-db ] must-infer-as\r
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes continuations destructors kernel math
+namespaces sequences sequences.lib classes.tuple words strings
+tools.walker accessors combinators.lib ;
+IN: db
+
+TUPLE: db
+ handle
+ insert-statements
+ update-statements
+ delete-statements ;
+
+: new-db ( class -- obj )
+ new
+ H{ } clone >>insert-statements
+ H{ } clone >>update-statements
+ H{ } clone >>delete-statements ;
+
+GENERIC: make-db* ( seq class -- db )
+
+: make-db ( seq class -- db )
+ new-db make-db* ;
+
+GENERIC: db-open ( db -- db )
+HOOK: db-close db ( handle -- )
+
+: dispose-statements ( assoc -- ) values dispose-each ;
+
+: dispose-db ( db -- )
+ dup db [
+ dup insert-statements>> dispose-statements
+ dup update-statements>> dispose-statements
+ dup delete-statements>> dispose-statements
+ handle>> db-close
+ ] with-variable ;
+
+TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
+TUPLE: simple-statement < statement ;
+TUPLE: prepared-statement < statement ;
+
+TUPLE: result-set sql in-params out-params handle n max ;
+
+: construct-statement ( sql in out class -- statement )
+ new
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
+HOOK: <simple-statement> db ( str in out -- statement )
+HOOK: <prepared-statement> db ( str in out -- statement )
+GENERIC: prepare-statement ( statement -- )
+GENERIC: bind-statement* ( statement -- )
+GENERIC: low-level-bind ( statement -- )
+GENERIC: bind-tuple ( tuple statement -- )
+GENERIC: query-results ( query -- result-set )
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set column -- obj )
+GENERIC# row-column-typed 1 ( result-set column -- sql )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+
+GENERIC: execute-statement* ( statement type -- )
+
+M: object execute-statement* ( statement type -- )
+ drop query-results dispose ;
+
+: execute-statement ( statement -- )
+ dup sequence? [
+ [ execute-statement ] each
+ ] [
+ dup type>> execute-statement*
+ ] if ;
+
+: bind-statement ( obj statement -- )
+ swap >>bind-params
+ [ bind-statement* ] keep
+ t >>bound? drop ;
+
+: init-result-set ( result-set -- )
+ dup #rows >>max
+ 0 >>n drop ;
+
+: construct-result-set ( query handle class -- result-set )
+ new
+ swap >>handle
+ >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
+: sql-row ( result-set -- seq )
+ dup #columns [ row-column ] with map ;
+
+: sql-row-typed ( result-set -- seq )
+ dup #columns [ row-column-typed ] with map ;
+
+: query-each ( statement quot: ( statement -- ) -- )
+ over more-rows? [
+ [ call ] 2keep over advance-row query-each
+ ] [
+ 2drop
+ ] if ; inline recursive
+
+: query-map ( statement quot -- seq )
+ accumulator >r query-each r> { } like ; inline
+
+: with-db ( seq class quot -- )
+ >r make-db db-open db r>
+ [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
+ inline
+
+: default-query ( query -- result-set )
+ query-results [ [ sql-row ] query-map ] with-disposal ;
+
+: do-bound-query ( obj query -- rows )
+ [ bind-statement ] keep default-query ;
+
+: do-bound-command ( obj query -- )
+ [ bind-statement ] keep execute-statement ;
+
+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 ;
+
+: sql-query ( sql -- rows )
+ f f <simple-statement> [ default-query ] with-disposal ;
+
+: sql-command ( sql -- )
+ dup string? [
+ f f <simple-statement> [ execute-statement ] with-disposal
+ ] [
+ ! [
+ [ sql-command ] each
+ ! ] with-transaction
+ ] if ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: db.errors
+
+ERROR: db-error ;
+ERROR: sql-error ;
+
+
+ERROR: table-exists ;
+ERROR: bad-schema ;
--- /dev/null
+IN: db.pools.tests
+USING: db.pools tools.test continuations io.files namespaces
+accessors kernel math destructors ;
+
+\ <db-pool> must-infer
+
+{ 2 0 } [ [ ] with-db-pool ] must-infer-as
+
+{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
+
+! Test behavior after image save/load
+USE: db.sqlite
+
+[ "pool-test.db" temp-file delete-file ] ignore-errors
+
+[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
+
+[ ] [ "pool" get expired>> t >>expired drop ] unit-test
+
+[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
+
+[ ] [ "pool" get dispose ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel arrays namespaces sequences continuations
+io.pools db ;
+IN: db.pools
+
+TUPLE: db-pool < pool db params ;
+
+: <db-pool> ( params db -- pool )
+ db-pool <pool>
+ swap >>db
+ swap >>params ;
+
+: with-db-pool ( db params quot -- )
+ >r <db-pool> r> with-pool ; inline
+
+M: db-pool make-connection ( pool -- )
+ [ params>> ] [ db>> ] bi make-db db-open ;
+
+: with-pooled-db ( pool quot -- )
+ [ db swap with-variable ] curry with-pooled-connection ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! tested on debian linux with postgresql 8.1
+USING: alien alien.syntax combinators system ;
+IN: db.postgresql.ffi
+
+<< "postgresql" {
+ { [ os winnt? ] [ "libpq.dll" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
+ { [ os unix? ] [ "libpq.so" ] }
+} cond "cdecl" add-library >>
+
+! 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
+
+! 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
+
+! 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
+
+! 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
+
+! PGVerbosity;
+: PQERRORS_TERSE HEX: 0 ; inline
+: PQERRORS_DEFAULT HEX: 1 ; inline
+: PQERRORS_VERBOSE HEX: 2 ; inline
+
+: InvalidOid 0 ; inline
+
+TYPEDEF: int ConnStatusType
+TYPEDEF: int ExecStatusType
+TYPEDEF: int PostgresPollingStatusType
+TYPEDEF: int PGTransactionStatusType
+TYPEDEF: int PGVerbosity
+
+TYPEDEF: void* PGconn*
+TYPEDEF: void* PGresult*
+TYPEDEF: void* PGcancel*
+TYPEDEF: uint Oid
+TYPEDEF: uint* Oid*
+TYPEDEF: char pqbool
+TYPEDEF: void* PQconninfoOption*
+TYPEDEF: void* PGnotify*
+TYPEDEF: void* PQArgBlock*
+TYPEDEF: void* PQprintOpt*
+TYPEDEF: void* FILE*
+TYPEDEF: void* SSL*
+
+LIBRARY: postgresql
+
+! Exported functions of libpq
+
+! make a new client connection to the backend
+! Asynchronous (non-blocking)
+FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
+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 ) ;
+
+: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
+ f f PQsetdbLogin ;
+
+! close the current connection and free the PGconn data structure
+FUNCTION: void PQfinish ( PGconn* conn ) ;
+
+! get info about connection options known to PQconnectdb
+FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
+
+! free the data structure returned by PQconndefaults()
+FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
+
+! Asynchronous (non-blocking)
+FUNCTION: int PQresetStart ( PGconn* conn ) ;
+FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: void PQreset ( PGconn* conn ) ;
+
+! request a cancel structure
+FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
+
+! free a cancel structure
+FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
+
+! issue a cancel request
+FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
+
+! Accessor functions for PGconn objects
+FUNCTION: char* PQdb ( PGconn* conn ) ;
+FUNCTION: char* PQuser ( PGconn* conn ) ;
+FUNCTION: char* PQpass ( PGconn* conn ) ;
+FUNCTION: char* PQhost ( PGconn* conn ) ;
+FUNCTION: char* PQport ( PGconn* conn ) ;
+FUNCTION: char* PQtty ( PGconn* conn ) ;
+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 ) ;
+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 ) ;
+
+! May not be compiled into libpq
+! Get the SSL structure associated with a connection
+FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
+
+! Tell libpq whether it needs to initialize OpenSSL
+FUNCTION: void PQinitSSL ( int do_init ) ;
+
+! Set verbosity for PQerrorMessage and PQresultErrorMessage
+FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
+ PGVerbosity verbosity ) ;
+
+! Enable/disable tracing
+FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
+FUNCTION: void PQuntrace ( PGconn* conn ) ;
+
+! BROKEN
+! Function types for notice-handling callbacks
+! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
+! typedef void (*PQnoticeProcessor) (void *arg, char* message);
+! ALIAS: void* PQnoticeReceiver
+! ALIAS: void* PQnoticeProcessor
+
+! Override default notice handling routines
+! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
+ ! PQnoticeReceiver proc,
+ ! void* arg ) ;
+! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
+ ! PQnoticeProcessor proc,
+ ! void* arg ) ;
+! END BROKEN
+
+! === in fe-exec.c ===
+
+! 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 ) ;
+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 ) ;
+
+! 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 ) ;
+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 ) ;
+FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
+
+! Routines for managing an asynchronous query
+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 ) ;
+
+! 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 ) ;
+
+! Set blocking/nonblocking connection to the backend
+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 ) ;
+
+!
+! * "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 ) ;
+
+! Accessor functions for PGresult objects
+FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
+FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
+FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
+FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
+FUNCTION: int PQntuples ( PGresult* res ) ;
+FUNCTION: int PQnfields ( PGresult* res ) ;
+FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
+FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
+FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
+FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
+FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
+FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
+FUNCTION: char* PQoidStatus ( PGresult* res ) ;
+FUNCTION: Oid PQoidValue ( PGresult* res ) ;
+FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
+! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
+
+! Delete a PGresult
+FUNCTION: void PQclear ( PGresult* res ) ;
+
+! For freeing other alloc'd results, such as PGnotify structs
+FUNCTION: void PQfreemem ( void* ptr ) ;
+
+! Exists for backward compatibility.
+: PQfreeNotify ( ptr -- ) PQfreemem ;
+
+!
+! Make an empty PGresult with given status (some apps find this
+! useful). If conn is not NULL and status indicates an error, the
+! conn's errorMessage is copied.
+!
+FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
+
+! Quoting strings before inclusion in queries.
+FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
+ char* to, char* from, size_t length,
+ int* error ) ;
+FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
+ char* from, size_t length,
+ size_t* to_length ) ;
+FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
+! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
+! 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 ) ;
+
+! === in fe-print.c ===
+
+FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
+
+! really old printing routines
+FUNCTION: void PQdisplayTuples ( PGresult* res,
+ FILE* fp,
+ int fillAlign,
+ char* fieldSep,
+ int printHeader,
+ int quiet ) ;
+
+FUNCTION: void PQprintTuples ( PGresult* res,
+ FILE* fout,
+ 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 ) ;
+
+! === in fe-misc.c ===
+
+! Determine length of multibyte encoded char at *s
+FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
+
+! Determine display length of multibyte encoded char at *s
+FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
+
+! Get encoding id from environment variable PGCLIENTENCODING
+FUNCTION: int PQenv2encoding ( ) ;
+
+! From git, include/catalog/pg_type.h
+: BOOL-OID 16 ; inline
+: BYTEA-OID 17 ; inline
+: CHAR-OID 18 ; inline
+: NAME-OID 19 ; inline
+: INT8-OID 20 ; inline
+: INT2-OID 21 ; inline
+: INT4-OID 23 ; inline
+: TEXT-OID 23 ; inline
+: OID-OID 26 ; inline
+: FLOAT4-OID 700 ; inline
+: FLOAT8-OID 701 ; inline
+: VARCHAR-OID 1043 ; inline
+: DATE-OID 1082 ; inline
+: TIME-OID 1083 ; inline
+: TIMESTAMP-OID 1114 ; inline
+: TIMESTAMPTZ-OID 1184 ; inline
+: INTERVAL-OID 1186 ; inline
+: NUMERIC-OID 1700 ; inline
--- /dev/null
+! 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
+db.types tools.walker ascii splitting math.parser combinators
+libc shuffle calendar.format byte-arrays destructors prettyprint
+accessors strings serialize io.encodings.binary io.encodings.utf8
+alien.strings io.streams.byte-array summary present urls ;
+IN: db.postgresql.lib
+
+: postgresql-result-error-message ( res -- str/f )
+ dup zero? [
+ drop f
+ ] [
+ PQresultErrorMessage [ blank? ] trim
+ ] if ;
+
+: postgres-result-error ( res -- )
+ postgresql-result-error-message [ throw ] when* ;
+
+: (postgresql-error-message) ( handle -- str )
+ PQerrorMessage
+ "\n" split [ [ blank? ] trim ] map "\n" join ;
+
+: postgresql-error-message ( -- str )
+ db get handle>> (postgresql-error-message) ;
+
+: postgresql-error ( res -- res )
+ dup [ postgresql-error-message throw ] unless ;
+
+ERROR: postgresql-result-null ;
+
+M: postgresql-result-null summary ( obj -- str )
+ drop "PQexec returned f." ;
+
+: postgresql-result-ok? ( res -- ? )
+ [ postgresql-result-null ] unless*
+ 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 handle>> swap sql>> PQexec dup postgresql-result-ok? [
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
+ ] unless ;
+
+: type>oid ( symbol -- n )
+ dup array? [ first ] when
+ {
+ { BLOB [ BYTEA-OID ] }
+ { FACTOR-BLOB [ BYTEA-OID ] }
+ [ drop 0 ]
+ } case ;
+
+: type>param-format ( symbol -- n )
+ dup array? [ first ] when
+ {
+ { BLOB [ 1 ] }
+ { FACTOR-BLOB [ 1 ] }
+ [ drop 0 ]
+ } case ;
+
+: param-types ( statement -- seq )
+ in-params>> [ type>> type>oid ] map >c-uint-array ;
+
+: malloc-byte-array/length ( byte-array -- alien length )
+ [ malloc-byte-array &free ] [ length ] bi ;
+
+: default-param-value ( obj -- alien n )
+ number>string* dup [ utf8 malloc-string &free ] when 0 ;
+
+: param-values ( statement -- seq seq2 )
+ [ bind-params>> ] [ in-params>> ] bi
+ [
+ >r value>> r> type>> {
+ { FACTOR-BLOB [
+ dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
+ ] }
+ { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
+ { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
+ { TIME [ dup [ timestamp>hms ] when default-param-value ] }
+ { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ { URL [ dup [ present ] when default-param-value ] }
+ [ drop default-param-value ]
+ } case 2array
+ ] 2map flip dup empty? [
+ drop f f
+ ] [
+ first2 [ >c-void*-array ] [ >c-uint-array ] bi*
+ ] if ;
+
+: param-formats ( statement -- seq )
+ in-params>> [ type>> type>param-format ] map >c-uint-array ;
+
+: do-postgresql-bound-statement ( statement -- res )
+ [
+ >r db get handle>> r>
+ {
+ [ sql>> ]
+ [ bind-params>> length ]
+ [ param-types ]
+ [ param-values ]
+ [ param-formats ]
+ } cleave
+ 0 PQexecParams dup postgresql-result-ok? [
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
+ ] unless
+ ] with-destructors ;
+
+: pq-get-is-null ( handle row column -- ? )
+ PQgetisnull 1 = ;
+
+: pq-get-string ( handle row column -- obj )
+ 3dup PQgetvalue utf8 alien>string
+ dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+
+: pq-get-number ( handle row column -- obj )
+ pq-get-string dup [ string>number ] when ;
+
+TUPLE: postgresql-malloc-destructor alien ;
+C: <postgresql-malloc-destructor> postgresql-malloc-destructor
+
+M: postgresql-malloc-destructor dispose ( obj -- )
+ alien>> PQfreemem ;
+
+: &postgresql-free ( alien -- alien )
+ dup <postgresql-malloc-destructor> &dispose drop ; inline
+
+: pq-get-blob ( handle row column -- obj/f )
+ [ PQgetvalue ] 3keep 3dup PQgetlength
+ dup 0 > [
+ 3nip
+ [
+ memory>byte-array >string
+ 0 <uint>
+ [
+ PQunescapeBytea dup zero? [
+ postgresql-result-error-message throw
+ ] [
+ &postgresql-free
+ ] if
+ ] keep
+ *uint memory>byte-array
+ ] with-destructors
+ ] [
+ drop pq-get-is-null nip [ f ] [ B{ } clone ] if
+ ] if ;
+
+: postgresql-column-typed ( handle row column type -- obj )
+ dup array? [ first ] when
+ {
+ { +db-assigned-id+ [ pq-get-number ] }
+ { +random-id+ [ pq-get-number ] }
+ { INTEGER [ pq-get-number ] }
+ { BIG-INTEGER [ pq-get-number ] }
+ { DOUBLE [ pq-get-number ] }
+ { TEXT [ pq-get-string ] }
+ { VARCHAR [ pq-get-string ] }
+ { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
+ { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
+ { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ pq-get-blob ] }
+ { URL [ pq-get-string dup [ >url ] when ] }
+ { FACTOR-BLOB [
+ pq-get-blob
+ dup [ bytes>object ] when ] }
+ [ no-sql-type ]
+ } case ;
--- /dev/null
+! 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 classes
+prettyprint sequences namespaces tools.test db
+db.tuples db.types unicode.case ;
+IN: db.postgresql.tests
+
+: test-db ( -- postgresql-db )
+ { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
+
+[ ] [ test-db [ ] with-db ] unit-test
+
+[ ] [
+ test-db [
+ [ "drop table person;" sql-command ] ignore-errors
+ "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" }
+ { "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
+] must-fail
+
+[ 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
+
+
+: with-dummy-db ( quot -- )
+ >r T{ postgresql-db } db r> with-variable ;
--- /dev/null
+! 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 math.parser namespaces prettyprint quotations
+sequences debugger db db.postgresql.lib db.postgresql.ffi
+db.tuples db.types tools.annotations math.ranges
+combinators sequences.lib classes locals words tools.walker
+namespaces.lib accessors random db.queries destructors ;
+USE: tools.walker
+IN: db.postgresql
+
+TUPLE: postgresql-db < db
+ host port pgopts pgtty db user pass ;
+
+TUPLE: postgresql-statement < statement ;
+
+TUPLE: postgresql-result-set < result-set ;
+
+M: postgresql-db make-db* ( seq tuple -- db )
+ >r first4 r>
+ swap >>db
+ swap >>pass
+ swap >>user
+ swap >>host ;
+
+M: postgresql-db db-open ( db -- db )
+ dup {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ db>> ]
+ [ user>> ]
+ [ pass>> ]
+ } cleave connect-postgres >>handle ;
+
+M: postgresql-db dispose ( db -- )
+ handle>> PQfinish ;
+
+M: postgresql-statement bind-statement* ( statement -- )
+ drop ;
+
+GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
+
+M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+ slot-name>> swap get-slot-named <low-level-binding> ;
+
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+ nip value>> <low-level-binding> ;
+
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+ dup generator-singleton>> eval-generator
+ [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
+
+M: postgresql-statement bind-tuple ( tuple statement -- )
+ tuck in-params>>
+ [ postgresql-bind-conversion ] with map
+ >>bind-params drop ;
+
+M: postgresql-result-set #rows ( result-set -- n )
+ handle>> PQntuples ;
+
+M: postgresql-result-set #columns ( result-set -- n )
+ handle>> PQnfields ;
+
+: result-handle-n ( result-set -- handle n )
+ [ handle>> ] [ n>> ] bi ;
+
+M: postgresql-result-set row-column ( result-set column -- obj )
+ >r result-handle-n r> pq-get-string ;
+
+M: postgresql-result-set row-column-typed ( result-set column -- obj )
+ dup pick out-params>> nth type>>
+ >r >r result-handle-n r> r> postgresql-column-typed ;
+
+M: postgresql-statement query-results ( query -- result-set )
+ dup bind-params>> [
+ over [ bind-statement ] keep
+ do-postgresql-bound-statement
+ ] [
+ dup do-postgresql-statement
+ ] if*
+ postgresql-result-set construct-result-set
+ dup init-result-set ;
+
+M: postgresql-result-set advance-row ( result-set -- )
+ [ 1+ ] change-n drop ;
+
+M: postgresql-result-set more-rows? ( result-set -- ? )
+ [ n>> ] [ max>> ] bi < ;
+
+M: postgresql-statement dispose ( query -- )
+ dup handle>> PQclear
+ f >>handle drop ;
+
+M: postgresql-result-set dispose ( result-set -- )
+ [ handle>> PQclear ]
+ [
+ 0 >>n
+ 0 >>max
+ f >>handle drop
+ ] bi ;
+
+M: postgresql-statement prepare-statement ( statement -- )
+ dup
+ >r db get handle>> f r>
+ [ sql>> ] [ in-params>> ] bi
+ length f PQprepare postgresql-error
+ >>handle drop ;
+
+M: postgresql-db <simple-statement> ( sql in out -- statement )
+ postgresql-statement construct-statement ;
+
+M: postgresql-db <prepared-statement> ( sql in out -- statement )
+ <simple-statement> dup prepare-statement ;
+
+: bind-name% ( -- )
+ CHAR: $ 0,
+ sql-counter [ inc ] [ get 0# ] bi ;
+
+M: postgresql-db bind% ( spec -- )
+ bind-name% 1, ;
+
+M: postgresql-db bind# ( spec obj -- )
+ >r bind-name% f swap type>> r> <literal-bind> 1, ;
+
+: create-table-sql ( class -- statement )
+ [
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup column-name>> 0%
+ " " 0%
+ dup type>> lookup-create-type 0%
+ modifiers 0%
+ ] interleave ");" 0%
+ ] query-make ;
+
+: create-function-sql ( class -- statement )
+ [
+ >r remove-id r>
+ "create function add_" 0% dup 0%
+ "(" 0%
+ over [ "," 0% ]
+ [
+ type>> lookup-type 0%
+ ] interleave
+ ")" 0%
+ " returns bigint as '" 0%
+
+ "insert into " 0%
+ dup 0%
+ "(" 0%
+ over [ ", " 0% ] [ column-name>> 0% ] interleave
+ ") values(" 0%
+ swap [ ", " 0% ] [ drop bind-name% ] interleave
+ "); " 0%
+ "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
+ ] query-make ;
+
+M: postgresql-db create-sql-statement ( class -- seq )
+ [
+ [ create-table-sql , ] keep
+ dup db-columns find-primary-key db-assigned-id-spec?
+ [ create-function-sql , ] [ drop ] if
+ ] { } make ;
+
+: drop-function-sql ( class -- statement )
+ [
+ "drop function add_" 0% 0%
+ "(" 0%
+ remove-id
+ [ ", " 0% ] [ type>> lookup-type 0% ] interleave
+ ");" 0%
+ ] query-make ;
+
+: drop-table-sql ( table -- statement )
+ [
+ "drop table " 0% 0% drop
+ ] query-make ;
+
+M: postgresql-db drop-sql-statement ( class -- seq )
+ [
+ [ drop-table-sql , ] keep
+ dup db-columns find-primary-key db-assigned-id-spec?
+ [ drop-function-sql , ] [ drop ] if
+ ] { } make ;
+
+M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
+ [
+ "select add_" 0% 0%
+ "(" 0%
+ dup find-primary-key 2,
+ remove-id
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] query-make ;
+
+M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
+ [
+ "insert into " 0% 0%
+ "(" 0%
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
+ ")" 0%
+
+ " values(" 0%
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+ [
+ bind-name%
+ slot-name>>
+ f
+ random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
+ ");" 0%
+ ] query-make ;
+
+M: postgresql-db insert-tuple* ( tuple statement -- )
+ query-modify-tuple ;
+
+M: postgresql-db persistent-table ( -- hashtable )
+ H{
+ { +db-assigned-id+ { "integer" "serial primary key" f } }
+ { +user-assigned-id+ { f f "primary key" } }
+ { +random-id+ { "bigint" "bigint primary key" f } }
+ { TEXT { "text" "text" f } }
+ { VARCHAR { "varchar" "varchar" f } }
+ { INTEGER { "integer" "integer" f } }
+ { BIG-INTEGER { "bigint" "bigint" f } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { DOUBLE { "real" "real" f } }
+ { DATE { "date" "date" f } }
+ { TIME { "time" "time" f } }
+ { DATETIME { "timestamp" "timestamp" f } }
+ { TIMESTAMP { "timestamp" "timestamp" f } }
+ { BLOB { "bytea" "bytea" f } }
+ { FACTOR-BLOB { "bytea" "bytea" f } }
+ { URL { "varchar" "varchar" f } }
+ { +foreign-id+ { f f "references" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
+ } ;
+
+M: postgresql-db compound ( str obj -- str' )
+ over {
+ { "default" [ first number>string join-space ] }
+ { "varchar" [ first number>string paren append ] }
+ { "references" [
+ first2 >r [ unparse join-space ] keep db-columns r>
+ swap [ slot-name>> = ] with find nip
+ column-name>> paren append
+ ] }
+ [ "no compound found" 3array throw ]
+ } case ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math namespaces sequences random
+strings math.parser math.intervals combinators
+math.bitfields.lib namespaces.lib db db.tuples db.types
+sequences.lib db.sql classes words shuffle arrays ;
+IN: db.queries
+
+GENERIC: where ( specs obj -- )
+
+: maybe-make-retryable ( statement -- statement )
+ dup in-params>> [ generator-bind? ] contains?
+ [ make-retryable ] when ;
+
+: query-make ( class quot -- )
+ >r sql-props r>
+ [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
+ <simple-statement> maybe-make-retryable ; inline
+
+M: db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: where-primary-key% ( specs -- )
+ " where " 0%
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
+
+M: db <update-tuple-statement> ( class -- statement )
+ [
+ "update " 0% 0%
+ " set " 0%
+ dup remove-id
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
+ where-primary-key%
+ ] query-make ;
+
+M: random-id-generator eval-generator ( singleton -- obj )
+ drop
+ system-random-generator get [
+ 63 [ 2^ random ] keep 1 - set-bit
+ ] with-random ;
+
+: interval-comparison ( ? str -- str )
+ "from" = " >" " <" ? swap [ "= " append ] when ;
+
+: fp-infinity? ( float -- ? )
+ dup float? [
+ double>bits -52 shift 11 2^ 1- [ bitand ] keep =
+ ] [
+ drop f
+ ] if ;
+
+: (infinite-interval?) ( interval -- ?1 ?2 )
+ [ from>> ] [ to>> ] bi
+ [ first fp-infinity? ] bi@ ;
+
+: double-infinite-interval? ( obj -- ? )
+ dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
+
+: infinite-interval? ( obj -- ? )
+ dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
+
+: where-interval ( spec obj from/to -- )
+ over first fp-infinity? [
+ 3drop
+ ] [
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind#
+ ] if ;
+
+: in-parens ( quot -- )
+ "(" 0% call ")" 0% ; inline
+
+M: interval where ( spec obj -- )
+ [
+ [ from>> "from" where-interval ] [
+ nip infinite-interval? [ " and " 0% ] unless
+ ] [ to>> "to" where-interval ] 2tri
+ ] in-parens ;
+
+M: sequence where ( spec obj -- )
+ [
+ [ " or " 0% ] [ dupd where ] interleave drop
+ ] in-parens ;
+
+: object-where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
+M: object where ( spec obj -- ) object-where ;
+
+M: integer where ( spec obj -- ) object-where ;
+
+M: string where ( spec obj -- ) object-where ;
+
+: filter-slots ( tuple specs -- specs' )
+ [
+ slot-name>> swap get-slot-named
+ dup double-infinite-interval? [ drop f ] when
+ ] with filter ;
+
+: where-clause ( tuple specs -- )
+ dupd filter-slots [
+ drop
+ ] [
+ " where " 0% [
+ " and " 0%
+ ] [
+ 2dup slot-name>> swap get-slot-named where
+ ] interleave drop
+ ] if-empty ;
+
+M: db <delete-tuples-statement> ( tuple table -- sql )
+ [
+ "delete from " 0% 0%
+ where-clause
+ ] query-make ;
+
+M: db <select-by-slots-statement> ( tuple class -- statement )
+ [
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup column-name>> 0% 2, ] interleave
+
+ " from " 0% 0%
+ where-clause
+ ] query-make ;
+
+: do-group ( tuple groups -- )
+ [
+ ", " join " group by " prepend append
+ ] curry change-sql drop ;
+
+: do-order ( tuple order -- )
+ [
+ ", " join " order by " prepend append
+ ] curry change-sql drop ;
+
+: do-offset ( tuple n -- )
+ [
+ number>string " offset " prepend append
+ ] curry change-sql drop ;
+
+: do-limit ( tuple n -- )
+ [
+ number>string " limit " prepend append
+ ] curry change-sql drop ;
+
+: make-query ( tuple query -- tuple' )
+ dupd
+ {
+ [ group>> [ do-group ] [ drop ] if-seq ]
+ [ order>> [ do-order ] [ drop ] if-seq ]
+ [ limit>> [ do-limit ] [ drop ] if* ]
+ [ offset>> [ do-offset ] [ drop ] if* ]
+ } 2cleave ;
+
+M: db <query> ( tuple class query -- tuple )
+ [ <select-by-slots-statement> ] dip make-query ;
+
+! select ID, NAME, SCORE from EXAM limit 1 offset 3
+
+: select-tuples* ( tuple -- statement )
+ dup
+ [
+ select 0,
+ dup class db-columns [ ", " 0, ]
+ [ dup column-name>> 0, 2, ] interleave
+ from 0,
+ class name>> 0,
+ ] { { } { } { } } nmake
+ >r >r parse-sql 4drop r> r>
+ <simple-statement> maybe-make-retryable do-select ;
+
+M: db <count-statement> ( tuple class groups -- statement )
+ \ query new
+ swap >>group
+ [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
+ dip make-query ;
+
+: create-index ( index-name table-name columns -- )
+ [
+ >r >r "create index " % % r> " on " % % r> "(" %
+ "," join % ")" %
+ ] "" make sql-command ;
+
+: drop-index ( index-name -- )
+ [ "drop index " % % ] "" make sql-command ;
--- /dev/null
+USING: kernel namespaces db.sql sequences math ;
+IN: db.sql.tests
+
+! TUPLE: person name age ;
+: insert-1
+ { insert
+ {
+ { table "person" }
+ { columns "name" "age" }
+ { values "erg" 26 }
+ }
+ } ;
+
+: update-1
+ { update "person"
+ { set { "name" "erg" }
+ { "age" 6 } }
+ { where { "age" 6 } }
+ } ;
+
+: select-1
+ { select
+ { columns
+ "branchno"
+ { count "staffno" as "mycount" }
+ { sum "salary" as "mysum" } }
+ { from "staff" "lol" }
+ { where
+ { "salary" > all
+ { select
+ { columns "salary" }
+ { from "staff" }
+ { where { "branchno" = "b003" } }
+ }
+ }
+ { "branchno" > 3 } }
+ { group-by "branchno" "lol2" }
+ { having { count "staffno" > 1 } }
+ { order-by "branchno" }
+ { offset 40 }
+ { limit 20 }
+ } ;
--- /dev/null
+USING: kernel parser quotations classes.tuple words math.order
+namespaces.lib namespaces sequences arrays combinators
+prettyprint strings math.parser sequences.lib math symbols ;
+IN: db.sql
+
+SYMBOLS: insert update delete select distinct columns from as
+where group-by having order-by limit offset is-null desc all
+any count avg table values ;
+
+: input-spec, ( obj -- ) 1, ;
+: output-spec, ( obj -- ) 2, ;
+: input, ( obj -- ) 3, ;
+: output, ( obj -- ) 4, ;
+
+DEFER: sql%
+
+: (sql-interleave) ( seq sep -- )
+ [ sql% ] curry [ sql% ] interleave ;
+
+: sql-interleave ( seq str sep -- )
+ swap sql% (sql-interleave) ;
+
+: sql-function, ( seq function -- )
+ sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
+
+: sql-where ( seq -- )
+B
+ [
+ [ second 0, ]
+ [ first 0, ]
+ [ third 1, \ ? 0, ] tri
+ ] each ;
+
+: sql-array% ( array -- )
+B
+ unclip
+ {
+ { \ create [ "create table" sql% ] }
+ { \ drop [ "drop table" sql% ] }
+ { \ insert [ "insert into" sql% ] }
+ { \ update [ "update" sql% ] }
+ { \ delete [ "delete" sql% ] }
+ { \ select [ B "select" sql% "," (sql-interleave) ] }
+ { \ columns [ "," (sql-interleave) ] }
+ { \ from [ "from" "," sql-interleave ] }
+ { \ where [ B "where" 0, sql-where ] }
+ { \ group-by [ "group by" "," sql-interleave ] }
+ { \ having [ "having" "," sql-interleave ] }
+ { \ order-by [ "order by" "," sql-interleave ] }
+ { \ offset [ "offset" sql% sql% ] }
+ { \ limit [ "limit" sql% sql% ] }
+ { \ select [ "(select" sql% sql% ")" sql% ] }
+ { \ table [ sql% ] }
+ { \ set [ "set" "," sql-interleave ] }
+ { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
+ { \ count [ "count" sql-function, ] }
+ { \ sum [ "sum" sql-function, ] }
+ { \ avg [ "avg" sql-function, ] }
+ { \ min [ "min" sql-function, ] }
+ { \ max [ "max" sql-function, ] }
+ [ sql% [ sql% ] each ]
+ } case ;
+
+ERROR: no-sql-match ;
+: sql% ( obj -- )
+ {
+ { [ dup string? ] [ 0, ] }
+ { [ dup array? ] [ sql-array% ] }
+ { [ dup number? ] [ number>string sql% ] }
+ { [ dup symbol? ] [ unparse sql% ] }
+ { [ dup word? ] [ unparse sql% ] }
+ { [ dup quotation? ] [ call ] }
+ [ no-sql-match ]
+ } cond ;
+
+: parse-sql ( obj -- sql in-spec out-spec in out )
+ [ [ sql% ] each ] { { } { } { } } nmake ;
--- /dev/null
+Chris Double
+Doug Coleman
--- /dev/null
+! 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.
+USING: alien compiler kernel math namespaces sequences strings alien.syntax
+ system combinators alien.c-types ;
+IN: db.sqlite.ffi
+
+<< "sqlite" {
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os 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"
+} ;
+
+! Return values from sqlite3_step
+: SQLITE_ROW 100 ; inline
+: SQLITE_DONE 101 ; inline
+
+! 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
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare_v2 ( 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: sqlite3_uint64 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_double ( sqlite3_stmt* pStmt, int index, double x ) ;
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
+: sqlite3-bind-uint64 ( pStmt index in64 -- int )
+ "int" "sqlite" "sqlite3_bind_int64"
+ { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
+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_clear_bindings ( sqlite3_stmt* pStmt ) ;
+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: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+: sqlite3-column-uint64 ( pStmt col -- uint64 )
+ "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
+ { "sqlite3_stmt*" "int" } alien-invoke ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* 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 ) ;
--- /dev/null
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types arrays assocs kernel math math.parser
+namespaces sequences db.sqlite.ffi db combinators
+continuations db.types calendar.format serialize
+io.streams.byte-array byte-arrays io.encodings.binary
+io.backend db.errors present urls io.encodings.utf8
+io.encodings.string accessors ;
+IN: db.sqlite.lib
+
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
+
+: throw-sqlite-error ( n -- * )
+ dup sqlite-error-messages nth sqlite-error ;
+
+: sqlite-statement-error ( -- * )
+ SQLITE_ERROR
+ db get handle>> sqlite3_errmsg sqlite-sql-error ;
+
+: sqlite-check-result ( n -- )
+ {
+ { SQLITE_OK [ ] }
+ { SQLITE_ERROR [ sqlite-statement-error ] }
+ [ throw-sqlite-error ]
+ } case ;
+
+: sqlite-open ( path -- db )
+ normalize-path
+ "void*" <c-object>
+ [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+ sqlite3_close sqlite-check-result ;
+
+: sqlite-prepare ( db sql -- handle )
+ utf8 encode dup length "void*" <c-object> "void*" <c-object>
+ [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
+ drop *void* ;
+
+: sqlite-bind-parameter-index ( handle name -- index )
+ sqlite3_bind_parameter_index ;
+
+: parameter-index ( handle name text -- handle name text )
+ >r dupd sqlite-bind-parameter-index r> ;
+
+: sqlite-bind-text ( handle index text -- )
+ utf8 encode dup length SQLITE_TRANSIENT
+ sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-int ( handle i n -- )
+ sqlite3_bind_int sqlite-check-result ;
+
+: sqlite-bind-int64 ( handle i n -- )
+ sqlite3_bind_int64 sqlite-check-result ;
+
+: sqlite-bind-uint64 ( handle i n -- )
+ sqlite3-bind-uint64 sqlite-check-result ;
+
+: sqlite-bind-double ( handle i x -- )
+ sqlite3_bind_double sqlite-check-result ;
+
+: sqlite-bind-null ( handle i -- )
+ sqlite3_bind_null sqlite-check-result ;
+
+: sqlite-bind-blob ( handle i byte-array -- )
+ dup length SQLITE_TRANSIENT
+ sqlite3_bind_blob sqlite-check-result ;
+
+: sqlite-bind-text-by-name ( handle name text -- )
+ parameter-index sqlite-bind-text ;
+
+: sqlite-bind-int-by-name ( handle name int -- )
+ parameter-index sqlite-bind-int ;
+
+: sqlite-bind-int64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-int64 ;
+
+: sqlite-bind-uint64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-uint64 ;
+
+: sqlite-bind-double-by-name ( handle name double -- )
+ parameter-index sqlite-bind-double ;
+
+: sqlite-bind-blob-by-name ( handle name blob -- )
+ parameter-index sqlite-bind-blob ;
+
+: sqlite-bind-null-by-name ( handle name obj -- )
+ parameter-index drop sqlite-bind-null ;
+
+: sqlite-bind-type ( handle key value type -- )
+ over [ drop NULL ] unless
+ dup array? [ first ] when
+ {
+ { INTEGER [ sqlite-bind-int-by-name ] }
+ { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
+ { TEXT [ sqlite-bind-text-by-name ] }
+ { VARCHAR [ sqlite-bind-text-by-name ] }
+ { DOUBLE [ sqlite-bind-double-by-name ] }
+ { DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
+ { TIME [ timestamp>hms sqlite-bind-text-by-name ] }
+ { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
+ { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
+ { BLOB [ sqlite-bind-blob-by-name ] }
+ { FACTOR-BLOB [
+ object>bytes
+ sqlite-bind-blob-by-name
+ ] }
+ { URL [ present sqlite-bind-text-by-name ] }
+ { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
+ { +random-id+ [ sqlite-bind-int64-by-name ] }
+ { NULL [ sqlite-bind-null-by-name ] }
+ [ no-sql-type ]
+ } case ;
+
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-clear-bindings ( handle -- )
+ sqlite3_clear_bindings sqlite-check-result ;
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
+
+: sqlite-column-blob ( handle index -- byte-array/f )
+ [ sqlite3_column_bytes ] 2keep
+ pick zero? [
+ 3drop f
+ ] [
+ sqlite3_column_blob swap memory>byte-array
+ ] if ;
+
+: sqlite-column-typed ( handle index type -- obj )
+ dup array? [ first ] when
+ {
+ { +db-assigned-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3-column-uint64 ] }
+ { INTEGER [ sqlite3_column_int ] }
+ { BIG-INTEGER [ sqlite3_column_int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
+ { DOUBLE [ sqlite3_column_double ] }
+ { TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
+ { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
+ { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
+ { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { URL [ sqlite3_column_text dup [ >url ] when ] }
+ { FACTOR-BLOB [
+ sqlite-column-blob
+ dup [ bytes>object ] when
+ ] }
+ ! { NULL [ 2drop f ] }
+ [ no-sql-type ]
+ } case ;
+
+: sqlite-row ( handle -- seq )
+ dup sqlite-#columns [ sqlite-column ] with map ;
+
+: sqlite-step-has-more-rows? ( prepared -- bool )
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
+
+: sqlite-next ( prepared -- ? )
+ sqlite3_step sqlite-step-has-more-rows? ;
--- /dev/null
+USING: io io.files io.launcher kernel namespaces
+prettyprint tools.test db.sqlite db sequences
+continuations db.types db.tuples unicode.case ;
+IN: db.sqlite.tests
+
+: db-path "test.db" temp-file ;
+: test.db db-path sqlite-db ;
+
+[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
+
+[ ] [
+ test.db [
+ "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
+
+[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
+[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
+
+[ ] [
+ test.db [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ sql-command
+ ] with-db
+] unit-test
+
+[
+ {
+ { "1" "John" "America" }
+ { "2" "Jane" "New Zealand" }
+ { "3" "Jimmy" "Canada" }
+ }
+] [ test.db [ "select rowid, * 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
+] must-fail
+
+[ 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
--- /dev/null
+! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assocs classes compiler db
+hashtables io.files kernel math math.parser namespaces
+prettyprint sequences strings classes.tuple alien.c-types
+continuations db.sqlite.lib db.sqlite.ffi db.tuples
+words combinators.lib db.types combinators math.intervals
+io namespaces.lib accessors vectors math.ranges random
+math.bitfields.lib db.queries destructors ;
+USE: tools.walker
+IN: db.sqlite
+
+TUPLE: sqlite-db < db path ;
+
+M: sqlite-db make-db* ( path db -- db )
+ swap >>path ;
+
+M: sqlite-db db-open ( db -- db )
+ dup path>> sqlite-open >>handle ;
+
+M: sqlite-db db-close ( handle -- ) sqlite-close ;
+M: sqlite-db dispose ( db -- ) dispose-db ;
+
+TUPLE: sqlite-statement < statement ;
+
+TUPLE: sqlite-result-set < result-set has-more? ;
+
+M: sqlite-db <simple-statement> ( str in out -- obj )
+ <prepared-statement> ;
+
+M: sqlite-db <prepared-statement> ( str in out -- obj )
+ sqlite-statement construct-statement ;
+
+: sqlite-maybe-prepare ( statement -- statement )
+ dup handle>> [
+ db get handle>> over sql>> sqlite-prepare
+ >>handle
+ ] unless ;
+
+M: sqlite-statement dispose ( statement -- )
+ handle>>
+ [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
+
+M: sqlite-result-set dispose ( result-set -- )
+ f >>handle drop ;
+
+: reset-statement ( statement -- )
+ sqlite-maybe-prepare handle>> sqlite-reset ;
+
+: reset-bindings ( statement -- )
+ sqlite-maybe-prepare
+ handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
+
+M: sqlite-statement low-level-bind ( statement -- )
+ [ bind-params>> ] [ handle>> ] bi
+ [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
+
+M: sqlite-statement bind-statement* ( statement -- )
+ sqlite-maybe-prepare
+ dup bound?>> [ dup reset-bindings ] when
+ low-level-bind ;
+
+GENERIC: sqlite-bind-conversion ( tuple obj -- array )
+
+TUPLE: sqlite-low-level-binding < low-level-binding key type ;
+: <sqlite-low-level-binding> ( key value type -- obj )
+ sqlite-low-level-binding new
+ swap >>type
+ swap >>value
+ swap >>key ;
+
+M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri <sqlite-low-level-binding> ;
+
+M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+ nip [ key>> ] [ value>> ] [ type>> ] tri
+ <sqlite-low-level-binding> ;
+
+M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ tuck
+ [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
+ rot set-slot-named
+ >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
+
+M: sqlite-statement bind-tuple ( tuple statement -- )
+ [
+ in-params>> [ sqlite-bind-conversion ] with map
+ ] keep bind-statement ;
+
+: last-insert-id ( -- id )
+ db get handle>> sqlite3_last_insert_rowid
+ dup zero? [ "last-id failed" throw ] when ;
+
+M: sqlite-db insert-tuple* ( tuple statement -- )
+ execute-statement last-insert-id swap set-primary-key ;
+
+M: sqlite-result-set #columns ( result-set -- n )
+ handle>> sqlite-#columns ;
+
+M: sqlite-result-set row-column ( result-set n -- obj )
+ [ handle>> ] [ sqlite-column ] bi* ;
+
+M: sqlite-result-set row-column-typed ( result-set n -- obj )
+ dup pick out-params>> nth type>>
+ >r >r handle>> r> r> sqlite-column-typed ;
+
+M: sqlite-result-set advance-row ( result-set -- )
+ dup handle>> sqlite-next >>has-more? drop ;
+
+M: sqlite-result-set more-rows? ( result-set -- ? )
+ has-more?>> ;
+
+M: sqlite-statement query-results ( query -- result-set )
+ sqlite-maybe-prepare
+ dup handle>> sqlite-result-set construct-result-set
+ dup advance-row ;
+
+M: sqlite-db create-sql-statement ( class -- statement )
+ [
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup column-name>> 0%
+ " " 0%
+ dup type>> lookup-create-type 0%
+ modifiers 0%
+ ] interleave ");" 0%
+ ] query-make ;
+
+M: sqlite-db drop-sql-statement ( class -- statement )
+ [ "drop table " 0% 0% ";" 0% drop ] query-make ;
+
+M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
+ [
+ "insert into " 0% 0%
+ "(" 0%
+ remove-db-assigned-id
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
+ ") values(" 0%
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+ [ slot-name>> ]
+ [
+ column-name>> ":" prepend dup 0%
+ random-id-generator
+ ] [ type>> ] tri <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
+ ");" 0%
+ ] query-make ;
+
+M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
+ <insert-db-assigned-statement> ;
+
+M: sqlite-db bind# ( spec obj -- )
+ >r
+ [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ type>> ] bi
+ r> <literal-bind> 1, ;
+
+M: sqlite-db bind% ( spec -- )
+ dup 1, column-name>> ":" prepend 0% ;
+
+M: sqlite-db persistent-table ( -- assoc )
+ H{
+ { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
+ { +user-assigned-id+ { f f "primary key" } }
+ { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
+ { INTEGER { "integer" "integer" "primary key" } }
+ { BIG-INTEGER { "bigint" "bigint" } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { TEXT { "text" "text" } }
+ { VARCHAR { "text" "text" } }
+ { DATE { "date" "date" } }
+ { TIME { "time" "time" } }
+ { DATETIME { "datetime" "datetime" } }
+ { TIMESTAMP { "timestamp" "timestamp" } }
+ { DOUBLE { "real" "real" } }
+ { BLOB { "blob" "blob" } }
+ { FACTOR-BLOB { "blob" "blob" } }
+ { URL { "text" "text" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
+ } ;
+
+M: sqlite-db compound ( str seq -- str' )
+ over {
+ { "default" [ first number>string join-space ] }
+ [ 2drop ]
+ } case ;
--- /dev/null
+create table person (name varchar(30), country varchar(30));
+insert into person values('John', 'America');
+insert into person values('Jane', 'New Zealand');
--- /dev/null
+Relational database abstraction layer
--- /dev/null
+enterprise
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files kernel tools.test db db.tuples classes
+db.types continuations namespaces math math.ranges
+prettyprint calendar sequences db.sqlite math.intervals
+db.postgresql accessors random math.bitfields.lib
+math.ranges strings sequences.lib urls fry ;
+IN: db.tuples.tests
+
+TUPLE: person the-id the-name the-number the-real
+ts date time blob factor-blob url ;
+
+: <person> ( name age real ts date time blob factor-blob url -- person )
+ person new
+ swap >>url
+ swap >>factor-blob
+ swap >>blob
+ swap >>time
+ swap >>date
+ swap >>ts
+ swap >>the-real
+ swap >>the-number
+ swap >>the-name ;
+
+: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
+ <person>
+ swap >>the-id ;
+
+SYMBOL: person1
+SYMBOL: person2
+SYMBOL: person3
+SYMBOL: person4
+
+: test-tuples ( -- )
+ [ ] [ person recreate-table ] unit-test
+ [ ] [ person ensure-table ] unit-test
+ [ ] [ person drop-table ] unit-test
+ [ ] [ person create-table ] unit-test
+ [ person create-table ] must-fail
+ [ ] [ person ensure-table ] unit-test
+
+ [ ] [ person1 get insert-tuple ] unit-test
+
+ [ 1 ] [ person1 get the-id>> ] unit-test
+
+ [ ] [ person1 get 200 >>the-number drop ] unit-test
+
+ [ ] [ person1 get update-tuple ] unit-test
+
+ [ T{ person f 1 "billy" 200 3.14 } ]
+ [ T{ person f 1 } select-tuple ] unit-test
+ [ ] [ person2 get insert-tuple ] unit-test
+ [
+ {
+ T{ person f 1 "billy" 200 3.14 }
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
+ [
+ {
+ T{ person f 1 "billy" 200 3.14 }
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f } select-tuples ] unit-test
+
+ [
+ {
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
+
+
+ [ ] [ person1 get delete-tuples ] unit-test
+ [ f ] [ T{ person f 1 } select-tuple ] unit-test
+
+ [ ] [ person3 get insert-tuple ] unit-test
+
+ [
+ T{
+ person
+ f
+ 3
+ "teddy"
+ 10
+ 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+ }
+ ] [ T{ person f 3 } select-tuple ] unit-test
+
+ [ ] [ person4 get insert-tuple ] unit-test
+ [
+ T{
+ person
+ f
+ 4
+ "eddie"
+ 10
+ 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ f
+ H{ { 1 2 } { 3 4 } { 5 "lol" } }
+ URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
+ }
+ ] [ T{ person f 4 } select-tuple ] unit-test
+
+ [ ] [ person drop-table ] unit-test ;
+
+: db-assigned-person-schema ( -- )
+ person "PERSON"
+ {
+ { "the-id" "ID" +db-assigned-id+ }
+ { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "the-number" "AGE" INTEGER { +default+ 0 } }
+ { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
+ { "factor-blob" "FB" FACTOR-BLOB }
+ { "url" "U" URL }
+ } define-persistent
+ "billy" 10 3.14 f f f f f f <person> person1 set
+ "johnny" 10 3.14 f f f f f f <person> person2 set
+ "teddy" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
+ "eddie" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
+
+: user-assigned-person-schema ( -- )
+ person "PERSON"
+ {
+ { "the-id" "ID" INTEGER +user-assigned-id+ }
+ { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "the-number" "AGE" INTEGER { +default+ 0 } }
+ { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
+ { "factor-blob" "FB" FACTOR-BLOB }
+ { "url" "U" URL }
+ } define-persistent
+ 1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
+ 2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
+ 3 "teddy" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+ f f <user-assigned-person> person3 set
+ 4 "eddie" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
+
+TUPLE: paste n summary author channel mode contents timestamp annotations ;
+TUPLE: annotation n paste-id summary author mode contents ;
+
+: db-assigned-paste-schema ( -- )
+ paste "PASTE"
+ {
+ { "n" "ID" +db-assigned-id+ }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "channel" "CHANNEL" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ { "date" "DATE" TIMESTAMP }
+ { "annotations" { +has-many+ annotation } }
+ } define-persistent
+
+ annotation "ANNOTATION"
+ {
+ { "n" "ID" +db-assigned-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ } define-persistent ;
+
+! { "localhost" "postgres" "" "factor-test" } postgresql-db [
+ ! [ paste drop-table ] [ drop ] recover
+ ! [ annotation drop-table ] [ drop ] recover
+ ! [ paste drop-table ] [ drop ] recover
+ ! [ annotation drop-table ] [ drop ] recover
+ ! [ ] [ paste create-table ] unit-test
+ ! [ ] [ annotation create-table ] unit-test
+! ] with-db
+
+: test-sqlite ( quot -- )
+ [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
+
+: test-postgresql ( quot -- )
+ [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
+
+: test-repeated-insert
+ [ ] [ person ensure-table ] unit-test
+ [ ] [ person1 get insert-tuple ] unit-test
+ [ person1 get insert-tuple ] must-fail ;
+
+TUPLE: serialize-me id data ;
+
+: test-serialize ( -- )
+ serialize-me "SERIALIZED"
+ {
+ { "id" "ID" +db-assigned-id+ }
+ { "data" "DATA" FACTOR-BLOB }
+ } define-persistent
+ [ serialize-me drop-table ] [ drop ] recover
+ [ ] [ serialize-me create-table ] unit-test
+
+ [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
+ [
+ { T{ serialize-me f 1 H{ { 1 2 } } } }
+ ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
+
+TUPLE: exam id name score ;
+
+: random-exam ( -- exam )
+ f
+ 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
+ 100 random
+ exam boa ;
+
+: test-intervals ( -- )
+ exam "EXAM"
+ {
+ { "id" "ID" +db-assigned-id+ }
+ { "name" "NAME" TEXT }
+ { "score" "SCORE" INTEGER }
+ } define-persistent
+ [ exam drop-table ] [ drop ] recover
+ [ ] [ exam create-table ] unit-test
+
+ [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
+ ] unit-test
+
+ [
+ { }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ }
+ ] [
+ T{ exam f f { "Stan" "Kyle" } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ range f 1 3 1 } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ }
+ ] [
+ T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam } select-tuples
+ ] unit-test
+
+ [ 4 ] [ T{ exam } f count-tuples ] unit-test ;
+
+TUPLE: bignum-test id m n o ;
+: <bignum-test> ( m n o -- obj )
+ bignum-test new
+ swap >>o
+ swap >>n
+ swap >>m ;
+
+: test-bignum
+ bignum-test "BIGNUM_TEST"
+ {
+ { "id" "ID" +db-assigned-id+ }
+ { "m" "M" BIG-INTEGER }
+ { "n" "N" UNSIGNED-BIG-INTEGER }
+ { "o" "O" SIGNED-BIG-INTEGER }
+ } define-persistent
+ [ bignum-test drop-table ] ignore-errors
+ [ ] [ bignum-test ensure-table ] unit-test
+ [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
+
+ ! sqlite only
+ ! [ T{ bignum-test f 1
+ ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
+ ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
+
+TUPLE: secret n message ;
+C: <secret> secret
+
+: test-random-id
+ secret "SECRET"
+ {
+ { "n" "ID" +random-id+ system-random-generator }
+ { "message" "MESSAGE" TEXT }
+ } define-persistent
+
+ [ ] [ secret recreate-table ] unit-test
+
+ [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
+
+ [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
+
+ [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
+
+ [ t ] [
+ T{ secret } select-tuples
+ first message>> "kilroy was here" head?
+ ] unit-test
+
+ [ t ] [
+ T{ secret } select-tuples length 3 =
+ ] unit-test ;
+
+[ db-assigned-person-schema test-tuples ] test-sqlite
+[ user-assigned-person-schema test-tuples ] test-sqlite
+[ user-assigned-person-schema test-repeated-insert ] test-sqlite
+[ test-bignum ] test-sqlite
+[ test-serialize ] test-sqlite
+[ test-intervals ] test-sqlite
+[ test-random-id ] test-sqlite
+
+[ db-assigned-person-schema test-tuples ] test-postgresql
+[ user-assigned-person-schema test-tuples ] test-postgresql
+[ user-assigned-person-schema test-repeated-insert ] test-postgresql
+[ test-bignum ] test-postgresql
+[ test-serialize ] test-postgresql
+[ test-intervals ] test-postgresql
+[ test-random-id ] test-postgresql
+
+TUPLE: does-not-persist ;
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-sqlite
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-postgresql
+
+
+TUPLE: suparclass id a ;
+
+suparclass f {
+ { "id" "ID" +db-assigned-id+ }
+ { "a" "A" INTEGER }
+} define-persistent
+
+TUPLE: subbclass < suparclass b ;
+
+subbclass "SUBCLASS" {
+ { "b" "B" TEXT }
+} define-persistent
+
+TUPLE: fubbclass < subbclass ;
+
+fubbclass "FUBCLASS" { } define-persistent
+
+: test-db-inheritance ( -- )
+ [ ] [ subbclass ensure-table ] unit-test
+ [ ] [ fubbclass ensure-table ] unit-test
+
+ [ ] [
+ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
+ ] unit-test
+
+ [ t "hi" 5 ] [
+ subbclass new "id" get >>id select-tuple
+ [ subbclass? ] [ b>> ] [ a>> ] tri
+ ] unit-test
+
+ [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
+
+ [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
+
+[ test-db-inheritance ] test-sqlite
+[ test-db-inheritance ] test-postgresql
+
+
+TUPLE: string-encoding-test id string ;
+
+string-encoding-test "STRING_ENCODING_TEST" {
+ { "id" "ID" +db-assigned-id+ }
+ { "string" "STRING" TEXT }
+} define-persistent
+
+: test-string-encoding ( -- )
+ [ ] [ string-encoding-test ensure-table ] unit-test
+
+ [ ] [
+ string-encoding-test new
+ "\u{copyright-sign}\u{bengali-letter-cha}" >>string
+ [ insert-tuple ] [ id>> "id" set ] bi
+ ] unit-test
+
+ [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
+ string-encoding-test new "id" get >>id select-tuple string>>
+ ] unit-test ;
+
+[ test-string-encoding ] test-sqlite
+[ test-string-encoding ] test-postgresql
+
+! Don't comment these out. These words must infer
+\ bind-tuple must-infer
+\ insert-tuple must-infer
+\ update-tuple must-infer
+\ delete-tuples must-infer
+\ select-tuple must-infer
+\ define-persistent must-infer
+\ ensure-table must-infer
+\ create-table must-infer
+\ drop-table must-infer
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes db kernel namespaces
+classes.tuple words sequences slots math accessors
+math.parser io prettyprint db.types continuations
+destructors mirrors sequences.lib combinators.lib ;
+IN: db.tuples
+
+: define-persistent ( class table columns -- )
+ >r dupd "db-table" set-word-prop dup r>
+ [ relation? ] partition swapd
+ dupd [ spec>tuple ] with map
+ "db-columns" set-word-prop
+ "db-relations" set-word-prop ;
+
+ERROR: not-persistent class ;
+
+: db-table ( class -- obj )
+ dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+
+: db-columns ( class -- obj )
+ superclasses [ "db-columns" word-prop ] map concat ;
+
+: db-relations ( class -- obj )
+ "db-relations" word-prop ;
+
+: set-primary-key ( key tuple -- )
+ [
+ class db-columns find-primary-key slot-name>>
+ ] keep set-slot-named ;
+
+SYMBOL: sql-counter
+: next-sql-counter ( -- str )
+ sql-counter [ inc ] [ get ] bi number>string ;
+
+! returns a sequence of prepared-statements
+HOOK: create-sql-statement db ( class -- obj )
+HOOK: drop-sql-statement db ( class -- obj )
+
+HOOK: <insert-db-assigned-statement> db ( class -- obj )
+HOOK: <insert-user-assigned-statement> db ( class -- obj )
+HOOK: <update-tuple-statement> db ( class -- obj )
+HOOK: <delete-tuples-statement> db ( tuple class -- obj )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
+TUPLE: query group order offset limit ;
+HOOK: <query> db ( tuple class query -- statement' )
+HOOK: <count-statement> db ( tuple class groups -- n )
+
+HOOK: insert-tuple* db ( tuple statement -- )
+
+GENERIC: eval-generator ( singleton -- obj )
+SINGLETON: retryable
+
+: make-retryable ( obj -- obj' )
+ dup sequence? [
+ [ make-retryable ] map
+ ] [
+ retryable >>type
+ 10 >>retries
+ ] if ;
+
+: regenerate-params ( statement -- statement )
+ dup
+ [ bind-params>> ] [ in-params>> ] bi
+ [
+ dup generator-bind? [
+ generator-singleton>> eval-generator >>value
+ ] [
+ drop
+ ] if
+ ] 2map >>bind-params ;
+
+M: retryable execute-statement* ( statement type -- )
+ drop [
+ [
+ [ query-results dispose t ]
+ [ ]
+ [ regenerate-params bind-statement* f ] cleanup
+ ] curry
+ ] [ retries>> ] bi retry drop ;
+
+: resulting-tuple ( class row out-params -- tuple )
+ rot class new [
+ [
+ >r slot-name>> r> set-slot-named
+ ] curry 2each
+ ] keep ;
+
+: query-tuples ( exemplar-tuple statement -- seq )
+ [ out-params>> ] keep query-results [
+ [ sql-row-typed swap resulting-tuple ] with with query-map
+ ] with-disposal ;
+
+: query-modify-tuple ( tuple statement -- )
+ [ query-results [ sql-row-typed ] with-disposal ] keep
+ out-params>> rot [
+ >r slot-name>> r> set-slot-named
+ ] curry 2each ;
+
+: sql-props ( class -- columns table )
+ [ db-columns ] [ db-table ] bi ;
+
+: with-disposals ( seq quot -- )
+ over sequence? [
+ [ with-disposal ] curry each
+ ] [
+ with-disposal
+ ] if ; inline
+
+: create-table ( class -- )
+ create-sql-statement [ execute-statement ] with-disposals ;
+
+: drop-table ( class -- )
+ drop-sql-statement [ execute-statement ] with-disposals ;
+
+: recreate-table ( class -- )
+ [
+ [ drop-sql-statement [ execute-statement ] with-disposals
+ ] curry ignore-errors
+ ] [ create-table ] bi ;
+
+: ensure-table ( class -- )
+ [ create-table ] curry ignore-errors ;
+
+: ensure-tables ( classes -- )
+ [ ensure-table ] each ;
+
+: insert-db-assigned-statement ( tuple -- )
+ dup class
+ db get insert-statements>> [ <insert-db-assigned-statement> ] cache
+ [ bind-tuple ] 2keep insert-tuple* ;
+
+: insert-user-assigned-statement ( tuple -- )
+ dup class
+ db get insert-statements>> [ <insert-user-assigned-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
+
+: insert-tuple ( tuple -- )
+ dup class db-columns find-primary-key db-assigned-id-spec?
+ [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
+
+: update-tuple ( tuple -- )
+ dup class
+ db get update-statements>> [ <update-tuple-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
+
+: delete-tuples ( tuple -- )
+ dup dup class <delete-tuples-statement> [
+ [ bind-tuple ] keep execute-statement
+ ] with-disposal ;
+
+: do-select ( exemplar-tuple statement -- tuples )
+ [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+
+: query ( tuple query -- tuples )
+ >r dup dup class r> <query> do-select ;
+
+: select-tuples ( tuple -- tuples )
+ dup dup class <select-by-slots-statement> do-select ;
+
+: select-tuple ( tuple -- tuple/f )
+ dup dup class \ query new 1 >>limit <query> do-select ?first ;
+
+: do-count ( exemplar-tuple statement -- tuples )
+ [
+ [ bind-tuple ] [ nip default-query ] 2bi
+ ] with-disposal ;
+
+: count-tuples ( tuple groups -- n )
+ >r dup dup class r> <count-statement> do-count
+ dup length 1 =
+ [ first first string>number ] [ [ first string>number ] map ] if ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs db kernel math math.parser
+sequences continuations sequences.deep sequences.lib
+words namespaces slots slots.private classes mirrors
+classes.tuple combinators calendar.format symbols
+classes.singleton accessors quotations random ;
+IN: db.types
+
+HOOK: persistent-table db ( -- hash )
+HOOK: compound db ( str obj -- hash )
+
+TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
+
+TUPLE: literal-bind key type value ;
+C: <literal-bind> literal-bind
+
+TUPLE: generator-bind slot-name key generator-singleton type ;
+C: <generator-bind> generator-bind
+SINGLETON: random-id-generator
+
+TUPLE: low-level-binding value ;
+C: <low-level-binding> low-level-binding
+
+SINGLETON: +db-assigned-id+
+SINGLETON: +user-assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
++foreign-id+ +has-many+ ;
+
+: find-random-generator ( seq -- obj )
+ [
+ {
+ random-generator
+ system-random-generator
+ secure-random-generator
+ } member?
+ ] find nip [ system-random-generator ] unless* ;
+
+: primary-key? ( spec -- ? )
+ primary-key>> +primary-key+? ;
+
+: db-assigned-id-spec? ( spec -- ? )
+ primary-key>> +db-assigned-id+? ;
+
+: assigned-id-spec? ( spec -- ? )
+ primary-key>> +user-assigned-id+? ;
+
+: normalize-spec ( spec -- )
+ dup type>> dup +primary-key+? [
+ >>primary-key drop
+ ] [
+ drop dup modifiers>> [
+ +primary-key+?
+ ] deep-find
+ [ >>primary-key drop ] [ drop ] if*
+ ] if ;
+
+: find-primary-key ( specs -- obj )
+ [ primary-key>> ] find nip ;
+
+: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
+
+SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
+FACTOR-BLOB NULL URL ;
+
+: spec>tuple ( class spec -- tuple )
+ 3 f pad-right
+ [ first3 ] keep 3 tail
+ sql-spec new
+ swap >>modifiers
+ swap >>type
+ swap >>column-name
+ swap >>slot-name
+ swap >>class
+ dup normalize-spec ;
+
+: number>string* ( n/str -- str )
+ dup number? [ number>string ] when ;
+
+: remove-db-assigned-id ( specs -- obj )
+ [ +db-assigned-id+? not ] filter ;
+
+: remove-relations ( specs -- newcolumns )
+ [ relation? not ] filter ;
+
+: remove-id ( specs -- obj )
+ [ primary-key>> not ] filter ;
+
+! SQLite Types: http://www.sqlite.org/datatype3.html
+! NULL INTEGER REAL TEXT BLOB
+! PostgreSQL Types:
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+ERROR: unknown-modifier ;
+
+: lookup-modifier ( obj -- str )
+ {
+ { [ dup array? ] [ unclip lookup-modifier swap compound ] }
+ [ persistent-table at* [ unknown-modifier ] unless third ]
+ } cond ;
+
+ERROR: no-sql-type ;
+
+: (lookup-type) ( obj -- str )
+ persistent-table at* [ no-sql-type ] unless ;
+
+: lookup-type ( obj -- str )
+ dup array? [
+ unclip (lookup-type) first nip
+ ] [
+ (lookup-type) first
+ ] if ;
+
+: lookup-create-type ( obj -- str )
+ dup array? [
+ unclip (lookup-type) second swap compound
+ ] [
+ (lookup-type) second
+ ] if ;
+
+: single-quote ( str -- newstr )
+ "'" swap "'" 3append ;
+
+: double-quote ( str -- newstr )
+ "\"" swap "\"" 3append ;
+
+: paren ( str -- newstr )
+ "(" swap ")" 3append ;
+
+: join-space ( str1 str2 -- newstr )
+ " " swap 3append ;
+
+: modifiers ( spec -- str )
+ modifiers>> [ lookup-modifier ] map " " join
+ dup empty? [ " " prepend ] unless ;
+
+HOOK: bind% db ( spec -- )
+HOOK: bind# db ( spec obj -- )
+
+: offset-of-slot ( str obj -- n )
+ class superclasses [ "slots" word-prop ] map concat
+ slot-named offset>> ;
+
+: get-slot-named ( name obj -- value )
+ tuck offset-of-slot slot ;
+
+: set-slot-named ( value name obj -- )
+ tuck offset-of-slot set-slot ;
+
+: tuple>filled-slots ( tuple -- alist )
+ <mirror> [ nip ] assoc-filter ;
+
+: tuple>params ( specs tuple -- obj )
+ [
+ >r [ type>> ] [ slot-name>> ] bi r>
+ get-slot-named swap
+ ] curry { } map>assoc ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: db.tests\r
-USING: tools.test db kernel ;\r
-\r
-{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
-{ 1 1 } [ [ ] query-map ] must-infer-as\r
-{ 2 0 } [ [ ] with-db ] must-infer-as\r
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes continuations destructors kernel math
-namespaces sequences sequences.lib classes.tuple words strings
-tools.walker accessors combinators.lib ;
-IN: db
-
-TUPLE: db
- handle
- insert-statements
- update-statements
- delete-statements ;
-
-: new-db ( class -- obj )
- new
- H{ } clone >>insert-statements
- H{ } clone >>update-statements
- H{ } clone >>delete-statements ;
-
-GENERIC: make-db* ( seq class -- db )
-
-: make-db ( seq class -- db )
- new-db make-db* ;
-
-GENERIC: db-open ( db -- db )
-HOOK: db-close db ( handle -- )
-
-: dispose-statements ( assoc -- ) values dispose-each ;
-
-: dispose-db ( db -- )
- dup db [
- dup insert-statements>> dispose-statements
- dup update-statements>> dispose-statements
- dup delete-statements>> dispose-statements
- handle>> db-close
- ] with-variable ;
-
-TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
-TUPLE: simple-statement < statement ;
-TUPLE: prepared-statement < statement ;
-
-TUPLE: result-set sql in-params out-params handle n max ;
-
-: construct-statement ( sql in out class -- statement )
- new
- swap >>out-params
- swap >>in-params
- swap >>sql ;
-
-HOOK: <simple-statement> db ( str in out -- statement )
-HOOK: <prepared-statement> db ( str in out -- statement )
-GENERIC: prepare-statement ( statement -- )
-GENERIC: bind-statement* ( statement -- )
-GENERIC: low-level-bind ( statement -- )
-GENERIC: bind-tuple ( tuple statement -- )
-GENERIC: query-results ( query -- result-set )
-GENERIC: #rows ( result-set -- n )
-GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set column -- obj )
-GENERIC# row-column-typed 1 ( result-set column -- sql )
-GENERIC: advance-row ( result-set -- )
-GENERIC: more-rows? ( result-set -- ? )
-
-GENERIC: execute-statement* ( statement type -- )
-
-M: object execute-statement* ( statement type -- )
- drop query-results dispose ;
-
-: execute-statement ( statement -- )
- dup sequence? [
- [ execute-statement ] each
- ] [
- dup type>> execute-statement*
- ] if ;
-
-: bind-statement ( obj statement -- )
- swap >>bind-params
- [ bind-statement* ] keep
- t >>bound? drop ;
-
-: init-result-set ( result-set -- )
- dup #rows >>max
- 0 >>n drop ;
-
-: construct-result-set ( query handle class -- result-set )
- new
- swap >>handle
- >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
- swap >>out-params
- swap >>in-params
- swap >>sql ;
-
-: sql-row ( result-set -- seq )
- dup #columns [ row-column ] with map ;
-
-: sql-row-typed ( result-set -- seq )
- dup #columns [ row-column-typed ] with map ;
-
-: query-each ( statement quot: ( statement -- ) -- )
- over more-rows? [
- [ call ] 2keep over advance-row query-each
- ] [
- 2drop
- ] if ; inline recursive
-
-: query-map ( statement quot -- seq )
- accumulator >r query-each r> { } like ; inline
-
-: with-db ( seq class quot -- )
- >r make-db db-open db r>
- [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
- inline
-
-: default-query ( query -- result-set )
- query-results [ [ sql-row ] query-map ] with-disposal ;
-
-: do-bound-query ( obj query -- rows )
- [ bind-statement ] keep default-query ;
-
-: do-bound-command ( obj query -- )
- [ bind-statement ] keep execute-statement ;
-
-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 ;
-
-: sql-query ( sql -- rows )
- f f <simple-statement> [ default-query ] with-disposal ;
-
-: sql-command ( sql -- )
- dup string? [
- f f <simple-statement> [ execute-statement ] with-disposal
- ] [
- ! [
- [ sql-command ] each
- ! ] with-transaction
- ] if ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
-IN: db.errors
-
-ERROR: db-error ;
-ERROR: sql-error ;
-
-
-ERROR: table-exists ;
-ERROR: bad-schema ;
+++ /dev/null
-IN: db.pools.tests
-USING: db.pools tools.test continuations io.files namespaces
-accessors kernel math destructors ;
-
-\ <db-pool> must-infer
-
-{ 2 0 } [ [ ] with-db-pool ] must-infer-as
-
-{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
-
-! Test behavior after image save/load
-USE: db.sqlite
-
-[ "pool-test.db" temp-file delete-file ] ignore-errors
-
-[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
-
-[ ] [ "pool" get expired>> t >>expired drop ] unit-test
-
-[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
-
-[ ] [ "pool" get dispose ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays namespaces sequences continuations
-io.pools db ;
-IN: db.pools
-
-TUPLE: db-pool < pool db params ;
-
-: <db-pool> ( params db -- pool )
- db-pool <pool>
- swap >>db
- swap >>params ;
-
-: with-db-pool ( db params quot -- )
- >r <db-pool> r> with-pool ; inline
-
-M: db-pool make-connection ( pool -- )
- [ params>> ] [ db>> ] bi make-db db-open ;
-
-: with-pooled-db ( pool quot -- )
- [ db swap with-variable ] curry with-pooled-connection ; inline
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-! tested on debian linux with postgresql 8.1
-USING: alien alien.syntax combinators system ;
-IN: db.postgresql.ffi
-
-<< "postgresql" {
- { [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "libpq.dylib" ] }
- { [ os unix? ] [ "libpq.so" ] }
-} cond "cdecl" add-library >>
-
-! 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
-
-! 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
-
-! 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
-
-! 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
-
-! PGVerbosity;
-: PQERRORS_TERSE HEX: 0 ; inline
-: PQERRORS_DEFAULT HEX: 1 ; inline
-: PQERRORS_VERBOSE HEX: 2 ; inline
-
-: InvalidOid 0 ; inline
-
-TYPEDEF: int ConnStatusType
-TYPEDEF: int ExecStatusType
-TYPEDEF: int PostgresPollingStatusType
-TYPEDEF: int PGTransactionStatusType
-TYPEDEF: int PGVerbosity
-
-TYPEDEF: void* PGconn*
-TYPEDEF: void* PGresult*
-TYPEDEF: void* PGcancel*
-TYPEDEF: uint Oid
-TYPEDEF: uint* Oid*
-TYPEDEF: char pqbool
-TYPEDEF: void* PQconninfoOption*
-TYPEDEF: void* PGnotify*
-TYPEDEF: void* PQArgBlock*
-TYPEDEF: void* PQprintOpt*
-TYPEDEF: void* FILE*
-TYPEDEF: void* SSL*
-
-LIBRARY: postgresql
-
-! Exported functions of libpq
-
-! make a new client connection to the backend
-! Asynchronous (non-blocking)
-FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
-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 ) ;
-
-: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
- f f PQsetdbLogin ;
-
-! close the current connection and free the PGconn data structure
-FUNCTION: void PQfinish ( PGconn* conn ) ;
-
-! get info about connection options known to PQconnectdb
-FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
-
-! free the data structure returned by PQconndefaults()
-FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
-
-! Asynchronous (non-blocking)
-FUNCTION: int PQresetStart ( PGconn* conn ) ;
-FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
-
-! Synchronous (blocking)
-FUNCTION: void PQreset ( PGconn* conn ) ;
-
-! request a cancel structure
-FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
-
-! free a cancel structure
-FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
-
-! issue a cancel request
-FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
-
-! Accessor functions for PGconn objects
-FUNCTION: char* PQdb ( PGconn* conn ) ;
-FUNCTION: char* PQuser ( PGconn* conn ) ;
-FUNCTION: char* PQpass ( PGconn* conn ) ;
-FUNCTION: char* PQhost ( PGconn* conn ) ;
-FUNCTION: char* PQport ( PGconn* conn ) ;
-FUNCTION: char* PQtty ( PGconn* conn ) ;
-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 ) ;
-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 ) ;
-
-! May not be compiled into libpq
-! Get the SSL structure associated with a connection
-FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
-
-! Tell libpq whether it needs to initialize OpenSSL
-FUNCTION: void PQinitSSL ( int do_init ) ;
-
-! Set verbosity for PQerrorMessage and PQresultErrorMessage
-FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
- PGVerbosity verbosity ) ;
-
-! Enable/disable tracing
-FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
-FUNCTION: void PQuntrace ( PGconn* conn ) ;
-
-! BROKEN
-! Function types for notice-handling callbacks
-! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
-! typedef void (*PQnoticeProcessor) (void *arg, char* message);
-! ALIAS: void* PQnoticeReceiver
-! ALIAS: void* PQnoticeProcessor
-
-! Override default notice handling routines
-! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
- ! PQnoticeReceiver proc,
- ! void* arg ) ;
-! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
- ! PQnoticeProcessor proc,
- ! void* arg ) ;
-! END BROKEN
-
-! === in fe-exec.c ===
-
-! 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 ) ;
-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 ) ;
-
-! 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 ) ;
-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 ) ;
-FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
-
-! Routines for managing an asynchronous query
-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 ) ;
-
-! 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 ) ;
-
-! Set blocking/nonblocking connection to the backend
-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 ) ;
-
-!
-! * "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 ) ;
-
-! Accessor functions for PGresult objects
-FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
-FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
-FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
-FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
-FUNCTION: int PQntuples ( PGresult* res ) ;
-FUNCTION: int PQnfields ( PGresult* res ) ;
-FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
-FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
-FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
-FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
-FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
-FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
-FUNCTION: char* PQoidStatus ( PGresult* res ) ;
-FUNCTION: Oid PQoidValue ( PGresult* res ) ;
-FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
-! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
-
-! Delete a PGresult
-FUNCTION: void PQclear ( PGresult* res ) ;
-
-! For freeing other alloc'd results, such as PGnotify structs
-FUNCTION: void PQfreemem ( void* ptr ) ;
-
-! Exists for backward compatibility.
-: PQfreeNotify ( ptr -- ) PQfreemem ;
-
-!
-! Make an empty PGresult with given status (some apps find this
-! useful). If conn is not NULL and status indicates an error, the
-! conn's errorMessage is copied.
-!
-FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
-
-! Quoting strings before inclusion in queries.
-FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
- char* to, char* from, size_t length,
- int* error ) ;
-FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
- char* from, size_t length,
- size_t* to_length ) ;
-FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
-! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
-! 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 ) ;
-
-! === in fe-print.c ===
-
-FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
-
-! really old printing routines
-FUNCTION: void PQdisplayTuples ( PGresult* res,
- FILE* fp,
- int fillAlign,
- char* fieldSep,
- int printHeader,
- int quiet ) ;
-
-FUNCTION: void PQprintTuples ( PGresult* res,
- FILE* fout,
- 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 ) ;
-
-! === in fe-misc.c ===
-
-! Determine length of multibyte encoded char at *s
-FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
-
-! Determine display length of multibyte encoded char at *s
-FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
-
-! Get encoding id from environment variable PGCLIENTENCODING
-FUNCTION: int PQenv2encoding ( ) ;
-
-! From git, include/catalog/pg_type.h
-: BOOL-OID 16 ; inline
-: BYTEA-OID 17 ; inline
-: CHAR-OID 18 ; inline
-: NAME-OID 19 ; inline
-: INT8-OID 20 ; inline
-: INT2-OID 21 ; inline
-: INT4-OID 23 ; inline
-: TEXT-OID 23 ; inline
-: OID-OID 26 ; inline
-: FLOAT4-OID 700 ; inline
-: FLOAT8-OID 701 ; inline
-: VARCHAR-OID 1043 ; inline
-: DATE-OID 1082 ; inline
-: TIME-OID 1083 ; inline
-: TIMESTAMP-OID 1114 ; inline
-: TIMESTAMPTZ-OID 1184 ; inline
-: INTERVAL-OID 1186 ; inline
-: NUMERIC-OID 1700 ; inline
+++ /dev/null
-! 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
-db.types tools.walker ascii splitting math.parser combinators
-libc shuffle calendar.format byte-arrays destructors prettyprint
-accessors strings serialize io.encodings.binary io.encodings.utf8
-alien.strings io.streams.byte-array summary present urls ;
-IN: db.postgresql.lib
-
-: postgresql-result-error-message ( res -- str/f )
- dup zero? [
- drop f
- ] [
- PQresultErrorMessage [ blank? ] trim
- ] if ;
-
-: postgres-result-error ( res -- )
- postgresql-result-error-message [ throw ] when* ;
-
-: (postgresql-error-message) ( handle -- str )
- PQerrorMessage
- "\n" split [ [ blank? ] trim ] map "\n" join ;
-
-: postgresql-error-message ( -- str )
- db get handle>> (postgresql-error-message) ;
-
-: postgresql-error ( res -- res )
- dup [ postgresql-error-message throw ] unless ;
-
-ERROR: postgresql-result-null ;
-
-M: postgresql-result-null summary ( obj -- str )
- drop "PQexec returned f." ;
-
-: postgresql-result-ok? ( res -- ? )
- [ postgresql-result-null ] unless*
- 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 handle>> swap sql>> PQexec dup postgresql-result-ok? [
- [ postgresql-result-error-message ] [ PQclear ] bi throw
- ] unless ;
-
-: type>oid ( symbol -- n )
- dup array? [ first ] when
- {
- { BLOB [ BYTEA-OID ] }
- { FACTOR-BLOB [ BYTEA-OID ] }
- [ drop 0 ]
- } case ;
-
-: type>param-format ( symbol -- n )
- dup array? [ first ] when
- {
- { BLOB [ 1 ] }
- { FACTOR-BLOB [ 1 ] }
- [ drop 0 ]
- } case ;
-
-: param-types ( statement -- seq )
- in-params>> [ type>> type>oid ] map >c-uint-array ;
-
-: malloc-byte-array/length ( byte-array -- alien length )
- [ malloc-byte-array &free ] [ length ] bi ;
-
-: default-param-value ( obj -- alien n )
- number>string* dup [ utf8 malloc-string &free ] when 0 ;
-
-: param-values ( statement -- seq seq2 )
- [ bind-params>> ] [ in-params>> ] bi
- [
- >r value>> r> type>> {
- { FACTOR-BLOB [
- dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
- ] }
- { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
- { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
- { TIME [ dup [ timestamp>hms ] when default-param-value ] }
- { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
- { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
- { URL [ dup [ present ] when default-param-value ] }
- [ drop default-param-value ]
- } case 2array
- ] 2map flip dup empty? [
- drop f f
- ] [
- first2 [ >c-void*-array ] [ >c-uint-array ] bi*
- ] if ;
-
-: param-formats ( statement -- seq )
- in-params>> [ type>> type>param-format ] map >c-uint-array ;
-
-: do-postgresql-bound-statement ( statement -- res )
- [
- >r db get handle>> r>
- {
- [ sql>> ]
- [ bind-params>> length ]
- [ param-types ]
- [ param-values ]
- [ param-formats ]
- } cleave
- 0 PQexecParams dup postgresql-result-ok? [
- [ postgresql-result-error-message ] [ PQclear ] bi throw
- ] unless
- ] with-destructors ;
-
-: pq-get-is-null ( handle row column -- ? )
- PQgetisnull 1 = ;
-
-: pq-get-string ( handle row column -- obj )
- 3dup PQgetvalue utf8 alien>string
- dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
-
-: pq-get-number ( handle row column -- obj )
- pq-get-string dup [ string>number ] when ;
-
-TUPLE: postgresql-malloc-destructor alien ;
-C: <postgresql-malloc-destructor> postgresql-malloc-destructor
-
-M: postgresql-malloc-destructor dispose ( obj -- )
- alien>> PQfreemem ;
-
-: &postgresql-free ( alien -- alien )
- dup <postgresql-malloc-destructor> &dispose drop ; inline
-
-: pq-get-blob ( handle row column -- obj/f )
- [ PQgetvalue ] 3keep 3dup PQgetlength
- dup 0 > [
- 3nip
- [
- memory>byte-array >string
- 0 <uint>
- [
- PQunescapeBytea dup zero? [
- postgresql-result-error-message throw
- ] [
- &postgresql-free
- ] if
- ] keep
- *uint memory>byte-array
- ] with-destructors
- ] [
- drop pq-get-is-null nip [ f ] [ B{ } clone ] if
- ] if ;
-
-: postgresql-column-typed ( handle row column type -- obj )
- dup array? [ first ] when
- {
- { +db-assigned-id+ [ pq-get-number ] }
- { +random-id+ [ pq-get-number ] }
- { INTEGER [ pq-get-number ] }
- { BIG-INTEGER [ pq-get-number ] }
- { DOUBLE [ pq-get-number ] }
- { TEXT [ pq-get-string ] }
- { VARCHAR [ pq-get-string ] }
- { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
- { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
- { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
- { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
- { BLOB [ pq-get-blob ] }
- { URL [ pq-get-string dup [ >url ] when ] }
- { FACTOR-BLOB [
- pq-get-blob
- dup [ bytes>object ] when ] }
- [ no-sql-type ]
- } case ;
+++ /dev/null
-! 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 classes
-prettyprint sequences namespaces tools.test db
-db.tuples db.types unicode.case ;
-IN: db.postgresql.tests
-
-: test-db ( -- postgresql-db )
- { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
-
-[ ] [ test-db [ ] with-db ] unit-test
-
-[ ] [
- test-db [
- [ "drop table person;" sql-command ] ignore-errors
- "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" }
- { "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
-] must-fail
-
-[ 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
-
-
-: with-dummy-db ( quot -- )
- >r T{ postgresql-db } db r> with-variable ;
+++ /dev/null
-! 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 math.parser namespaces prettyprint quotations
-sequences debugger db db.postgresql.lib db.postgresql.ffi
-db.tuples db.types tools.annotations math.ranges
-combinators sequences.lib classes locals words tools.walker
-namespaces.lib accessors random db.queries destructors ;
-USE: tools.walker
-IN: db.postgresql
-
-TUPLE: postgresql-db < db
- host port pgopts pgtty db user pass ;
-
-TUPLE: postgresql-statement < statement ;
-
-TUPLE: postgresql-result-set < result-set ;
-
-M: postgresql-db make-db* ( seq tuple -- db )
- >r first4 r>
- swap >>db
- swap >>pass
- swap >>user
- swap >>host ;
-
-M: postgresql-db db-open ( db -- db )
- dup {
- [ host>> ]
- [ port>> ]
- [ pgopts>> ]
- [ pgtty>> ]
- [ db>> ]
- [ user>> ]
- [ pass>> ]
- } cleave connect-postgres >>handle ;
-
-M: postgresql-db dispose ( db -- )
- handle>> PQfinish ;
-
-M: postgresql-statement bind-statement* ( statement -- )
- drop ;
-
-GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
-
-M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
- slot-name>> swap get-slot-named <low-level-binding> ;
-
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
- nip value>> <low-level-binding> ;
-
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
- dup generator-singleton>> eval-generator
- [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
-
-M: postgresql-statement bind-tuple ( tuple statement -- )
- tuck in-params>>
- [ postgresql-bind-conversion ] with map
- >>bind-params drop ;
-
-M: postgresql-result-set #rows ( result-set -- n )
- handle>> PQntuples ;
-
-M: postgresql-result-set #columns ( result-set -- n )
- handle>> PQnfields ;
-
-: result-handle-n ( result-set -- handle n )
- [ handle>> ] [ n>> ] bi ;
-
-M: postgresql-result-set row-column ( result-set column -- obj )
- >r result-handle-n r> pq-get-string ;
-
-M: postgresql-result-set row-column-typed ( result-set column -- obj )
- dup pick out-params>> nth type>>
- >r >r result-handle-n r> r> postgresql-column-typed ;
-
-M: postgresql-statement query-results ( query -- result-set )
- dup bind-params>> [
- over [ bind-statement ] keep
- do-postgresql-bound-statement
- ] [
- dup do-postgresql-statement
- ] if*
- postgresql-result-set construct-result-set
- dup init-result-set ;
-
-M: postgresql-result-set advance-row ( result-set -- )
- [ 1+ ] change-n drop ;
-
-M: postgresql-result-set more-rows? ( result-set -- ? )
- [ n>> ] [ max>> ] bi < ;
-
-M: postgresql-statement dispose ( query -- )
- dup handle>> PQclear
- f >>handle drop ;
-
-M: postgresql-result-set dispose ( result-set -- )
- [ handle>> PQclear ]
- [
- 0 >>n
- 0 >>max
- f >>handle drop
- ] bi ;
-
-M: postgresql-statement prepare-statement ( statement -- )
- dup
- >r db get handle>> f r>
- [ sql>> ] [ in-params>> ] bi
- length f PQprepare postgresql-error
- >>handle drop ;
-
-M: postgresql-db <simple-statement> ( sql in out -- statement )
- postgresql-statement construct-statement ;
-
-M: postgresql-db <prepared-statement> ( sql in out -- statement )
- <simple-statement> dup prepare-statement ;
-
-: bind-name% ( -- )
- CHAR: $ 0,
- sql-counter [ inc ] [ get 0# ] bi ;
-
-M: postgresql-db bind% ( spec -- )
- bind-name% 1, ;
-
-M: postgresql-db bind# ( spec obj -- )
- >r bind-name% f swap type>> r> <literal-bind> 1, ;
-
-: create-table-sql ( class -- statement )
- [
- "create table " 0% 0%
- "(" 0% [ ", " 0% ] [
- dup column-name>> 0%
- " " 0%
- dup type>> lookup-create-type 0%
- modifiers 0%
- ] interleave ");" 0%
- ] query-make ;
-
-: create-function-sql ( class -- statement )
- [
- >r remove-id r>
- "create function add_" 0% dup 0%
- "(" 0%
- over [ "," 0% ]
- [
- type>> lookup-type 0%
- ] interleave
- ")" 0%
- " returns bigint as '" 0%
-
- "insert into " 0%
- dup 0%
- "(" 0%
- over [ ", " 0% ] [ column-name>> 0% ] interleave
- ") values(" 0%
- swap [ ", " 0% ] [ drop bind-name% ] interleave
- "); " 0%
- "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
- ] query-make ;
-
-M: postgresql-db create-sql-statement ( class -- seq )
- [
- [ create-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ create-function-sql , ] [ drop ] if
- ] { } make ;
-
-: drop-function-sql ( class -- statement )
- [
- "drop function add_" 0% 0%
- "(" 0%
- remove-id
- [ ", " 0% ] [ type>> lookup-type 0% ] interleave
- ");" 0%
- ] query-make ;
-
-: drop-table-sql ( table -- statement )
- [
- "drop table " 0% 0% drop
- ] query-make ;
-
-M: postgresql-db drop-sql-statement ( class -- seq )
- [
- [ drop-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ drop-function-sql , ] [ drop ] if
- ] { } make ;
-
-M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
- [
- "select add_" 0% 0%
- "(" 0%
- dup find-primary-key 2,
- remove-id
- [ ", " 0% ] [ bind% ] interleave
- ");" 0%
- ] query-make ;
-
-M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
- [
- "insert into " 0% 0%
- "(" 0%
- dup [ ", " 0% ] [ column-name>> 0% ] interleave
- ")" 0%
-
- " values(" 0%
- [ ", " 0% ] [
- dup type>> +random-id+ = [
- [
- bind-name%
- slot-name>>
- f
- random-id-generator
- ] [ type>> ] bi <generator-bind> 1,
- ] [
- bind%
- ] if
- ] interleave
- ");" 0%
- ] query-make ;
-
-M: postgresql-db insert-tuple* ( tuple statement -- )
- query-modify-tuple ;
-
-M: postgresql-db persistent-table ( -- hashtable )
- H{
- { +db-assigned-id+ { "integer" "serial primary key" f } }
- { +user-assigned-id+ { f f "primary key" } }
- { +random-id+ { "bigint" "bigint primary key" f } }
- { TEXT { "text" "text" f } }
- { VARCHAR { "varchar" "varchar" f } }
- { INTEGER { "integer" "integer" f } }
- { BIG-INTEGER { "bigint" "bigint" f } }
- { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
- { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
- { DOUBLE { "real" "real" f } }
- { DATE { "date" "date" f } }
- { TIME { "time" "time" f } }
- { DATETIME { "timestamp" "timestamp" f } }
- { TIMESTAMP { "timestamp" "timestamp" f } }
- { BLOB { "bytea" "bytea" f } }
- { FACTOR-BLOB { "bytea" "bytea" f } }
- { URL { "varchar" "varchar" f } }
- { +foreign-id+ { f f "references" } }
- { +autoincrement+ { f f "autoincrement" } }
- { +unique+ { f f "unique" } }
- { +default+ { f f "default" } }
- { +null+ { f f "null" } }
- { +not-null+ { f f "not null" } }
- { system-random-generator { f f f } }
- { secure-random-generator { f f f } }
- { random-generator { f f f } }
- } ;
-
-M: postgresql-db compound ( str obj -- str' )
- over {
- { "default" [ first number>string join-space ] }
- { "varchar" [ first number>string paren append ] }
- { "references" [
- first2 >r [ unparse join-space ] keep db-columns r>
- swap [ slot-name>> = ] with find nip
- column-name>> paren append
- ] }
- [ "no compound found" 3array throw ]
- } case ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces sequences random
-strings math.parser math.intervals combinators
-math.bitfields.lib namespaces.lib db db.tuples db.types
-sequences.lib db.sql classes words shuffle arrays ;
-IN: db.queries
-
-GENERIC: where ( specs obj -- )
-
-: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains?
- [ make-retryable ] when ;
-
-: query-make ( class quot -- )
- >r sql-props r>
- [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
- <simple-statement> maybe-make-retryable ; inline
-
-M: db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
-: where-primary-key% ( specs -- )
- " where " 0%
- find-primary-key dup column-name>> 0% " = " 0% bind% ;
-
-M: db <update-tuple-statement> ( class -- statement )
- [
- "update " 0% 0%
- " set " 0%
- dup remove-id
- [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
- where-primary-key%
- ] query-make ;
-
-M: random-id-generator eval-generator ( singleton -- obj )
- drop
- system-random-generator get [
- 63 [ 2^ random ] keep 1 - set-bit
- ] with-random ;
-
-: interval-comparison ( ? str -- str )
- "from" = " >" " <" ? swap [ "= " append ] when ;
-
-: fp-infinity? ( float -- ? )
- dup float? [
- double>bits -52 shift 11 2^ 1- [ bitand ] keep =
- ] [
- drop f
- ] if ;
-
-: (infinite-interval?) ( interval -- ?1 ?2 )
- [ from>> ] [ to>> ] bi
- [ first fp-infinity? ] bi@ ;
-
-: double-infinite-interval? ( obj -- ? )
- dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
-
-: infinite-interval? ( obj -- ? )
- dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
-
-: where-interval ( spec obj from/to -- )
- over first fp-infinity? [
- 3drop
- ] [
- pick column-name>> 0%
- >r first2 r> interval-comparison 0%
- bind#
- ] if ;
-
-: in-parens ( quot -- )
- "(" 0% call ")" 0% ; inline
-
-M: interval where ( spec obj -- )
- [
- [ from>> "from" where-interval ] [
- nip infinite-interval? [ " and " 0% ] unless
- ] [ to>> "to" where-interval ] 2tri
- ] in-parens ;
-
-M: sequence where ( spec obj -- )
- [
- [ " or " 0% ] [ dupd where ] interleave drop
- ] in-parens ;
-
-: object-where ( spec obj -- )
- over column-name>> 0% " = " 0% bind# ;
-
-M: object where ( spec obj -- ) object-where ;
-
-M: integer where ( spec obj -- ) object-where ;
-
-M: string where ( spec obj -- ) object-where ;
-
-: filter-slots ( tuple specs -- specs' )
- [
- slot-name>> swap get-slot-named
- dup double-infinite-interval? [ drop f ] when
- ] with filter ;
-
-: where-clause ( tuple specs -- )
- dupd filter-slots [
- drop
- ] [
- " where " 0% [
- " and " 0%
- ] [
- 2dup slot-name>> swap get-slot-named where
- ] interleave drop
- ] if-empty ;
-
-M: db <delete-tuples-statement> ( tuple table -- sql )
- [
- "delete from " 0% 0%
- where-clause
- ] query-make ;
-
-M: db <select-by-slots-statement> ( tuple class -- statement )
- [
- "select " 0%
- over [ ", " 0% ]
- [ dup column-name>> 0% 2, ] interleave
-
- " from " 0% 0%
- where-clause
- ] query-make ;
-
-: do-group ( tuple groups -- )
- [
- ", " join " group by " prepend append
- ] curry change-sql drop ;
-
-: do-order ( tuple order -- )
- [
- ", " join " order by " prepend append
- ] curry change-sql drop ;
-
-: do-offset ( tuple n -- )
- [
- number>string " offset " prepend append
- ] curry change-sql drop ;
-
-: do-limit ( tuple n -- )
- [
- number>string " limit " prepend append
- ] curry change-sql drop ;
-
-: make-query ( tuple query -- tuple' )
- dupd
- {
- [ group>> [ do-group ] [ drop ] if-seq ]
- [ order>> [ do-order ] [ drop ] if-seq ]
- [ limit>> [ do-limit ] [ drop ] if* ]
- [ offset>> [ do-offset ] [ drop ] if* ]
- } 2cleave ;
-
-M: db <query> ( tuple class query -- tuple )
- [ <select-by-slots-statement> ] dip make-query ;
-
-! select ID, NAME, SCORE from EXAM limit 1 offset 3
-
-: select-tuples* ( tuple -- statement )
- dup
- [
- select 0,
- dup class db-columns [ ", " 0, ]
- [ dup column-name>> 0, 2, ] interleave
- from 0,
- class name>> 0,
- ] { { } { } { } } nmake
- >r >r parse-sql 4drop r> r>
- <simple-statement> maybe-make-retryable do-select ;
-
-M: db <count-statement> ( tuple class groups -- statement )
- \ query new
- swap >>group
- [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
- dip make-query ;
-
-: create-index ( index-name table-name columns -- )
- [
- >r >r "create index " % % r> " on " % % r> "(" %
- "," join % ")" %
- ] "" make sql-command ;
-
-: drop-index ( index-name -- )
- [ "drop index " % % ] "" make sql-command ;
+++ /dev/null
-USING: kernel namespaces db.sql sequences math ;
-IN: db.sql.tests
-
-! TUPLE: person name age ;
-: insert-1
- { insert
- {
- { table "person" }
- { columns "name" "age" }
- { values "erg" 26 }
- }
- } ;
-
-: update-1
- { update "person"
- { set { "name" "erg" }
- { "age" 6 } }
- { where { "age" 6 } }
- } ;
-
-: select-1
- { select
- { columns
- "branchno"
- { count "staffno" as "mycount" }
- { sum "salary" as "mysum" } }
- { from "staff" "lol" }
- { where
- { "salary" > all
- { select
- { columns "salary" }
- { from "staff" }
- { where { "branchno" = "b003" } }
- }
- }
- { "branchno" > 3 } }
- { group-by "branchno" "lol2" }
- { having { count "staffno" > 1 } }
- { order-by "branchno" }
- { offset 40 }
- { limit 20 }
- } ;
+++ /dev/null
-USING: kernel parser quotations classes.tuple words math.order
-namespaces.lib namespaces sequences arrays combinators
-prettyprint strings math.parser sequences.lib math symbols ;
-IN: db.sql
-
-SYMBOLS: insert update delete select distinct columns from as
-where group-by having order-by limit offset is-null desc all
-any count avg table values ;
-
-: input-spec, ( obj -- ) 1, ;
-: output-spec, ( obj -- ) 2, ;
-: input, ( obj -- ) 3, ;
-: output, ( obj -- ) 4, ;
-
-DEFER: sql%
-
-: (sql-interleave) ( seq sep -- )
- [ sql% ] curry [ sql% ] interleave ;
-
-: sql-interleave ( seq str sep -- )
- swap sql% (sql-interleave) ;
-
-: sql-function, ( seq function -- )
- sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
-
-: sql-where ( seq -- )
-B
- [
- [ second 0, ]
- [ first 0, ]
- [ third 1, \ ? 0, ] tri
- ] each ;
-
-: sql-array% ( array -- )
-B
- unclip
- {
- { \ create [ "create table" sql% ] }
- { \ drop [ "drop table" sql% ] }
- { \ insert [ "insert into" sql% ] }
- { \ update [ "update" sql% ] }
- { \ delete [ "delete" sql% ] }
- { \ select [ B "select" sql% "," (sql-interleave) ] }
- { \ columns [ "," (sql-interleave) ] }
- { \ from [ "from" "," sql-interleave ] }
- { \ where [ B "where" 0, sql-where ] }
- { \ group-by [ "group by" "," sql-interleave ] }
- { \ having [ "having" "," sql-interleave ] }
- { \ order-by [ "order by" "," sql-interleave ] }
- { \ offset [ "offset" sql% sql% ] }
- { \ limit [ "limit" sql% sql% ] }
- { \ select [ "(select" sql% sql% ")" sql% ] }
- { \ table [ sql% ] }
- { \ set [ "set" "," sql-interleave ] }
- { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
- { \ count [ "count" sql-function, ] }
- { \ sum [ "sum" sql-function, ] }
- { \ avg [ "avg" sql-function, ] }
- { \ min [ "min" sql-function, ] }
- { \ max [ "max" sql-function, ] }
- [ sql% [ sql% ] each ]
- } case ;
-
-ERROR: no-sql-match ;
-: sql% ( obj -- )
- {
- { [ dup string? ] [ 0, ] }
- { [ dup array? ] [ sql-array% ] }
- { [ dup number? ] [ number>string sql% ] }
- { [ dup symbol? ] [ unparse sql% ] }
- { [ dup word? ] [ unparse sql% ] }
- { [ dup quotation? ] [ call ] }
- [ no-sql-match ]
- } cond ;
-
-: parse-sql ( obj -- sql in-spec out-spec in out )
- [ [ sql% ] each ] { { } { } { } } nmake ;
+++ /dev/null
-Chris Double
-Doug Coleman
+++ /dev/null
-! 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.
-USING: alien compiler kernel math namespaces sequences strings alien.syntax
- system combinators alien.c-types ;
-IN: db.sqlite.ffi
-
-<< "sqlite" {
- { [ os winnt? ] [ "sqlite3.dll" ] }
- { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ os 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"
-} ;
-
-! Return values from sqlite3_step
-: SQLITE_ROW 100 ; inline
-: SQLITE_DONE 101 ; inline
-
-! 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
-TYPEDEF: longlong sqlite3_int64
-TYPEDEF: ulonglong sqlite3_uint64
-
-LIBRARY: sqlite
-FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
-FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
-FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
-FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
-FUNCTION: int sqlite3_prepare_v2 ( 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: sqlite3_uint64 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_double ( sqlite3_stmt* pStmt, int index, double x ) ;
-FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
-FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
-: sqlite3-bind-uint64 ( pStmt index in64 -- int )
- "int" "sqlite" "sqlite3_bind_int64"
- { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
-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_clear_bindings ( sqlite3_stmt* pStmt ) ;
-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: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
-: sqlite3-column-uint64 ( pStmt col -- uint64 )
- "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
- { "sqlite3_stmt*" "int" } alien-invoke ;
-FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: char* 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 ) ;
+++ /dev/null
-! Copyright (C) 2008 Chris Double, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays assocs kernel math math.parser
-namespaces sequences db.sqlite.ffi db combinators
-continuations db.types calendar.format serialize
-io.streams.byte-array byte-arrays io.encodings.binary
-io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors ;
-IN: db.sqlite.lib
-
-ERROR: sqlite-error < db-error n string ;
-ERROR: sqlite-sql-error < sql-error n string ;
-
-: throw-sqlite-error ( n -- * )
- dup sqlite-error-messages nth sqlite-error ;
-
-: sqlite-statement-error ( -- * )
- SQLITE_ERROR
- db get handle>> sqlite3_errmsg sqlite-sql-error ;
-
-: sqlite-check-result ( n -- )
- {
- { SQLITE_OK [ ] }
- { SQLITE_ERROR [ sqlite-statement-error ] }
- [ throw-sqlite-error ]
- } case ;
-
-: sqlite-open ( path -- db )
- normalize-path
- "void*" <c-object>
- [ sqlite3_open sqlite-check-result ] keep *void* ;
-
-: sqlite-close ( db -- )
- sqlite3_close sqlite-check-result ;
-
-: sqlite-prepare ( db sql -- handle )
- utf8 encode dup length "void*" <c-object> "void*" <c-object>
- [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
- drop *void* ;
-
-: sqlite-bind-parameter-index ( handle name -- index )
- sqlite3_bind_parameter_index ;
-
-: parameter-index ( handle name text -- handle name text )
- >r dupd sqlite-bind-parameter-index r> ;
-
-: sqlite-bind-text ( handle index text -- )
- utf8 encode dup length SQLITE_TRANSIENT
- sqlite3_bind_text sqlite-check-result ;
-
-: sqlite-bind-int ( handle i n -- )
- sqlite3_bind_int sqlite-check-result ;
-
-: sqlite-bind-int64 ( handle i n -- )
- sqlite3_bind_int64 sqlite-check-result ;
-
-: sqlite-bind-uint64 ( handle i n -- )
- sqlite3-bind-uint64 sqlite-check-result ;
-
-: sqlite-bind-double ( handle i x -- )
- sqlite3_bind_double sqlite-check-result ;
-
-: sqlite-bind-null ( handle i -- )
- sqlite3_bind_null sqlite-check-result ;
-
-: sqlite-bind-blob ( handle i byte-array -- )
- dup length SQLITE_TRANSIENT
- sqlite3_bind_blob sqlite-check-result ;
-
-: sqlite-bind-text-by-name ( handle name text -- )
- parameter-index sqlite-bind-text ;
-
-: sqlite-bind-int-by-name ( handle name int -- )
- parameter-index sqlite-bind-int ;
-
-: sqlite-bind-int64-by-name ( handle name int64 -- )
- parameter-index sqlite-bind-int64 ;
-
-: sqlite-bind-uint64-by-name ( handle name int64 -- )
- parameter-index sqlite-bind-uint64 ;
-
-: sqlite-bind-double-by-name ( handle name double -- )
- parameter-index sqlite-bind-double ;
-
-: sqlite-bind-blob-by-name ( handle name blob -- )
- parameter-index sqlite-bind-blob ;
-
-: sqlite-bind-null-by-name ( handle name obj -- )
- parameter-index drop sqlite-bind-null ;
-
-: sqlite-bind-type ( handle key value type -- )
- over [ drop NULL ] unless
- dup array? [ first ] when
- {
- { INTEGER [ sqlite-bind-int-by-name ] }
- { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
- { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
- { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
- { TEXT [ sqlite-bind-text-by-name ] }
- { VARCHAR [ sqlite-bind-text-by-name ] }
- { DOUBLE [ sqlite-bind-double-by-name ] }
- { DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
- { TIME [ timestamp>hms sqlite-bind-text-by-name ] }
- { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
- { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
- { BLOB [ sqlite-bind-blob-by-name ] }
- { FACTOR-BLOB [
- object>bytes
- sqlite-bind-blob-by-name
- ] }
- { URL [ present sqlite-bind-text-by-name ] }
- { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
- { +random-id+ [ sqlite-bind-int64-by-name ] }
- { NULL [ sqlite-bind-null-by-name ] }
- [ no-sql-type ]
- } case ;
-
-: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
-: sqlite-clear-bindings ( handle -- )
- sqlite3_clear_bindings sqlite-check-result ;
-: sqlite-#columns ( query -- int ) sqlite3_column_count ;
-: sqlite-column ( handle index -- string ) sqlite3_column_text ;
-: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
-: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
-
-: sqlite-column-blob ( handle index -- byte-array/f )
- [ sqlite3_column_bytes ] 2keep
- pick zero? [
- 3drop f
- ] [
- sqlite3_column_blob swap memory>byte-array
- ] if ;
-
-: sqlite-column-typed ( handle index type -- obj )
- dup array? [ first ] when
- {
- { +db-assigned-id+ [ sqlite3_column_int64 ] }
- { +random-id+ [ sqlite3-column-uint64 ] }
- { INTEGER [ sqlite3_column_int ] }
- { BIG-INTEGER [ sqlite3_column_int64 ] }
- { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
- { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
- { DOUBLE [ sqlite3_column_double ] }
- { TEXT [ sqlite3_column_text ] }
- { VARCHAR [ sqlite3_column_text ] }
- { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
- { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
- { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
- { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
- { BLOB [ sqlite-column-blob ] }
- { URL [ sqlite3_column_text dup [ >url ] when ] }
- { FACTOR-BLOB [
- sqlite-column-blob
- dup [ bytes>object ] when
- ] }
- ! { NULL [ 2drop f ] }
- [ no-sql-type ]
- } case ;
-
-: sqlite-row ( handle -- seq )
- dup sqlite-#columns [ sqlite-column ] with map ;
-
-: sqlite-step-has-more-rows? ( prepared -- bool )
- {
- { SQLITE_ROW [ t ] }
- { SQLITE_DONE [ f ] }
- [ sqlite-check-result f ]
- } case ;
-
-: sqlite-next ( prepared -- ? )
- sqlite3_step sqlite-step-has-more-rows? ;
+++ /dev/null
-USING: io io.files io.launcher kernel namespaces
-prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case ;
-IN: db.sqlite.tests
-
-: db-path "test.db" temp-file ;
-: test.db db-path sqlite-db ;
-
-[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
-
-[ ] [
- test.db [
- "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
-
-[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
-[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
-
-[ ] [
- test.db [
- "insert into person(name, country) values('Jimmy', 'Canada')"
- sql-command
- ] with-db
-] unit-test
-
-[
- {
- { "1" "John" "America" }
- { "2" "Jane" "New Zealand" }
- { "3" "Jimmy" "Canada" }
- }
-] [ test.db [ "select rowid, * 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
-] must-fail
-
-[ 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
+++ /dev/null
-! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assocs classes compiler db
-hashtables io.files kernel math math.parser namespaces
-prettyprint sequences strings classes.tuple alien.c-types
-continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types combinators math.intervals
-io namespaces.lib accessors vectors math.ranges random
-math.bitfields.lib db.queries destructors ;
-USE: tools.walker
-IN: db.sqlite
-
-TUPLE: sqlite-db < db path ;
-
-M: sqlite-db make-db* ( path db -- db )
- swap >>path ;
-
-M: sqlite-db db-open ( db -- db )
- dup path>> sqlite-open >>handle ;
-
-M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) dispose-db ;
-
-TUPLE: sqlite-statement < statement ;
-
-TUPLE: sqlite-result-set < result-set has-more? ;
-
-M: sqlite-db <simple-statement> ( str in out -- obj )
- <prepared-statement> ;
-
-M: sqlite-db <prepared-statement> ( str in out -- obj )
- sqlite-statement construct-statement ;
-
-: sqlite-maybe-prepare ( statement -- statement )
- dup handle>> [
- db get handle>> over sql>> sqlite-prepare
- >>handle
- ] unless ;
-
-M: sqlite-statement dispose ( statement -- )
- handle>>
- [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
-
-M: sqlite-result-set dispose ( result-set -- )
- f >>handle drop ;
-
-: reset-statement ( statement -- )
- sqlite-maybe-prepare handle>> sqlite-reset ;
-
-: reset-bindings ( statement -- )
- sqlite-maybe-prepare
- handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
-
-M: sqlite-statement low-level-bind ( statement -- )
- [ bind-params>> ] [ handle>> ] bi
- [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
-
-M: sqlite-statement bind-statement* ( statement -- )
- sqlite-maybe-prepare
- dup bound?>> [ dup reset-bindings ] when
- low-level-bind ;
-
-GENERIC: sqlite-bind-conversion ( tuple obj -- array )
-
-TUPLE: sqlite-low-level-binding < low-level-binding key type ;
-: <sqlite-low-level-binding> ( key value type -- obj )
- sqlite-low-level-binding new
- swap >>type
- swap >>value
- swap >>key ;
-
-M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
- [ column-name>> ":" prepend ]
- [ slot-name>> rot get-slot-named ]
- [ type>> ] tri <sqlite-low-level-binding> ;
-
-M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
- nip [ key>> ] [ value>> ] [ type>> ] tri
- <sqlite-low-level-binding> ;
-
-M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
- tuck
- [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
- rot set-slot-named
- >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
-
-M: sqlite-statement bind-tuple ( tuple statement -- )
- [
- in-params>> [ sqlite-bind-conversion ] with map
- ] keep bind-statement ;
-
-: last-insert-id ( -- id )
- db get handle>> sqlite3_last_insert_rowid
- dup zero? [ "last-id failed" throw ] when ;
-
-M: sqlite-db insert-tuple* ( tuple statement -- )
- execute-statement last-insert-id swap set-primary-key ;
-
-M: sqlite-result-set #columns ( result-set -- n )
- handle>> sqlite-#columns ;
-
-M: sqlite-result-set row-column ( result-set n -- obj )
- [ handle>> ] [ sqlite-column ] bi* ;
-
-M: sqlite-result-set row-column-typed ( result-set n -- obj )
- dup pick out-params>> nth type>>
- >r >r handle>> r> r> sqlite-column-typed ;
-
-M: sqlite-result-set advance-row ( result-set -- )
- dup handle>> sqlite-next >>has-more? drop ;
-
-M: sqlite-result-set more-rows? ( result-set -- ? )
- has-more?>> ;
-
-M: sqlite-statement query-results ( query -- result-set )
- sqlite-maybe-prepare
- dup handle>> sqlite-result-set construct-result-set
- dup advance-row ;
-
-M: sqlite-db create-sql-statement ( class -- statement )
- [
- "create table " 0% 0%
- "(" 0% [ ", " 0% ] [
- dup column-name>> 0%
- " " 0%
- dup type>> lookup-create-type 0%
- modifiers 0%
- ] interleave ");" 0%
- ] query-make ;
-
-M: sqlite-db drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
-M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
- [
- "insert into " 0% 0%
- "(" 0%
- remove-db-assigned-id
- dup [ ", " 0% ] [ column-name>> 0% ] interleave
- ") values(" 0%
- [ ", " 0% ] [
- dup type>> +random-id+ = [
- [ slot-name>> ]
- [
- column-name>> ":" prepend dup 0%
- random-id-generator
- ] [ type>> ] tri <generator-bind> 1,
- ] [
- bind%
- ] if
- ] interleave
- ");" 0%
- ] query-make ;
-
-M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
- <insert-db-assigned-statement> ;
-
-M: sqlite-db bind# ( spec obj -- )
- >r
- [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
- [ type>> ] bi
- r> <literal-bind> 1, ;
-
-M: sqlite-db bind% ( spec -- )
- dup 1, column-name>> ":" prepend 0% ;
-
-M: sqlite-db persistent-table ( -- assoc )
- H{
- { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
- { +user-assigned-id+ { f f "primary key" } }
- { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
- { INTEGER { "integer" "integer" "primary key" } }
- { BIG-INTEGER { "bigint" "bigint" } }
- { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
- { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
- { TEXT { "text" "text" } }
- { VARCHAR { "text" "text" } }
- { DATE { "date" "date" } }
- { TIME { "time" "time" } }
- { DATETIME { "datetime" "datetime" } }
- { TIMESTAMP { "timestamp" "timestamp" } }
- { DOUBLE { "real" "real" } }
- { BLOB { "blob" "blob" } }
- { FACTOR-BLOB { "blob" "blob" } }
- { URL { "text" "text" } }
- { +autoincrement+ { f f "autoincrement" } }
- { +unique+ { f f "unique" } }
- { +default+ { f f "default" } }
- { +null+ { f f "null" } }
- { +not-null+ { f f "not null" } }
- { system-random-generator { f f f } }
- { secure-random-generator { f f f } }
- { random-generator { f f f } }
- } ;
-
-M: sqlite-db compound ( str seq -- str' )
- over {
- { "default" [ first number>string join-space ] }
- [ 2drop ]
- } case ;
+++ /dev/null
-create table person (name varchar(30), country varchar(30));
-insert into person values('John', 'America');
-insert into person values('Jane', 'New Zealand');
+++ /dev/null
-Relational database abstraction layer
+++ /dev/null
-enterprise
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.tuples classes
-db.types continuations namespaces math math.ranges
-prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitfields.lib
-math.ranges strings sequences.lib urls fry ;
-IN: db.tuples.tests
-
-TUPLE: person the-id the-name the-number the-real
-ts date time blob factor-blob url ;
-
-: <person> ( name age real ts date time blob factor-blob url -- person )
- person new
- swap >>url
- swap >>factor-blob
- swap >>blob
- swap >>time
- swap >>date
- swap >>ts
- swap >>the-real
- swap >>the-number
- swap >>the-name ;
-
-: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
- <person>
- swap >>the-id ;
-
-SYMBOL: person1
-SYMBOL: person2
-SYMBOL: person3
-SYMBOL: person4
-
-: test-tuples ( -- )
- [ ] [ person recreate-table ] unit-test
- [ ] [ person ensure-table ] unit-test
- [ ] [ person drop-table ] unit-test
- [ ] [ person create-table ] unit-test
- [ person create-table ] must-fail
- [ ] [ person ensure-table ] unit-test
-
- [ ] [ person1 get insert-tuple ] unit-test
-
- [ 1 ] [ person1 get the-id>> ] unit-test
-
- [ ] [ person1 get 200 >>the-number drop ] unit-test
-
- [ ] [ person1 get update-tuple ] unit-test
-
- [ T{ person f 1 "billy" 200 3.14 } ]
- [ T{ person f 1 } select-tuple ] unit-test
- [ ] [ person2 get insert-tuple ] unit-test
- [
- {
- T{ person f 1 "billy" 200 3.14 }
- T{ person f 2 "johnny" 10 3.14 }
- }
- ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
- [
- {
- T{ person f 1 "billy" 200 3.14 }
- T{ person f 2 "johnny" 10 3.14 }
- }
- ] [ T{ person f } select-tuples ] unit-test
-
- [
- {
- T{ person f 2 "johnny" 10 3.14 }
- }
- ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
-
-
- [ ] [ person1 get delete-tuples ] unit-test
- [ f ] [ T{ person f 1 } select-tuple ] unit-test
-
- [ ] [ person3 get insert-tuple ] unit-test
-
- [
- T{
- person
- f
- 3
- "teddy"
- 10
- 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
- }
- ] [ T{ person f 3 } select-tuple ] unit-test
-
- [ ] [ person4 get insert-tuple ] unit-test
- [
- T{
- person
- f
- 4
- "eddie"
- 10
- 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- f
- H{ { 1 2 } { 3 4 } { 5 "lol" } }
- URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
- }
- ] [ T{ person f 4 } select-tuple ] unit-test
-
- [ ] [ person drop-table ] unit-test ;
-
-: db-assigned-person-schema ( -- )
- person "PERSON"
- {
- { "the-id" "ID" +db-assigned-id+ }
- { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
- { "the-number" "AGE" INTEGER { +default+ 0 } }
- { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
- { "ts" "TS" TIMESTAMP }
- { "date" "D" DATE }
- { "time" "T" TIME }
- { "blob" "B" BLOB }
- { "factor-blob" "FB" FACTOR-BLOB }
- { "url" "U" URL }
- } define-persistent
- "billy" 10 3.14 f f f f f f <person> person1 set
- "johnny" 10 3.14 f f f f f f <person> person2 set
- "teddy" 10 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
- "eddie" 10 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
-
-: user-assigned-person-schema ( -- )
- person "PERSON"
- {
- { "the-id" "ID" INTEGER +user-assigned-id+ }
- { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
- { "the-number" "AGE" INTEGER { +default+ 0 } }
- { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
- { "ts" "TS" TIMESTAMP }
- { "date" "D" DATE }
- { "time" "T" TIME }
- { "blob" "B" BLOB }
- { "factor-blob" "FB" FACTOR-BLOB }
- { "url" "U" URL }
- } define-persistent
- 1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
- 2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
- 3 "teddy" 10 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
- f f <user-assigned-person> person3 set
- 4 "eddie" 10 3.14
- T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
- f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
-
-TUPLE: paste n summary author channel mode contents timestamp annotations ;
-TUPLE: annotation n paste-id summary author mode contents ;
-
-: db-assigned-paste-schema ( -- )
- paste "PASTE"
- {
- { "n" "ID" +db-assigned-id+ }
- { "summary" "SUMMARY" TEXT }
- { "author" "AUTHOR" TEXT }
- { "channel" "CHANNEL" TEXT }
- { "mode" "MODE" TEXT }
- { "contents" "CONTENTS" TEXT }
- { "date" "DATE" TIMESTAMP }
- { "annotations" { +has-many+ annotation } }
- } define-persistent
-
- annotation "ANNOTATION"
- {
- { "n" "ID" +db-assigned-id+ }
- { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
- { "summary" "SUMMARY" TEXT }
- { "author" "AUTHOR" TEXT }
- { "mode" "MODE" TEXT }
- { "contents" "CONTENTS" TEXT }
- } define-persistent ;
-
-! { "localhost" "postgres" "" "factor-test" } postgresql-db [
- ! [ paste drop-table ] [ drop ] recover
- ! [ annotation drop-table ] [ drop ] recover
- ! [ paste drop-table ] [ drop ] recover
- ! [ annotation drop-table ] [ drop ] recover
- ! [ ] [ paste create-table ] unit-test
- ! [ ] [ annotation create-table ] unit-test
-! ] with-db
-
-: test-sqlite ( quot -- )
- [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
-
-: test-postgresql ( quot -- )
- [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
-
-: test-repeated-insert
- [ ] [ person ensure-table ] unit-test
- [ ] [ person1 get insert-tuple ] unit-test
- [ person1 get insert-tuple ] must-fail ;
-
-TUPLE: serialize-me id data ;
-
-: test-serialize ( -- )
- serialize-me "SERIALIZED"
- {
- { "id" "ID" +db-assigned-id+ }
- { "data" "DATA" FACTOR-BLOB }
- } define-persistent
- [ serialize-me drop-table ] [ drop ] recover
- [ ] [ serialize-me create-table ] unit-test
-
- [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
- [
- { T{ serialize-me f 1 H{ { 1 2 } } } }
- ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
-
-TUPLE: exam id name score ;
-
-: random-exam ( -- exam )
- f
- 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
- 100 random
- exam boa ;
-
-: test-intervals ( -- )
- exam "EXAM"
- {
- { "id" "ID" +db-assigned-id+ }
- { "name" "NAME" TEXT }
- { "score" "SCORE" INTEGER }
- } define-persistent
- [ exam drop-table ] [ drop ] recover
- [ ] [ exam create-table ] unit-test
-
- [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
- [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
- [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
- [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
-
- [
- {
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
- ] unit-test
-
- [
- { }
- ] [
- T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
- ] unit-test
- [
- {
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
- ] unit-test
- [
- {
- T{ exam f 3 "Kenny" 60 }
- }
- ] [
- T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
- ] unit-test
- [
- {
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 1 "Kyle" 100 }
- T{ exam f 2 "Stan" 80 }
- }
- ] [
- T{ exam f f { "Stan" "Kyle" } } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 1 "Kyle" 100 }
- T{ exam f 2 "Stan" 80 }
- T{ exam f 3 "Kenny" 60 }
- }
- ] [
- T{ exam f T{ range f 1 3 1 } } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 2 "Stan" 80 }
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 1 "Kyle" 100 }
- }
- ] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 1 "Kyle" 100 }
- T{ exam f 2 "Stan" 80 }
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
- ] unit-test
-
- [
- {
- T{ exam f 1 "Kyle" 100 }
- T{ exam f 2 "Stan" 80 }
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- }
- ] [
- T{ exam } select-tuples
- ] unit-test
-
- [ 4 ] [ T{ exam } f count-tuples ] unit-test ;
-
-TUPLE: bignum-test id m n o ;
-: <bignum-test> ( m n o -- obj )
- bignum-test new
- swap >>o
- swap >>n
- swap >>m ;
-
-: test-bignum
- bignum-test "BIGNUM_TEST"
- {
- { "id" "ID" +db-assigned-id+ }
- { "m" "M" BIG-INTEGER }
- { "n" "N" UNSIGNED-BIG-INTEGER }
- { "o" "O" SIGNED-BIG-INTEGER }
- } define-persistent
- [ bignum-test drop-table ] ignore-errors
- [ ] [ bignum-test ensure-table ] unit-test
- [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
-
- ! sqlite only
- ! [ T{ bignum-test f 1
- ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
- ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
-
-TUPLE: secret n message ;
-C: <secret> secret
-
-: test-random-id
- secret "SECRET"
- {
- { "n" "ID" +random-id+ system-random-generator }
- { "message" "MESSAGE" TEXT }
- } define-persistent
-
- [ ] [ secret recreate-table ] unit-test
-
- [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
-
- [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
-
- [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
-
- [ t ] [
- T{ secret } select-tuples
- first message>> "kilroy was here" head?
- ] unit-test
-
- [ t ] [
- T{ secret } select-tuples length 3 =
- ] unit-test ;
-
-[ db-assigned-person-schema test-tuples ] test-sqlite
-[ user-assigned-person-schema test-tuples ] test-sqlite
-[ user-assigned-person-schema test-repeated-insert ] test-sqlite
-[ test-bignum ] test-sqlite
-[ test-serialize ] test-sqlite
-[ test-intervals ] test-sqlite
-[ test-random-id ] test-sqlite
-
-[ db-assigned-person-schema test-tuples ] test-postgresql
-[ user-assigned-person-schema test-tuples ] test-postgresql
-[ user-assigned-person-schema test-repeated-insert ] test-postgresql
-[ test-bignum ] test-postgresql
-[ test-serialize ] test-postgresql
-[ test-intervals ] test-postgresql
-[ test-random-id ] test-postgresql
-
-TUPLE: does-not-persist ;
-
-[
- [ does-not-persist create-sql-statement ]
- [ class \ not-persistent = ] must-fail-with
-] test-sqlite
-
-[
- [ does-not-persist create-sql-statement ]
- [ class \ not-persistent = ] must-fail-with
-] test-postgresql
-
-
-TUPLE: suparclass id a ;
-
-suparclass f {
- { "id" "ID" +db-assigned-id+ }
- { "a" "A" INTEGER }
-} define-persistent
-
-TUPLE: subbclass < suparclass b ;
-
-subbclass "SUBCLASS" {
- { "b" "B" TEXT }
-} define-persistent
-
-TUPLE: fubbclass < subbclass ;
-
-fubbclass "FUBCLASS" { } define-persistent
-
-: test-db-inheritance ( -- )
- [ ] [ subbclass ensure-table ] unit-test
- [ ] [ fubbclass ensure-table ] unit-test
-
- [ ] [
- subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
- ] unit-test
-
- [ t "hi" 5 ] [
- subbclass new "id" get >>id select-tuple
- [ subbclass? ] [ b>> ] [ a>> ] tri
- ] unit-test
-
- [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
-
- [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
-
-[ test-db-inheritance ] test-sqlite
-[ test-db-inheritance ] test-postgresql
-
-
-TUPLE: string-encoding-test id string ;
-
-string-encoding-test "STRING_ENCODING_TEST" {
- { "id" "ID" +db-assigned-id+ }
- { "string" "STRING" TEXT }
-} define-persistent
-
-: test-string-encoding ( -- )
- [ ] [ string-encoding-test ensure-table ] unit-test
-
- [ ] [
- string-encoding-test new
- "\u{copyright-sign}\u{bengali-letter-cha}" >>string
- [ insert-tuple ] [ id>> "id" set ] bi
- ] unit-test
-
- [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
- string-encoding-test new "id" get >>id select-tuple string>>
- ] unit-test ;
-
-[ test-string-encoding ] test-sqlite
-[ test-string-encoding ] test-postgresql
-
-! Don't comment these out. These words must infer
-\ bind-tuple must-infer
-\ insert-tuple must-infer
-\ update-tuple must-infer
-\ delete-tuples must-infer
-\ select-tuple must-infer
-\ define-persistent must-infer
-\ ensure-table must-infer
-\ create-table must-infer
-\ drop-table must-infer
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes db kernel namespaces
-classes.tuple words sequences slots math accessors
-math.parser io prettyprint db.types continuations
-destructors mirrors sequences.lib combinators.lib ;
-IN: db.tuples
-
-: define-persistent ( class table columns -- )
- >r dupd "db-table" set-word-prop dup r>
- [ relation? ] partition swapd
- dupd [ spec>tuple ] with map
- "db-columns" set-word-prop
- "db-relations" set-word-prop ;
-
-ERROR: not-persistent class ;
-
-: db-table ( class -- obj )
- dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
-
-: db-columns ( class -- obj )
- superclasses [ "db-columns" word-prop ] map concat ;
-
-: db-relations ( class -- obj )
- "db-relations" word-prop ;
-
-: set-primary-key ( key tuple -- )
- [
- class db-columns find-primary-key slot-name>>
- ] keep set-slot-named ;
-
-SYMBOL: sql-counter
-: next-sql-counter ( -- str )
- sql-counter [ inc ] [ get ] bi number>string ;
-
-! returns a sequence of prepared-statements
-HOOK: create-sql-statement db ( class -- obj )
-HOOK: drop-sql-statement db ( class -- obj )
-
-HOOK: <insert-db-assigned-statement> db ( class -- obj )
-HOOK: <insert-user-assigned-statement> db ( class -- obj )
-HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuples-statement> db ( tuple class -- obj )
-HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: query group order offset limit ;
-HOOK: <query> db ( tuple class query -- statement' )
-HOOK: <count-statement> db ( tuple class groups -- n )
-
-HOOK: insert-tuple* db ( tuple statement -- )
-
-GENERIC: eval-generator ( singleton -- obj )
-SINGLETON: retryable
-
-: make-retryable ( obj -- obj' )
- dup sequence? [
- [ make-retryable ] map
- ] [
- retryable >>type
- 10 >>retries
- ] if ;
-
-: regenerate-params ( statement -- statement )
- dup
- [ bind-params>> ] [ in-params>> ] bi
- [
- dup generator-bind? [
- generator-singleton>> eval-generator >>value
- ] [
- drop
- ] if
- ] 2map >>bind-params ;
-
-M: retryable execute-statement* ( statement type -- )
- drop [
- [
- [ query-results dispose t ]
- [ ]
- [ regenerate-params bind-statement* f ] cleanup
- ] curry
- ] [ retries>> ] bi retry drop ;
-
-: resulting-tuple ( class row out-params -- tuple )
- rot class new [
- [
- >r slot-name>> r> set-slot-named
- ] curry 2each
- ] keep ;
-
-: query-tuples ( exemplar-tuple statement -- seq )
- [ out-params>> ] keep query-results [
- [ sql-row-typed swap resulting-tuple ] with with query-map
- ] with-disposal ;
-
-: query-modify-tuple ( tuple statement -- )
- [ query-results [ sql-row-typed ] with-disposal ] keep
- out-params>> rot [
- >r slot-name>> r> set-slot-named
- ] curry 2each ;
-
-: sql-props ( class -- columns table )
- [ db-columns ] [ db-table ] bi ;
-
-: with-disposals ( seq quot -- )
- over sequence? [
- [ with-disposal ] curry each
- ] [
- with-disposal
- ] if ; inline
-
-: create-table ( class -- )
- create-sql-statement [ execute-statement ] with-disposals ;
-
-: drop-table ( class -- )
- drop-sql-statement [ execute-statement ] with-disposals ;
-
-: recreate-table ( class -- )
- [
- [ drop-sql-statement [ execute-statement ] with-disposals
- ] curry ignore-errors
- ] [ create-table ] bi ;
-
-: ensure-table ( class -- )
- [ create-table ] curry ignore-errors ;
-
-: ensure-tables ( classes -- )
- [ ensure-table ] each ;
-
-: insert-db-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-db-assigned-statement> ] cache
- [ bind-tuple ] 2keep insert-tuple* ;
-
-: insert-user-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-user-assigned-statement> ] cache
- [ bind-tuple ] keep execute-statement ;
-
-: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key db-assigned-id-spec?
- [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
-
-: update-tuple ( tuple -- )
- dup class
- db get update-statements>> [ <update-tuple-statement> ] cache
- [ bind-tuple ] keep execute-statement ;
-
-: delete-tuples ( tuple -- )
- dup dup class <delete-tuples-statement> [
- [ bind-tuple ] keep execute-statement
- ] with-disposal ;
-
-: do-select ( exemplar-tuple statement -- tuples )
- [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
-
-: query ( tuple query -- tuples )
- >r dup dup class r> <query> do-select ;
-
-: select-tuples ( tuple -- tuples )
- dup dup class <select-by-slots-statement> do-select ;
-
-: select-tuple ( tuple -- tuple/f )
- dup dup class \ query new 1 >>limit <query> do-select ?first ;
-
-: do-count ( exemplar-tuple statement -- tuples )
- [
- [ bind-tuple ] [ nip default-query ] 2bi
- ] with-disposal ;
-
-: count-tuples ( tuple groups -- n )
- >r dup dup class r> <count-statement> do-count
- dup length 1 =
- [ first first string>number ] [ [ first string>number ] map ] if ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs db kernel math math.parser
-sequences continuations sequences.deep sequences.lib
-words namespaces slots slots.private classes mirrors
-classes.tuple combinators calendar.format symbols
-classes.singleton accessors quotations random ;
-IN: db.types
-
-HOOK: persistent-table db ( -- hash )
-HOOK: compound db ( str obj -- hash )
-
-TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
-
-TUPLE: literal-bind key type value ;
-C: <literal-bind> literal-bind
-
-TUPLE: generator-bind slot-name key generator-singleton type ;
-C: <generator-bind> generator-bind
-SINGLETON: random-id-generator
-
-TUPLE: low-level-binding value ;
-C: <low-level-binding> low-level-binding
-
-SINGLETON: +db-assigned-id+
-SINGLETON: +user-assigned-id+
-SINGLETON: +random-id+
-UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
-
-SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ ;
-
-: find-random-generator ( seq -- obj )
- [
- {
- random-generator
- system-random-generator
- secure-random-generator
- } member?
- ] find nip [ system-random-generator ] unless* ;
-
-: primary-key? ( spec -- ? )
- primary-key>> +primary-key+? ;
-
-: db-assigned-id-spec? ( spec -- ? )
- primary-key>> +db-assigned-id+? ;
-
-: assigned-id-spec? ( spec -- ? )
- primary-key>> +user-assigned-id+? ;
-
-: normalize-spec ( spec -- )
- dup type>> dup +primary-key+? [
- >>primary-key drop
- ] [
- drop dup modifiers>> [
- +primary-key+?
- ] deep-find
- [ >>primary-key drop ] [ drop ] if*
- ] if ;
-
-: find-primary-key ( specs -- obj )
- [ primary-key>> ] find nip ;
-
-: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
-DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
-FACTOR-BLOB NULL URL ;
-
-: spec>tuple ( class spec -- tuple )
- 3 f pad-right
- [ first3 ] keep 3 tail
- sql-spec new
- swap >>modifiers
- swap >>type
- swap >>column-name
- swap >>slot-name
- swap >>class
- dup normalize-spec ;
-
-: number>string* ( n/str -- str )
- dup number? [ number>string ] when ;
-
-: remove-db-assigned-id ( specs -- obj )
- [ +db-assigned-id+? not ] filter ;
-
-: remove-relations ( specs -- newcolumns )
- [ relation? not ] filter ;
-
-: remove-id ( specs -- obj )
- [ primary-key>> not ] filter ;
-
-! SQLite Types: http://www.sqlite.org/datatype3.html
-! NULL INTEGER REAL TEXT BLOB
-! PostgreSQL Types:
-! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-
-ERROR: unknown-modifier ;
-
-: lookup-modifier ( obj -- str )
- {
- { [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ persistent-table at* [ unknown-modifier ] unless third ]
- } cond ;
-
-ERROR: no-sql-type ;
-
-: (lookup-type) ( obj -- str )
- persistent-table at* [ no-sql-type ] unless ;
-
-: lookup-type ( obj -- str )
- dup array? [
- unclip (lookup-type) first nip
- ] [
- (lookup-type) first
- ] if ;
-
-: lookup-create-type ( obj -- str )
- dup array? [
- unclip (lookup-type) second swap compound
- ] [
- (lookup-type) second
- ] if ;
-
-: single-quote ( str -- newstr )
- "'" swap "'" 3append ;
-
-: double-quote ( str -- newstr )
- "\"" swap "\"" 3append ;
-
-: paren ( str -- newstr )
- "(" swap ")" 3append ;
-
-: join-space ( str1 str2 -- newstr )
- " " swap 3append ;
-
-: modifiers ( spec -- str )
- modifiers>> [ lookup-modifier ] map " " join
- dup empty? [ " " prepend ] unless ;
-
-HOOK: bind% db ( spec -- )
-HOOK: bind# db ( spec obj -- )
-
-: offset-of-slot ( str obj -- n )
- class superclasses [ "slots" word-prop ] map concat
- slot-named offset>> ;
-
-: get-slot-named ( name obj -- value )
- tuck offset-of-slot slot ;
-
-: set-slot-named ( value name obj -- )
- tuck offset-of-slot set-slot ;
-
-: tuple>filled-slots ( tuple -- alist )
- <mirror> [ nip ] assoc-filter ;
-
-: tuple>params ( specs tuple -- obj )
- [
- >r [ type>> ] [ slot-name>> ] bi r>
- get-slot-named swap
- ] curry { } map>assoc ;
projects / factor.git / commitdiff