.#*
*.swo
checksums.txt
+a.out
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.connections db2.tester ;
+IN: db2.connections.tests
+
+! Tests connection
+
+{ 1 0 } [ [ ] with-db ] must-infer-as
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors fry kernel namespaces ;
+IN: db2.connections
+
+TUPLE: db-connection handle ;
+
+: new-db-connection ( handle class -- db-connection )
+ new
+ swap >>handle ; inline
+
+GENERIC: db-open ( db -- db-connection )
+GENERIC: db-close ( handle -- )
+HOOK: parse-db-error db-connection ( error -- error' )
+
+M: db-connection dispose ( db-connection -- )
+ [ db-close ] [ f >>handle drop ] bi ;
+
+: with-db ( db quot -- )
+ [ db-open db-connection over ] dip
+ '[ _ [ drop @ ] with-disposal ] with-variable ; inline
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2 kernel ;
+IN: db2.tests
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations destructors fry kernel
+namespaces sequences strings db2.statements ;
+IN: db2
+
+<PRIVATE
+
+: execute-sql-string ( string -- )
+ f f <statement> [ execute-statement ] with-disposal ;
+
+PRIVATE>
+
+: sql-command ( sql -- )
+ dup string?
+ [ execute-sql-string ]
+ [ [ execute-sql-string ] each ] if ;
+
+: sql-query ( sql -- sequence )
+ f f <statement> [ statement>result-sequence ] with-disposal ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel continuations fry words constructors
+db2.connections ;
+IN: db2.errors
+
+ERROR: db-error ;
+ERROR: sql-error location ;
+HOOK: parse-sql-error db-connection ( error -- error' )
+
+ERROR: sql-unknown-error < sql-error message ;
+CONSTRUCTOR: sql-unknown-error ( message -- error ) ;
+
+ERROR: sql-table-exists < sql-error table ;
+CONSTRUCTOR: sql-table-exists ( table -- error ) ;
+
+ERROR: sql-table-missing < sql-error table ;
+CONSTRUCTOR: sql-table-missing ( table -- error ) ;
+
+ERROR: sql-syntax-error < sql-error message ;
+CONSTRUCTOR: sql-syntax-error ( message -- error ) ;
+
+ERROR: sql-function-exists < sql-error message ;
+CONSTRUCTOR: sql-function-exists ( message -- error ) ;
+
+ERROR: sql-function-missing < sql-error message ;
+CONSTRUCTOR: sql-function-missing ( message -- error ) ;
+
+: ignore-error ( quot word -- )
+ '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
+
+: ignore-table-exists ( quot -- )
+ \ sql-table-exists? ignore-error ; inline
+
+: ignore-table-missing ( quot -- )
+ \ sql-table-missing? ignore-error ; inline
+
+: ignore-function-exists ( quot -- )
+ \ sql-function-exists? ignore-error ; inline
+
+: ignore-function-missing ( quot -- )
+ \ sql-function-missing? ignore-error ; inline
--- /dev/null
+Errors thrown by database library
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: accessors continuations db2.pools db2.sqlite
+db2.sqlite.connections destructors io.directories io.files
+io.files.temp kernel math namespaces tools.test
+db2.sqlite.connections ;
+IN: db2.pools.tests
+
+\ <db-pool> must-infer
+
+{ 1 0 } [ [ ] with-db-pool ] must-infer-as
+
+{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
+
+! Test behavior after image save/load
+
+[ "pool-test.db" temp-file delete-file ] ignore-errors
+
+[ ] [ "pool-test.db" temp-file <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 db2.connections fry io.pools kernel
+namespaces ;
+IN: db2.pools
+
+TUPLE: db-pool < pool db ;
+
+: <db-pool> ( db -- pool )
+ db-pool <pool>
+ swap >>db ;
+
+: with-db-pool ( db quot -- )
+ [ <db-pool> ] dip with-pool ; inline
+
+M: db-pool make-connection ( pool -- )
+ db>> db-open ;
+
+: with-pooled-db ( pool quot -- )
+ '[ db-connection _ with-variable ] with-pooled-connection ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences ;
+IN: db2.result-sets
+
+TUPLE: result-set sql in out handle n max ;
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+GENERIC# column 1 ( result-set column -- obj )
+GENERIC# column-typed 1 ( result-set column -- sql )
+
+: init-result-set ( result-set -- result-set )
+ dup #rows >>max
+ 0 >>n ;
+
+: new-result-set ( query handle class -- result-set )
+ new
+ swap >>handle
+ swap [ sql>> >>sql ] [ in>> >>in ] [ out>> >>out ] tri ;
+
+: sql-row ( result-set -- seq )
+ dup #columns [ column ] with map ;
+
+: sql-row-typed ( result-set -- seq )
+ dup #columns [ column-typed ] with map ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.sqlite.connections ;
+IN: db2.sqlite.connections.tests
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.sqlite
+db2.sqlite.errors db2.sqlite.lib kernel ;
+IN: db2.sqlite.connections
+
+TUPLE: sqlite-db-connection < db-connection ;
+
+: <sqlite-db-connection> ( handle -- db-connection )
+ sqlite-db-connection new-db-connection ;
+
+M: sqlite-db db-open ( db -- db-connection )
+ path>> sqlite-open <sqlite-db-connection> ;
+
+M: sqlite-db-connection db-close ( db-connection -- )
+ handle>> sqlite-close ;
+
+M: sqlite-db-connection parse-db-error ( error -- error' )
+ dup n>> {
+ { 1 [ string>> parse-sqlite-sql-error ] }
+ [ drop ]
+ } case ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ;
+IN: db2.sqlite.db
+
+TUPLE: sqlite-db path ;
+
+: <sqlite-db> ( path -- sqlite-db )
+ sqlite-db new
+ swap >>path ;
+
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.errors
+db2.sqlite.ffi kernel locals namespaces peg.ebnf sequences
+strings ;
+IN: db2.sqlite.errors
+
+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-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
+
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
+
+: sqlite-table-error ( table message -- error )
+ {
+ { sql-table-exists [ <sql-table-exists> ] }
+ } case ;
+
+EBNF: parse-sqlite-sql-error
+
+TableMessage = " already exists" => [[ sql-table-exists ]]
+
+SqliteError =
+ "table " (!(TableMessage).)+:table TableMessage:message
+ => [[ table >string message sqlite-table-error ]]
+ | "no such table: " .+:table
+ => [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
+;EBNF
--- /dev/null
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! Not all functions have been wrapped.
+USING: alien alien.libraries alien.syntax combinators system ;
+IN: db2.sqlite.ffi
+
+<< "sqlite" {
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: sqlite
+
+! Return values from sqlite functions
+CONSTANT: SQLITE_OK 0 ! Successful result
+CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
+CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
+CONSTANT: SQLITE_PERM 3 ! Access permission denied
+CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
+CONSTANT: SQLITE_BUSY 5 ! The database file is locked
+CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
+CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
+CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
+CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
+CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
+CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
+CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
+CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
+CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
+CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
+CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
+CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
+CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
+CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
+CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
+CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
+CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
+CONSTANT: SQLITE_AUTH 23 ! Authorization denied
+CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
+CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
+CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
+
+CONSTANT: sqlite-error-messages
+{
+ "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
+CONSTANT: SQLITE_ROW 100
+CONSTANT: SQLITE_DONE 101
+
+! Return values from the sqlite3_column_type function
+CONSTANT: SQLITE_INTEGER 1
+CONSTANT: SQLITE_FLOAT 2
+CONSTANT: SQLITE_TEXT 3
+CONSTANT: SQLITE_BLOB 4
+CONSTANT: SQLITE_NULL 5
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+CONSTANT: SQLITE_STATIC 0
+CONSTANT: SQLITE_TRANSIENT -1
+
+CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
+CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
+CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
+CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
+CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
+CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
+CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
+
+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 ) ;
+! Bind the same function as above, but for unsigned 64bit integers
+: 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 ) ;
+! Bind the same function as above, but for unsigned 64bit integers
+: 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: accessors alien.c-types arrays calendar.format
+combinators db2.connections db2.sqlite.ffi db2.errors
+io.backend io.encodings.string io.encodings.utf8 kernel math
+namespaces present sequences serialize urls db2.sqlite.errors ;
+IN: db2.sqlite.lib
+
+: ?when ( object quot -- object' ) dupd when ; inline
+
+
+: 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 )
+ [ dupd sqlite-bind-parameter-index ] dip ;
+
+: 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-boolean-by-name ( handle name obj -- )
+ >boolean 1 0 ? parameter-index sqlite-bind-int ;
+
+: 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-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-step-has-more-rows? ( prepared -- ? )
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
+
+: sqlite-next ( prepared -- ? )
+ sqlite3_step sqlite-step-has-more-rows? ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.result-sets ;
+IN: db2.sqlite.result-sets
+
+TUPLE: sqlite-result-set < result-set has-more? ;
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors db2.connections ;
+IN: db2.sqlite
+
+TUPLE: sqlite-db path ;
+CONSTRUCTOR: sqlite-db ( path -- sqlite-db ) ;
+
+TUPLE: sqlite-db-connection < db-connection ;
+
+: <sqlite-db-connection> ( handle -- db-connection )
+ sqlite-db-connection new-db-connection ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.connections db2.statements db2.sqlite.connections
+db2.sqlite.lib ;
+IN: db2.sqlite.statements
+
+TUPLE: sqlite-statement < statement ;
+
+M: sqlite-db-connection <statement> ( string in out -- obj )
+ sqlite-statement new-statement ;
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays calendar.format combinators db2.types
+db2.sqlite.ffi db2.sqlite.lib
+kernel present sequences serialize urls ;
+IN: db2.sqlite.types
+
+: (bind-sqlite-type) ( handle key value type -- )
+ 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 ] }
+ { BOOLEAN [ sqlite-bind-boolean-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 ;
+
+: bind-sqlite-type ( handle key value type -- )
+ #! null and empty values need to be set by sqlite-bind-null-by-name
+ over [
+ NULL = [ 2drop NULL NULL ] when
+ ] [
+ drop NULL
+ ] if* (bind-sqlite-type) ;
+
+: sqlite-type ( 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 ] }
+ { BOOLEAN [ sqlite3_column_int 1 = ] }
+ { DOUBLE [ sqlite3_column_double ] }
+ { TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
+ { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] }
+ { TIME [ sqlite3_column_text [ hms>timestamp ] ?when ] }
+ { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { URL [ sqlite3_column_text [ >url ] ?when ] }
+ { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] }
+ [ no-sql-type ]
+ } case ;
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.statements kernel ;
+IN: db2.statements.tests
+
+{ 1 0 } [ [ drop ] statement-each ] must-infer-as
+{ 1 1 } [ [ ] statement-map ] must-infer-as
+
+[ ]
+[
+ "insert into computer (name, os) values('rocky', 'mac');"
+
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations destructors fry kernel
+sequences db2.result-sets db2.connections ;
+IN: db2.statements
+
+TUPLE: statement handle sql in out ;
+
+: new-statement ( sql in out class -- statement )
+ new
+ swap >>out
+ swap >>in
+ swap >>sql ;
+
+HOOK: <statement> db-connection ( sql in out -- statement )
+GENERIC: execute-statement* ( statement type -- )
+GENERIC: statement>result-set ( statement -- result-set )
+
+M: object execute-statement* ( statement type -- )
+ drop '[ _ statement>result-set dispose ]
+ [ parse-db-error rethrow ] recover ;
+
+: execute-one-statement ( statement -- )
+ dup type>> execute-statement* ;
+
+: execute-statement ( statement -- )
+ dup sequence?
+ [ [ execute-one-statement ] each ]
+ [ execute-one-statement ] if ;
+
+: statement-each ( statement quot: ( statement -- ) -- )
+ over more-rows?
+ [ [ call ] 2keep over advance-row statement-each ]
+ [ 2drop ] if ; inline recursive
+
+: statement-map ( statement quot -- sequence )
+ accumulator [ statement-each ] dip { } like ; inline
+
+: statement>result-sequence ( statement -- sequence )
+ statement>result-set [ [ sql-row ] statement-map ] with-disposal ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.tester ;
+IN: db2.tester.tests
+
+! [ ] [ sqlite-test-db db-tester ] unit-test
+! [ ] [ sqlite-test-db db-tester2 ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db2.connections
+db2.pools db2.sqlite db2.types fry io.files.temp kernel math
+namespaces random threads tools.test combinators ;
+IN: db2.tester
+USE: multiline
+
+: sqlite-test-db ( -- sqlite-db )
+ "tuples-test.db" temp-file <sqlite-db> ;
+
+! These words leak resources, but are useful for interactivel testing
+: set-sqlite-db ( -- )
+ sqlite-db db-open db-connection set ;
+
+: test-sqlite ( quot -- )
+ '[
+ [ ] [ sqlite-test-db _ with-db ] unit-test
+ ] call ; inline
+
+: test-dbs ( quot -- )
+ {
+ [ test-sqlite ]
+ } cleave ;
+
+/*
+: postgresql-test-db ( -- postgresql-db )
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
+
+: set-postgresql-db ( -- )
+ postgresql-db db-open db-connection set ;
+
+: test-postgresql ( quot -- )
+ '[
+ os windows? cpu x86.64? and [
+ [ ] [ postgresql-test-db _ with-db ] unit-test
+ ] unless
+ ] call ; inline
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: db-tester ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ 10 [
+ drop
+ 10 [
+ dup [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] with-db
+ ] times
+ ] with parallel-each
+ ] bi ;
+
+: db-tester2 ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ <db-pool> [
+ 10 [
+ 10 [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] times
+ ] parallel-each
+ ] with-pooled-db
+ ] bi ;
+*/
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations db2 db2.connections namespaces ;
+IN: db2.transactions
+
+SYMBOL: in-transaction
+
+HOOK: begin-transaction db-connection ( -- )
+
+HOOK: commit-transaction db-connection ( -- )
+
+HOOK: rollback-transaction db-connection ( -- )
+
+M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
+
+M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
+
+M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: db2.types
+
+SINGLETONS: +db-assigned-id+ +user-assigned-id+ +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+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
+
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
+FACTOR-BLOB NULL URL ;
+
+ERROR: no-sql-type type ;
-USING: tools.test sequence-parser ascii kernel accessors ;
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
IN: sequence-parser.tests
[ "hello" ]
[ "123u" ]
[ "123u" <sequence-parser> take-c-integer ] unit-test
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
] [
[ drop n>> ]
[ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
] if ; inline
: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
: skip-whitespace ( sequence-parser -- sequence-parser )
[ [ current blank? not ] take-until drop ] keep ;
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
: take-rest-slice ( sequence-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
sequence-parser [ n + ] change-n drop
] if ;
-: take-c-comment ( sequence-parser -- seq/f )
- [
- dup "/*" take-sequence [
- "*/" take-until-sequence*
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: take-c++-comment ( sequence-parser -- seq/f )
- [
- dup "//" take-sequence [
- [
- [
- { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
- ] take-until
- ] [
- advance drop
- ] bi
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
: c-identifier-begin? ( ch -- ? )
CHAR: a CHAR: z [a,b]
CHAR: A CHAR: Z [a,b]
CHAR: 0 CHAR: 9 [a,b]
{ CHAR: _ } 4 nappend member? ;
-: take-c-identifier ( state-parser -- string/f )
- [
- dup current c-identifier-begin? [
- [ current c-identifier-ch? ] take-while
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
<< "length" [ length ] define-sorting >>
: sort-tokens ( seq -- seq' )
{ length>=< <=> } sort-by ;
-: take-first-matching ( state-parser seq -- seq )
+: take-first-matching ( sequence-parser seq -- seq )
swap
'[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-: take-longest ( state-parser seq -- seq )
+: take-longest ( sequence-parser seq -- seq )
sort-tokens take-first-matching ;
-: take-c-integer ( state-parser -- string/f )
+: take-c-integer ( sequence-parser -- string/f )
[
dup take-integer [
swap
] if*
] with-sequence-parser ;
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
+
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
projects / factor.git / commitdiff