websites.concatenative: Add a way to test postgresql.

sqlite: add dummy database

basis/db/db-docs.factor

@@ -1,314 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math quotations db.private ;
-IN: db
-
-HELP: db-connection
-{ $description "The " { $snippet "db-connection" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries. Stores the current database object as a dynamic variable." } ;
-
-HELP: new-db-connection
-{ $values { "class" class } { "obj" db-connection } }
-{ $description "Creates a new database object from a given class with caches for prepared statements. Does not actually connect to the database until " { $link db-open } " or " { $link with-db } " is called." }
-{ $notes "User-defined databases must call this constructor word instead of " { $link new } "." } ;
-
-HELP: db-open
-{ $values { "db" "a database configuration object" } { "db-connection" db-connection } }
-{ $description "Opens a database using the configuration data stored in a " { $snippet "database configuration object" } "tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
-
-HELP: db-close
-{ $values { "handle" alien } }
-{ $description "Closes a database using the handle provided. Use of the " { $link with-db } " combinator is preferred over manually opening and closing databases so that resources are not leaked." } ;
-
-{ db-open db-close with-db } related-words
-
-HELP: dispose-statements
-{ $values { "assoc" assoc } }
-{ $description "Disposes an associative list of statements." } ;
-
-HELP: statement
-{ $description "A " { $snippet "statement" } " stores the information about a statement, such as the SQL statement text, the in/out parameters, and type information." } ;
-
-HELP: result-set
-{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
-{ $subsections
-    "db-random-access-result-set"
-    "db-sequential-result-set"
-}
-} ;
-
-HELP: new-result-set
-{ $values
-     { "query" "a query" } { "handle" alien } { "class" class }
-     { "result-set" result-set } }
-{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
-
-HELP: new-statement
-{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
-{ $description "Makes a new statement object from the given parameters." } ;
-
-HELP: bind-statement
-{ $values
-     { "obj" object } { "statement" statement } }
-{ $description "Sets the statement's " { $slot "bind-params" } " and calls " { $link bind-statement* } " to do the database-specific bind. Sets " { $slot "bound?" } " to true if binding succeeds." } ;
-
-HELP: bind-statement*
-{ $values
-     { "statement" statement } }
-{ $description "Does a low-level bind of the SQL statement's tuple parameters if the database requires. Some databases should treat this as a no-op and bind instead when the actual statement is run." } ;
-
-HELP: <simple-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence }
-    { "statement" statement } }
-{ $description "Makes a new simple statement object from the given parameters.." }
-{ $warning "Using a simple statement can lead to SQL injection attacks in PostgreSQL. The Factor database implementation for SQLite only uses " { $link <prepared-statement> } " as the sole kind of statement; simple statements alias to prepared ones." } ;
-
-HELP: <prepared-statement>
-{ $values { "string" string } { "in" sequence } { "out" sequence }
-    { "statement" statement } }
-{ $description "Makes a new prepared statement object from the given parameters. A prepared statement's parameters will be escaped by the database backend to avoid SQL injection attacks. Prepared statements should be preferred over simple statements." } ;
-
-HELP: prepare-statement
-{ $values { "statement" statement } }
-{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ;
-
-HELP: low-level-bind
-{ $values
-     { "statement" statement } }
-{ $description "For use with prepared statements, methods on this word should bind the datatype in the SQL spec to its identifier in the SQL string. To name bound variables, SQLite uses identifiers in the form of " { $snippet ":name" } ", while PostgreSQL uses increasing numbers beginning with a dollar sign, e.g. " { $snippet "$1" } "." } ;
-
-HELP: query-results
-{ $values { "query" object }
-    { "result-set" result-set }
-}
-{ $description "Returns a " { $link result-set } " object representing the results of a SQL query. See " { $link "db-result-sets" } "." } ;
-
-HELP: #rows
-{ $values { "result-set" result-set } { "n" integer } }
-{ $description "Returns the number of rows in a result set." } ;
-
-HELP: #columns
-{ $values { "result-set" result-set } { "n" integer } }
-{ $description "Returns the number of columns in a result set." } ;
-
-HELP: row-column
-{ $values { "result-set" result-set } { "column" integer }
-    { "obj" object }
-}
-{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
-
-HELP: row-column-typed
-{ $values { "result-set" result-set } { "column" integer }
-    { "sql" "sql" } }
-{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ;
-
-HELP: advance-row
-{ $values { "result-set" result-set } }
-{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ;
-
-HELP: more-rows?
-{ $values { "result-set" result-set } { "?" boolean } }
-{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
-
-
-
-HELP: begin-transaction
-{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-
-HELP: commit-transaction
-{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-
-HELP: in-transaction
-{ $description "A variable that is set true when a transaction is in progress." } ;
-
-HELP: in-transaction?
-{ $values
-     { "?" boolean } }
-{ $description "Returns true if there is currently a transaction in progress in this scope." } ;
-
-HELP: query-each
-{ $values
-     { "statement" statement } { "quot" quotation } }
-{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
-
-HELP: query-map
-{ $values
-     { "statement" statement } { "quot" quotation }
-     { "seq" sequence } }
-{ $description "A combinator that maps a sequence of SQL statements to their results query results." } ;
-
-HELP: rollback-transaction
-{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
-
-HELP: sql-command
-{ $values
-     { "sql" string } }
-{ $description "Executes a SQL string using the database in the " { $link db-connection } " symbol." } ;
-
-HELP: sql-query
-{ $values
-     { "sql" string }
-     { "rows" "an array of arrays of strings" } }
-{ $description "Runs a SQL query of raw text in the database in the " { $link db-connection } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
-
-{ sql-command sql-query } related-words
-
-HELP: sql-row
-{ $values
-     { "result-set" result-set }
-     { "seq" sequence } }
-{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ;
-
-HELP: sql-row-typed
-{ $values
-     { "result-set" result-set }
-     { "seq" sequence } }
-{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ;
-
-{ sql-row sql-row-typed } related-words
-
-HELP: with-db
-{ $values
-     { "db" "a database configuration object" } { "quot" quotation } }
-{ $description "Calls the quotation with a database bound to the " { $link db-connection } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
-
-HELP: with-transaction
-{ $values
-     { "quot" quotation } }
-{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
-
-ARTICLE: "db" "Database library"
-"Accessing a database:"
-{ $subsections "db-custom-database-combinators" }
-"Higher-level database help:"
-{ $vocab-subsection "Database types" "db.types" }
-{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
-"Low-level database help:"
-{ $subsections
-    "db-protocol"
-    "db-result-sets"
-    "db-lowlevel-tutorial"
-}
-"Supported database backends:"
-{ $vocab-subsection "SQLite" "db.sqlite" }
-{ $vocab-subsection "PostgreSQL" "db.postgresql" } ;
-
-ARTICLE: "db-random-access-result-set" "Random access result sets"
-"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
-$nl
-"Databases which work in this way must provide methods for the following traversal words:"
-{ $subsections
-    #rows
-    #columns
-    row-column
-    row-column-typed
-} ;
-
-ARTICLE: "db-sequential-result-set" "Sequential result sets"
-"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
-$nl
-"Databases which work in this way must provide methods for the following traversal words:"
-{ $subsections
-    more-rows?
-    advance-row
-    row-column
-    row-column-typed
-} ;
-
-ARTICLE: "db-result-sets" "Result sets"
-"Result sets are the encapsulated, database-specific results from a SQL query."
-$nl
-"Two possible protocols for iterating over result sets exist:"
-{ $subsections
-    "db-random-access-result-set"
-    "db-sequential-result-set"
-}
-"Query the number of rows or columns:"
-{ $subsections
-    #rows
-    #columns
-}
-"Traversing a result set:"
-{ $subsections
-    advance-row
-    more-rows?
-}
-"Pulling out a single row of results:"
-{ $subsections
-    row-column
-    row-column-typed
-} ;
-
-ARTICLE: "db-protocol" "Low-level database protocol"
-"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." $nl
-"Opening a database:"
-{ $subsections db-open }
-"Closing a database:"
-{ $subsections db-close }
-"Creating statements:"
-{ $subsections
-    <simple-statement>
-    <prepared-statement>
-}
-"Using statements with the database:"
-{ $subsections
-    prepare-statement
-    bind-statement*
-    low-level-bind
-}
-"Performing a query:"
-{ $subsections query-results }
-"Handling query results:"
-{ $subsections "db-result-sets" }
-;
-! { $subsection bind-tuple }
-
-ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
-"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
-"Executing a SQL command:"
-{ $subsections sql-command }
-"Executing a query directly:"
-{ $subsections sql-query }
-"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
-"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code "USING: db.sqlite db io.files io.files.temp ;
-: with-book-db ( quot -- )
-    \"book.db\" temp-file <sqlite-db> swap with-db ; inline" }
-"Now let's create the table manually:"
-{ $code "\"create table books
-    (id integer primary key, title text, author text, date_published timestamp,
-     edition integer, cover_price double, condition text)\"
-    [ sql-command ] with-book-db" }
-"Time to insert some books:"
-{ $code "\"insert into books
-    (title, author, date_published, edition, cover_price, condition)
-    values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')\"
-[ sql-command ] with-book-db" }
-"Now let's select the book:"
-{ $code "\"select id, title, cover_price from books;\" [ sql-query ] with-book-db" }
-"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
-"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
-
-ARTICLE: "db-custom-database-combinators" "Custom database combinators"
-"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specific port." $nl
-
-"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
-
-"SQLite example combinator:"
-{ $code "USING: db.sqlite db io.files io.files.temp ;
-: with-sqlite-db ( quot -- )
-    \"my-database.db\" temp-file <sqlite-db> swap with-db ; inline" }
-
-"PostgreSQL example combinator:"
-{ $code "USING: db.postgresql db ;
-: with-postgresql-db ( quot -- )
-    <postgresql-db>
-        \"localhost\" >>host
-        5432 >>port
-        \"erg\" >>username
-        \"secrets?\" >>password
-        \"factor-test\" >>database
-    swap with-db ; inline"
-} ;
-
-ABOUT: "db"

basis/db/db-tests.factor

@@ -1,6 +0,0 @@
-USING: tools.test db kernel ;
-IN: db.tests
-
-{ 1 0 } [ [ drop ] query-each ] must-infer-as
-{ 1 1 } [ [ ] query-map ] must-infer-as
-{ 1 0 } [ [ ] with-db ] must-infer-as

basis/db/db.factor

@@ -1,156 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes continuations destructors kernel math
-namespaces sequences classes.tuple words strings
-tools.walker accessors combinators fry db.errors ;
-IN: db
-
-TUPLE: db-connection
-    handle
-    insert-statements
-    update-statements
-    delete-statements ;
-
-<PRIVATE
-
-: new-db-connection ( class -- obj )
-    new
-        H{ } clone >>insert-statements
-        H{ } clone >>update-statements
-        H{ } clone >>delete-statements ; inline
-
-PRIVATE>
-
-GENERIC: db-open ( db -- db-connection )
-HOOK: db-close db-connection ( handle -- )
-HOOK: parse-db-error db-connection ( error -- error' )
-
-: dispose-statements ( assoc -- ) values dispose-each ;
-
-M: db-connection dispose ( db-connection -- )
-    dup db-connection [
-        [ dispose-statements H{ } clone ] change-insert-statements
-        [ dispose-statements H{ } clone ] change-update-statements
-        [ dispose-statements H{ } clone ] change-delete-statements
-        [ db-close f ] change-handle
-        drop
-    ] with-variable ;
-
-TUPLE: result-set sql in-params out-params handle n max ;
-
-GENERIC: query-results ( query -- result-set )
-GENERIC: #rows ( result-set -- n )
-GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set column -- obj )
-GENERIC# row-column-typed 1 ( result-set column -- sql )
-GENERIC: advance-row ( result-set -- )
-GENERIC: more-rows? ( result-set -- ? )
-
-: init-result-set ( result-set -- )
-    dup #rows >>max
-    0 >>n drop ;
-
-: new-result-set ( query handle class -- result-set )
-    new
-        swap >>handle
-        [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
-        swap >>out-params
-        swap >>in-params
-        swap >>sql ;
-
-TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
-TUPLE: simple-statement < statement ;
-TUPLE: prepared-statement < statement ;
-
-: new-statement ( sql in out class -- statement )
-    new
-        swap >>out-params
-        swap >>in-params
-        swap >>sql ;
-
-HOOK: <simple-statement> db-connection ( string in out -- statement )
-HOOK: <prepared-statement> db-connection ( string in out -- statement )
-GENERIC: prepare-statement ( statement -- )
-GENERIC: bind-statement* ( statement -- )
-GENERIC: low-level-bind ( statement -- )
-GENERIC: bind-tuple ( tuple statement -- )
-
-GENERIC: execute-statement* ( statement type -- )
-
-M: object execute-statement* ( statement type -- )
-    '[
-        _ _ drop query-results 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 ;
-
-: bind-statement ( obj statement -- )
-    swap >>bind-params
-    [ bind-statement* ] keep
-    t >>bound? drop ;
-
-: sql-row ( result-set -- seq )
-    dup #columns [ row-column ] with { } map-integers ;
-
-: sql-row-typed ( result-set -- seq )
-    dup #columns [ row-column-typed ] with { } map-integers ;
-
-: query-each ( statement quot: ( statement -- ) -- )
-    over more-rows? [
-        [ call ] 2keep over advance-row query-each
-    ] [
-        2drop
-    ] if ; inline recursive
-
-: query-map ( statement quot -- seq )
-    collector [ query-each ] dip { } like ; inline
-
-: with-db ( db quot -- )
-    [ db-open db-connection ] dip
-    '[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
-
-! Words for working with raw SQL statements
-: default-query ( query -- result-set )
-    query-results [ [ sql-row ] query-map ] with-disposal ;
-
-: sql-query ( sql -- rows )
-    f f <simple-statement> [ default-query ] with-disposal ;
-
-: (sql-command) ( string -- )
-    f f <simple-statement> [ execute-statement ] with-disposal ;
-
-: sql-command ( sql -- )
-    dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
-
-! 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 -- )
-    in-transaction? [
-        call
-    ] [
-        t in-transaction [
-            begin-transaction
-            [ ] [ rollback-transaction ] cleanup commit-transaction
-        ] with-variable
-    ] if ; inline

basis/db/errors/errors.factor

@@ -1,62 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel continuations fry words ;
-IN: db.errors
-
-ERROR: db-error ;
-TUPLE: sql-error location ;
-
-ERROR: bad-schema ;
-
-TUPLE: sql-unknown-error < sql-error message ;
-: <sql-unknown-error> ( message -- error )
-    \ sql-unknown-error new
-        swap >>message ;
-
-TUPLE: sql-table-exists < sql-error table ;
-: <sql-table-exists> ( table -- error )
-    \ sql-table-exists new
-        swap >>table ;
-
-TUPLE: sql-table-missing < sql-error table ;
-: <sql-table-missing> ( table -- error )
-    \ sql-table-missing new
-        swap >>table ;
-
-TUPLE: sql-syntax-error < sql-error message ;
-: <sql-syntax-error> ( message -- error )
-    \ sql-syntax-error new
-        swap >>message ;
-
-TUPLE: sql-function-exists < sql-error message ;
-: <sql-function-exists> ( message -- error )
-    \ sql-function-exists new
-        swap >>message ;
-
-TUPLE: sql-function-missing < sql-error message ;
-: <sql-function-missing> ( message -- error )
-    \ sql-function-missing new
-        swap >>message ;
-
-TUPLE: sql-database-exists < sql-error message ;
-: <sql-database-exists> ( message -- error )
-    \ sql-database-exists new
-        swap >>message ;
-
-: 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
-
-: ignore-database-exists ( quot -- )
-    \ sql-database-exists? ignore-error ; inline

basis/db/errors/postgresql/postgresql-tests.factor

@@ -1,32 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit db db.errors
-db.errors.postgresql db.postgresql io.files.unique kernel namespaces
-tools.test db.tester continuations ;
-IN: db.errors.postgresql.tests
-
-[
-
-    [ "drop table foo;" sql-command ] ignore-errors
-    [ "drop table ship;" sql-command ] ignore-errors
-
-    [
-        "insert into foo (id) values('1');" sql-command
-    ] [
-        { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
-    ] must-fail-with
-
-    [
-        "create table ship(id integer);" sql-command
-        "create table ship(id integer);" sql-command
-    ] [
-        { [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
-    ] must-fail-with
-
-    [
-        "create table foo(id) lol;" sql-command
-    ] [
-        sql-syntax-error?
-    ] must-fail-with
-
-] test-postgresql

basis/db/errors/sqlite/sqlite-tests.factor

@@ -1,26 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit db db.errors
-db.errors.sqlite db.sqlite io.files.unique kernel namespaces
-tools.test ;
-IN: db.errors.sqlite.tests
-
-: sqlite-error-test-db-path ( -- path )
-    "sqlite" "error-test" make-unique-file ;
-
-sqlite-error-test-db-path <sqlite-db> [
-
-    [
-        "insert into foo (id) values('1');" sql-command
-    ] [
-        { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
-    ] must-fail-with
-
-    [
-        "create table foo(id);" sql-command
-        "create table foo(id);" sql-command
-    ] [
-        { [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
-    ] must-fail-with
-
-] with-db

basis/db/errors/sqlite/sqlite.factor

@@ -1,28 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators db kernel sequences peg.ebnf
-strings db.errors ;
-IN: db.errors.sqlite
-
-TUPLE: unparsed-sqlite-error error ;
-C: <unparsed-sqlite-error> unparsed-sqlite-error
-
-SINGLETONS: table-exists table-missing ;
-
-: sqlite-table-error ( table message -- error )
-    {
-        { table-exists [ <sql-table-exists> ] }
-    } case ;
-
-EBNF: parse-sqlite-sql-error
-
-TableMessage = " already exists" => [[ 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

basis/db/errors/summary.txt

@@ -1 +0,0 @@
-Errors thrown by database library

basis/db/pools/pools-tests.factor

@@ -1,20 +0,0 @@
-IN: db.pools.tests
-USING: db.pools tools.test continuations io.files io.files.temp
-io.directories namespaces accessors kernel math destructors ;
-
-{ 1 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" 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

basis/db/pools/summary.txt

@@ -1 +0,0 @@
-Database connection pooling

basis/db/postgresql/lib/lib.factor

@@ -1,176 +0,0 @@
-! 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
-alien.data db.types tools.walker ascii splitting math.parser
-combinators libc calendar.format byte-arrays destructors
-prettyprint accessors strings serialize io.encodings.binary
-io.encodings.utf8 alien.strings io.streams.byte-array summary
-present urls specialized-arrays db.private ;
-SPECIALIZED-ARRAY: uint
-SPECIALIZED-ARRAY: void*
-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-connection 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) ] [ PQfinish ] bi throw
-    ] unless ;
-
-: do-postgresql-statement ( statement -- res )
-    db-connection 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 ] uint-array{ } map-as ;
-
-: 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
-    [
-        [ value>> ] [ type>> ] bi* {
-            { 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 [
-        f f
-    ] [
-        first2 [ void* >c-array ] [ uint >c-array ] bi*
-    ] if-empty ;
-
-: param-formats ( statement -- seq )
-    in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
-
-: do-postgresql-bound-statement ( statement -- res )
-    [
-        [ db-connection get handle>> ] dip
-        {
-            [ 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? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] 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 > [
-        [ 3drop ] dip
-        [
-            memory>byte-array >string
-            { uint }
-            [
-                PQunescapeBytea dup zero? [
-                    postgresql-result-error-message throw
-                ] [
-                    &postgresql-free
-                ] if
-            ] with-out-parameters 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 ;

basis/db/postgresql/postgresql-tests.factor

@@ -1,110 +0,0 @@
-USING: accessors alien continuations db db.errors db.queries db.postgresql
-db.private db.tester db.tuples db.types io classes kernel math namespaces
-prettyprint sequences system tools.test unicode.case ;
-IN: db.postgresql.tests
-
-: nonexistant-db ( -- db )
-    <postgresql-db>
-        "localhost" >>host
-        "fake-user" >>username
-        "no-pass" >>password
-        "dont-exist" >>database ;
-
-! Don't leak connections
-{ } [
-    2000 [ [ nonexistant-db [ ] with-db ] ignore-errors ] times
-] unit-test
-
-! Ensure the test database exists
-postgresql-template1-db [
-    postgresql-test-db-name ensure-database
-] with-db
-
-! Triggers a two line error message (ERROR + DETAIL) because two
-! connections can't simultaneously use the template1 database.
-! [
-    ! postgresql-template1-db [
-        ! postgresql-template1-db [
-            ! "will_never_exist" ensure-database
-        ! ] with-db
-    ! ] with-db
-! ] [ sql-unknown-error? ] must-fail-with
-
-{ } [
-    postgresql-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" }
-    }
-} [
-    postgresql-test-db [
-        "select * from person" sql-query
-    ] with-db
-] unit-test
-
-{
-    {
-        { "John" "America" }
-        { "Jane" "New Zealand" }
-    }
-} [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
-
-{
-} [
-    postgresql-test-db [
-        "insert into person(name, country) values('Jimmy', 'Canada')"
-        sql-command
-    ] with-db
-] unit-test
-
-{
-    {
-        { "John" "America" }
-        { "Jane" "New Zealand" }
-        { "Jimmy" "Canada" }
-    }
-} [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
-
-[
-    postgresql-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 } [
-    postgresql-test-db [
-        "select * from person" sql-query length
-    ] with-db
-] unit-test
-
-{
-} [
-    postgresql-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 } [
-    postgresql-test-db [
-        "select * from person" sql-query length
-    ] with-db
-] unit-test

basis/db/postgresql/postgresql.factor

@@ -1,293 +0,0 @@
-! 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 make prettyprint quotations
-sequences debugger db db.postgresql.lib db.postgresql.ffi
-db.tuples db.types tools.annotations math.ranges
-combinators classes classes.tuple locals words tools.walker
-db.private nmake accessors random db.queries destructors
-db.tuples.private db.postgresql db.errors.postgresql splitting ;
-IN: db.postgresql
-
-TUPLE: postgresql-db host port pgopts pgtty database username password ;
-
-: <postgresql-db> ( -- postgresql-db )
-    postgresql-db new ;
-
-<PRIVATE
-
-TUPLE: postgresql-db-connection < db-connection ;
-: <postgresql-db-connection> ( handle -- db-connection )
-    postgresql-db-connection new-db-connection
-        swap >>handle ;
-
-PRIVATE>
-
-TUPLE: postgresql-statement < statement ;
-
-TUPLE: postgresql-result-set < result-set ;
-
-M: postgresql-db db-open ( db -- db-connection )
-    {
-        [ host>> ]
-        [ port>> ]
-        [ pgopts>> ]
-        [ pgtty>> ]
-        [ database>> ]
-        [ username>> ]
-        [ password>> ]
-    } cleave connect-postgres <postgresql-db-connection> ;
-
-M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
-
-M: postgresql-statement bind-statement* ( statement -- ) drop ;
-
-GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
-
-M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
-    slot-name>> swap get-slot-named <low-level-binding> ;
-
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
-    nip value>> <low-level-binding> ;
-
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
-    dup generator-singleton>> eval-generator
-    [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
-
-M: postgresql-statement bind-tuple ( tuple statement -- )
-    [ nip ] [
-        in-params>>
-        [ postgresql-bind-conversion ] with map
-    ] 2bi
-    >>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 -- object )
-    [ result-handle-n ] dip pq-get-string ;
-
-M: postgresql-result-set row-column-typed ( result-set column -- object )
-    dup pick out-params>> nth type>>
-    [ result-handle-n ] 2dip 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 new-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
-    [ db-connection get handle>> f ] dip
-    [ sql>> ] [ in-params>> ] bi
-    length f PQprepare postgresql-error
-    >>handle drop ;
-
-M: postgresql-db-connection <simple-statement> ( sql in out -- statement )
-    postgresql-statement new-statement ;
-
-M: postgresql-db-connection <prepared-statement> ( sql in out -- statement )
-    <simple-statement> dup prepare-statement ;
-
-: bind-name% ( -- )
-    CHAR: $ 0,
-    sql-counter [ inc ] [ get 0# ] bi ;
-
-M: postgresql-db-connection bind% ( spec -- )
-    bind-name% 1, ;
-
-M: postgresql-db-connection bind# ( spec object -- )
-    [ bind-name% f swap type>> ] dip
-    <literal-bind> 1, ;
-
-: create-table-sql ( class -- statement )
-    [
-        dupd
-        "create table " 0% 0%
-        "(" 0% [ ", " 0% ] [
-            dup column-name>> 0%
-            " " 0%
-            dup type>> lookup-create-type 0%
-            modifiers 0%
-        ] interleave
-
-        ", " 0%
-        find-primary-key
-        "primary key(" 0%
-        [ "," 0% ] [ column-name>> 0% ] interleave
-        "));" 0%
-    ] query-make ;
-
-: create-function-sql ( class -- statement )
-    [
-        [ dup remove-id ] dip
-        "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% "_" 0%
-        find-primary-key first column-name>> 0%
-        "_seq'');' language sql;" 0%
-    ] query-make ;
-
-M: postgresql-db-connection create-sql-statement ( class -- seq )
-    [
-        [ create-table-sql , ] keep
-        dup db-assigned? [ 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-connection drop-sql-statement ( class -- seq )
-    [
-        [ drop-table-sql , ] keep
-        dup db-assigned? [ drop-function-sql , ] [ drop ] if
-    ] { } make ;
-
-M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement )
-    [
-        "select add_" 0% 0%
-        "(" 0%
-        dup find-primary-key first 2,
-        remove-id
-        [ ", " 0% ] [ bind% ] interleave
-        ");" 0%
-    ] query-make ;
-
-M: postgresql-db-connection <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-connection insert-tuple-set-key ( tuple statement -- )
-    query-modify-tuple ;
-
-M: postgresql-db-connection persistent-table ( -- hashtable )
-    H{
-        { +db-assigned-id+ { "integer" "serial" f } }
-        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "bigint" "bigint" f } }
-
-        { +foreign-id+ { f f "references" } }
-
-        { +on-update+ { f f "on update" } }
-        { +on-delete+ { f f "on delete" } }
-        { +restrict+ { f f "restrict" } }
-        { +cascade+ { f f "cascade" } }
-        { +set-null+ { f f "set null" } }
-        { +set-default+ { f f "set default" } }
-
-        { 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 } }
-        { +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 } }
-    } ;
-
-ERROR: no-compound-found string object ;
-M: postgresql-db-connection compound ( string object -- string' )
-    over {
-        { "default" [ first number>string " " glue ] }
-        { "varchar" [ first number>string "(" ")" surround append ] }
-        { "references" [ >reference-string ] }
-        [ drop no-compound-found ]
-    } case ;
-
-M: postgresql-db-connection parse-db-error
-    "\n" split dup length {
-        { 1 [ first parse-postgresql-sql-error ] }
-        { 2 [ concat parse-postgresql-sql-error ] }
-        { 3 [
-                first3
-                [ parse-postgresql-sql-error ] 2dip
-                postgresql-location >>location
-        ] }
-    } case ;

basis/db/postgresql/summary.txt

@@ -1 +0,0 @@
-PostgreSQL database connector

basis/db/queries/queries.factor

@@ -1,216 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays classes classes.tuple
-combinators continuations db db.errors db.private db.tuples
-db.tuples.private db.types destructors kernel make math
-math.bitwise math.intervals math.parser namespaces nmake
-prettyprint random sequences shuffle strings words fry ;
-IN: db.queries
-
-GENERIC: where ( specs obj -- )
-
-SINGLETON: retryable
-: make-retryable ( obj -- obj' )
-    dup sequence? [
-        [ make-retryable ] map
-    ] [
-        retryable >>type
-        10 >>retries
-    ] if ;
-
-: maybe-make-retryable ( statement -- statement )
-    dup in-params>> [ generator-bind? ] any?
-    [ make-retryable ] when ;
-
-: 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 [ retries>> iota ] [
-        [
-            nip
-            [ query-results dispose t ]
-            [ ]
-            [ regenerate-params bind-statement* f ] cleanup
-        ] curry
-    ] bi attempt-all drop ;
-
-: sql-props ( class -- columns table )
-    [ db-columns ] [ db-table-name ] bi ;
-
-: query-make ( class quot -- statements )
-    ! query, input, outputs, secondary queries
-    over db-table-name "table-name" set
-    [ sql-props ] dip
-    [ 0 sql-counter rot with-variable ] curry
-    { "" { } { } { } } nmake
-    [ <simple-statement> maybe-make-retryable ] dip
-    [ [ 1array ] dip append ] unless-empty ; inline
-
-: where-primary-key% ( specs -- )
-    " where " 0%
-    find-primary-key [
-        " and " 0%
-    ] [
-        dup column-name>> 0% " = " 0% bind%
-    ] interleave ;
-
-M: db-connection <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 [ random-bits ] keep 1 - set-bit
-    ] with-random ;
-
-: interval-comparison ( ? str -- str )
-    "from" = " >" " <" ? swap [ "= " append ] when ;
-
-: (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%
-        [ first2 ] dip 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 ;
-
-M: byte-array where ( spec obj -- )
-    over column-name>> 0% " = " 0% bind# ;
-
-M: NULL where ( spec obj -- )
-    drop column-name>> 0% " is NULL" 0% ;
-
-: 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 ;
-
-: many-where ( tuple seq -- )
-    " where " 0% [
-        " and " 0%
-    ] [
-        2dup slot-name>> swap get-slot-named where
-    ] interleave drop ;
-
-: where-clause ( tuple specs -- )
-    dupd filter-slots [ drop ] [ many-where ] if-empty ;
-
-M: db-connection <delete-tuples-statement> ( tuple table -- sql )
-    [
-        "delete from " 0% 0%
-        where-clause
-    ] query-make ;
-
-ERROR: all-slots-ignored class ;
-
-M: db-connection <select-by-slots-statement> ( tuple class -- statement )
-    [
-        "select " 0%
-        [ dupd filter-ignores ] dip
-        over empty? [ all-slots-ignored ] when
-        over
-        [ ", " 0% ]
-        [ dup column-name>> 0% 2, ] interleave
-        " from " 0% 0%
-        where-clause
-    ] query-make ;
-
-: do-group ( tuple groups -- )
-    dup string? [ 1array ] when
-    [ ", " join " group by " glue ] curry change-sql drop ;
-
-: do-order ( tuple order -- )
-    dup string? [ 1array ] when
-    [ ", " join " order by " glue ] curry change-sql drop ;
-
-: do-offset ( tuple n -- )
-    [ number>string " offset " glue ] curry change-sql drop ;
-
-: do-limit ( tuple n -- )
-    [ number>string " limit " glue ] curry change-sql drop ;
-
-: make-query* ( tuple query -- tuple' )
-    dupd
-    {
-        [ group>> [ drop ] [ do-group ] if-empty ]
-        [ order>> [ drop ] [ do-order ] if-empty ]
-        [ limit>> [ do-limit ] [ drop ] if* ]
-        [ offset>> [ do-offset ] [ drop ] if* ]
-    } 2cleave ;
-
-M: db-connection query>statement ( query -- tuple )
-    [ tuple>> dup class-of ] keep
-    [ <select-by-slots-statement> ] dip make-query* ;
-
-! select ID, NAME, SCORE from EXAM limit 1 offset 3
-
-M: db-connection <count-statement> ( query -- statement )
-    [ tuple>> dup class-of ] keep
-    [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
-    dip make-query* ;
-
-: create-index ( index-name table-name columns -- )
-    [
-        [ [ "create index " % % ] dip " on " % % ] dip "(" %
-        "," join % ")" %
-    ] "" make sql-command ;
-
-: drop-index ( index-name -- )
-    [ "drop index " % % ] "" make sql-command ;
-
-: create-database ( string -- )
-    "create database " ";" surround sql-command ;
-
-: ensure-database ( string -- )
-    '[ _ create-database ] ignore-database-exists ;

basis/db/queries/summary.txt

@@ -1 +0,0 @@
-Database queries

basis/db/sqlite/lib/lib.factor

@@ -1,178 +0,0 @@
-! Copyright (C) 2008 Chris Double, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data 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 shuffle io db.private ;
-IN: db.sqlite.lib
-
-ERROR: sqlite-error < db-error n string ;
-ERROR: sqlite-sql-error < sql-error n string ;
-
-: sqlite-other-error ( n -- * )
-    dup sqlite-error-messages nth sqlite-error ;
-
-: sqlite-statement-error ( -- * )
-    SQLITE_ERROR
-    db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
-
-: sqlite-check-result ( n -- )
-    {
-        { SQLITE_OK [ ] }
-        { SQLITE_ERROR [ sqlite-statement-error ] }
-        [ sqlite-other-error ]
-    } case ;
-
-: sqlite-open ( path -- db )
-    normalize-path
-    { void* } [ sqlite3_open sqlite-check-result ]
-    with-out-parameters ;
-
-: sqlite-close ( db -- )
-    sqlite3_close sqlite-check-result ;
-
-: sqlite-prepare ( db sql -- handle )
-    utf8 encode dup length
-    { void* void* }
-    [ sqlite3_prepare_v2 sqlite-check-result ]
-    with-out-parameters drop ;
-
-: 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-bind-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 ;
-
-: sqlite-bind-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* (sqlite-bind-type) ;
-
-: 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 ] }
-        { BOOLEAN [ sqlite3_column_int 1 = ] }
-        { 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 ] }
-        [ no-sql-type ]
-    } case ;
-
-: sqlite-row ( handle -- seq )
-    dup sqlite-#columns [ sqlite-column ] with { } map-integers ;
-
-: 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? ;

basis/db/sqlite/sqlite-tests.factor

@@ -1,174 +0,0 @@
-USING: io io.files io.files.temp io.directories io.launcher
-kernel namespaces prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case accessors arrays
-sorting layouts math.parser ;
-IN: db.sqlite.tests
-
-: db-path ( -- path ) "test-" cell number>string ".db" 3append temp-file ;
-: test.db ( -- sqlite-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
-
-[ \ swap ensure-table ] must-fail
-
-! You don't need a primary key
-TUPLE: things one two ;
-
-things "THINGS" {
-    { "one" "ONE" INTEGER +not-null+ }
-    { "two" "TWO" INTEGER +not-null+ }
-} define-persistent
-
-{ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } } [
-    test.db [
-       things create-table
-        0 0 things boa insert-tuple
-        0 1 things boa insert-tuple
-        1 1 things boa insert-tuple
-        1 0 things boa insert-tuple
-        f f things boa select-tuples
-        [ [ one>> ] [ two>> ] bi 2array ] map natural-sort
-       things drop-table
-    ] with-db
-] unit-test
-
-! Tables can have different names than the name of the tuple
-TUPLE: foo slot ;
-C: <foo> foo
-foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
-
-TUPLE: hi bye try ;
-C: <hi> hi
-hi "HELLO" {
-    { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
-    { "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
-} define-persistent
-
-{ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } } [
-    test.db [
-        foo create-table
-        hi create-table
-        1 <foo> insert-tuple
-        f <foo> select-tuple
-        1 1 <hi> insert-tuple
-        f f <hi> select-tuple
-        hi drop-table
-        foo drop-table
-    ] with-db
-] unit-test
-
-
-! Test SQLite triggers
-
-TUPLE: show id ;
-TUPLE: user username data ;
-TUPLE: watch show user ;
-
-user "USER" {
-    { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
-    { "data" "DATA" TEXT }
-} define-persistent
-
-show "SHOW" {
-    { "id" "ID" +db-assigned-id+ }
-} define-persistent
-
-watch "WATCH" {
-    { "user" "USER" TEXT +not-null+ +user-assigned-id+
-        { +foreign-id+ user "USERNAME" } }
-    { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
-        { +foreign-id+ show "ID" } }
-} define-persistent
-
-{ T{ user { username "littledan" } { data "foo" } } } [
-    test.db [
-        user create-table
-        show create-table
-        watch create-table
-        "littledan" "foo" user boa insert-tuple
-        "mark" "bar" user boa insert-tuple
-        show new insert-tuple
-        show new select-tuple
-        "littledan" f user boa select-tuple
-        [ id>> ] [ username>> ] bi*
-        watch boa insert-tuple
-        watch new select-tuple
-        user>> f user boa select-tuple
-    ] with-db
-] unit-test
-
-{ } [
-    test.db [ [
-            user ensure-table [
-                "mew" "foo" user boa insert-tuple
-                "denny" "kitty" user boa insert-tuple
-            ] with-transaction
-        ] with-transaction
-    ] with-db
-] unit-test

basis/db/sqlite/sqlite.factor

@@ -1,343 +0,0 @@
-! 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 fry
-sequences strings classes.tuple alien.c-types continuations
-db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-math.intervals io locals nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string make db.private sequences.deep
-db.errors.sqlite ;
-IN: db.sqlite
-
-TUPLE: sqlite-db path ;
-
-: <sqlite-db> ( path -- sqlite-db )
-    sqlite-db new
-        swap >>path ;
-
-<PRIVATE
-
-TUPLE: sqlite-db-connection < db-connection ;
-
-: <sqlite-db-connection> ( handle -- db-connection )
-    sqlite-db-connection new-db-connection
-        swap >>handle ;
-
-PRIVATE>
-
-M: sqlite-db db-open ( db -- db-connection )
-    path>> sqlite-open <sqlite-db-connection> ;
-
-M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
-
-TUPLE: sqlite-statement < statement ;
-
-TUPLE: sqlite-result-set < result-set has-more? ;
-
-M: sqlite-db-connection <simple-statement> ( str in out -- obj )
-    <prepared-statement> ;
-
-M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
-    sqlite-statement new-statement ;
-
-: sqlite-maybe-prepare ( statement -- statement )
-    dup handle>> [
-        db-connection 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-bindings ( statement -- )
-    sqlite-maybe-prepare
-    handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
-
-M: sqlite-statement low-level-bind ( statement -- )
-    [ handle>> ] [ bind-params>> ] bi
-    [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with 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 )
-    generate-bind generator-singleton>> eval-generator :> obj
-    generate-bind slot-name>> :> name
-    obj name tuple set-slot-named
-    generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
-
-M: sqlite-statement bind-tuple ( tuple statement -- )
-    [
-        in-params>> [ sqlite-bind-conversion ] with map
-    ] keep bind-statement ;
-
-ERROR: sqlite-last-id-fail ;
-
-: last-insert-id ( -- id )
-    db-connection get handle>> sqlite3_last_insert_rowid
-    dup zero? [ sqlite-last-id-fail ] when ;
-
-M: sqlite-db-connection insert-tuple-set-key ( 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>>
-    [ handle>> ] 2dip 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 new-result-set
-    dup advance-row ;
-
-M: sqlite-db-connection <insert-db-assigned-statement> ( class -- 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-connection <insert-user-assigned-statement> ( class -- statement )
-    <insert-db-assigned-statement> ;
-
-M: sqlite-db-connection bind# ( spec obj -- )
-    [
-        [ column-name>> ":" next-sql-counter surround dup 0% ]
-        [ type>> ] bi
-    ] dip <literal-bind> 1, ;
-
-M: sqlite-db-connection bind% ( spec -- )
-    dup 1, column-name>> ":" prepend 0% ;
-
-M: sqlite-db-connection persistent-table ( -- assoc )
-    H{
-        { +db-assigned-id+ { "integer" "integer" f } }
-        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "integer" "integer" f } }
-        { +foreign-id+ { "integer" "integer" "references" } }
-
-        { +on-update+ { f f "on update" } }
-        { +on-delete+ { f f "on delete" } }
-        { +restrict+ { f f "restrict" } }
-        { +cascade+ { f f "cascade" } }
-        { +set-null+ { f f "set null" } }
-        { +set-default+ { f f "set default" } }
-
-        { BOOLEAN { "boolean" "boolean" f } }
-        { INTEGER { "integer" "integer" f } }
-        { BIG-INTEGER { "bigint" "bigint" f } }
-        { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
-        { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
-        { TEXT { "text" "text" f } }
-        { VARCHAR { "text" "text" f } }
-        { DATE { "date" "date" f } }
-        { TIME { "time" "time" f } }
-        { DATETIME { "datetime" "datetime" f } }
-        { TIMESTAMP { "timestamp" "timestamp" f } }
-        { DOUBLE { "real" "real" f } }
-        { BLOB { "blob" "blob" f } }
-        { FACTOR-BLOB { "blob" "blob" f } }
-        { URL { "text" "text" f } }
-        { +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 } }
-    } ;
-
-: insert-trigger ( -- string )
-    "
-        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE INSERT ON ${table-name}
-        FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
-        END;
-    " interpolate>string ;
-
-: insert-trigger-not-null ( -- string )
-    "
-        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE INSERT ON ${table-name}
-        FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
-            WHERE NEW.${table-id} IS NOT NULL
-                AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
-        END;
-    " interpolate>string ;
-
-: update-trigger ( -- string )
-    "
-        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE UPDATE ON ${table-name}
-        FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
-            WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
-        END;
-    " interpolate>string ;
-
-: update-trigger-not-null ( -- string )
-    "
-        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE UPDATE ON ${table-name}
-        FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
-            WHERE NEW.${table-id} IS NOT NULL
-                AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
-        END;
-    " interpolate>string ;
-
-: delete-trigger-restrict ( -- string )
-    "
-        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE DELETE ON ${foreign-table-name}
-        FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'delete on table \"${foreign-table-name}\" violates foreign key constraint \"fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
-            WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
-        END;
-    " interpolate>string ;
-
-: delete-trigger-cascade ( -- string )
-    "
-        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
-        BEFORE DELETE ON ${foreign-table-name}
-        FOR EACH ROW BEGIN
-            DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
-        END;
-    " interpolate>string ;
-
-: can-be-null? ( -- ? )
-    "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
-
-: delete-cascade? ( -- ? )
-    "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
-
-: sqlite-trigger, ( string -- )
-    { } { } <simple-statement> 3, ;
-
-: create-sqlite-triggers ( -- )
-    can-be-null? [
-        insert-trigger sqlite-trigger,
-        update-trigger sqlite-trigger,
-    ] [
-        insert-trigger-not-null sqlite-trigger,
-        update-trigger-not-null sqlite-trigger,
-    ] if
-    delete-cascade? [
-        delete-trigger-cascade sqlite-trigger,
-    ] [
-        delete-trigger-restrict sqlite-trigger,
-    ] if ;
-
-: create-db-triggers ( sql-specs -- )
-    [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
-    [
-        [ class>> db-table-name "db-table" set ]
-        [
-            [ "sql-spec" set ]
-            [ column-name>> "table-id" set ]
-            [ ] tri
-            modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
-            [
-                [ second db-table-name "foreign-table-name" set ]
-                [ third "foreign-table-id" set ] bi
-                create-sqlite-triggers
-            ] each
-        ] bi
-    ] each ;
-
-: sqlite-create-table ( sql-specs class-name -- )
-    [
-        "create table " 0% 0%
-        "(" 0% [ ", " 0% ] [
-            dup "sql-spec" set
-            dup column-name>> [ "table-id" set ] [ 0% ] bi
-            " " 0%
-            dup type>> lookup-create-type 0%
-            modifiers 0%
-        ] interleave
-    ] [
-        drop
-        find-primary-key [
-            ", " 0%
-            "primary key(" 0%
-            [ "," 0% ] [ column-name>> 0% ] interleave
-            ")" 0%
-        ] unless-empty
-        ");" 0%
-    ] 2bi ;
-
-M: sqlite-db-connection create-sql-statement ( class -- statement )
-    [
-        [ sqlite-create-table ]
-        [ drop create-db-triggers ] 2bi
-    ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statements )
-    [ nip "drop table " 0% 0% ";" 0% ] query-make ;
-
-M: sqlite-db-connection compound ( string seq -- new-string )
-    over {
-        { "default" [ first number>string " " glue ] }
-        { "references" [ >reference-string ] }
-        [ 2drop ]
-    } case ;
-
-M: sqlite-db-connection parse-db-error
-    dup n>> {
-        { 1 [ string>> parse-sqlite-sql-error ] }
-        [ drop ]
-    } case ;

basis/db/sqlite/summary.txt

@@ -1 +0,0 @@
-SQLite database connector

basis/db/sqlite/test.txt

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

basis/db/summary.txt

@@ -1 +0,0 @@
-Relational database abstraction layer

basis/db/tags.txt

@@ -1 +0,0 @@
-enterprise

basis/db/tester/tester-tests.factor

@@ -1,7 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test db.tester ;
-IN: db.tester.tests
-
-{ } [ sqlite-test-db db-tester ] unit-test
-{ } [ sqlite-test-db db-tester2 ] unit-test

basis/db/tester/tester.factor

@@ -1,103 +0,0 @@
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.combinators db db.pools db.sqlite db.tuples
-db.types destructors kernel math random threads tools.test sequences
-io io.pools prettyprint db.postgresql accessors io.files.temp
-namespaces fry system math.parser db.queries assocs ;
-IN: db.tester
-
-: postgresql-test-db-name ( -- string )
-    cpu name>> "-" "factor-test" 3append
-    H{ { CHAR: - CHAR: _ } { CHAR: . CHAR: _ } } substitute ;
-
-: postgresql-test-db ( -- postgresql-db )
-    \ postgresql-db get-global clone postgresql-test-db-name >>database ;
-
-: postgresql-template1-db ( -- postgresql-db )
-    \ postgresql-db get-global clone "template1" >>database ;
-
-: sqlite-test-db ( -- sqlite-db )
-    cpu name>> "tuples-test." ".db" surround
-    temp-file <sqlite-db> ;
-
-! These words leak resources, but are useful for interactive testing
-: set-sqlite-db ( -- )
-    sqlite-db db-open db-connection set ;
-
-: set-postgresql-db ( -- )
-    postgresql-db db-open db-connection set ;
-
-
-: test-sqlite ( quot -- )
-    '[
-        [ ] [ sqlite-test-db _ with-db ] unit-test
-    ] call ; inline
-
-: test-postgresql ( quot -- )
-
-    '[
-        os windows? cpu x86.64? and [
-            postgresql-template1-db [
-                postgresql-test-db-name ensure-database
-            ] with-db
-            [ ] [ 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
-
-: test-1-tuple ( -- tuple )
-    f 100 random 100 random 100 random [ number>string ] tri@
-    test-1 boa ;
-
-: db-tester ( test-db -- )
-    [
-        [
-            test-1 ensure-table
-            test-2 ensure-table
-        ] with-db
-    ] [
-        10 iota [
-            drop
-            10 [
-                dup [
-                    test-1-tuple 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 iota [
-                    10 [
-                        test-1-tuple insert-tuple yield
-                    ] times
-                ] parallel-each
-            ] with-pooled-db
-        ] with-disposal
-    ] bi ;

basis/db/tuples/summary.txt

@@ -1 +0,0 @@
-O/R mapper

basis/db/tuples/tuples-docs.factor

@@ -1,272 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings math db.types db.tuples.private db ;
-IN: db.tuples
-
-HELP: random-id-generator
-{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
-
-HELP: create-sql-statement
-{ $values
-     { "class" class }
-     { "object" object } }
-{ $description "Generates the SQL code for creating a table for a given class." } ;
-
-HELP: drop-sql-statement
-{ $values
-     { "class" class }
-     { "object" object } }
-{ $description "Generates the SQL code for dropping a table for a given class." } ;
-
-HELP: insert-tuple-set-key
-{ $values
-     { "tuple" tuple } { "statement" statement } }
-{ $description "Inserts a tuple and sets its primary key in one word. This is necessary for some databases." } ;
-
-HELP: <count-statement>
-{ $values
-     { "query" query }
-     { "statement" statement } }
-{ $description "A database-specific hook for generating the SQL for a count statement." } ;
-
-HELP: <delete-tuples-statement>
-{ $values
-     { "tuple" tuple } { "class" class }
-     { "object" object } }
-{ $description "A database-specific hook for generating the SQL for an delete statement." } ;
-
-HELP: <insert-db-assigned-statement>
-{ $values
-     { "class" class }
-     { "object" object } }
-{ $description "A database-specific hook for generating the SQL for an insert statement with a database-assigned primary key." } ;
-
-HELP: <insert-user-assigned-statement>
-{ $values
-     { "class" class }
-     { "object" object } }
-{ $description "A database-specific hook for generating the SQL for an insert statement with a user-assigned primary key." } ;
-
-HELP: <select-by-slots-statement>
-{ $values
-     { "tuple" tuple } { "class" class }
-     { "statement" tuple } }
-{ $description "A database-specific hook for generating the SQL for a select statement." } ;
-
-HELP: <update-tuple-statement>
-{ $values
-     { "class" class }
-     { "object" object } }
-{ $description "A database-specific hook for generating the SQL for an update statement." } ;
-
-
-HELP: define-persistent
-{ $values
-     { "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
-{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to a SQL database table name. The format for the slot specifiers is as follows:"
-{ $list
-    { "a slot name from the " { $snippet "tuple class" } }
-    { "the name of a database column that maps to the slot" }        { "a database type (see " { $link "db.types" } ")" }
-} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
-{ $examples
-    { $code "USING: db.tuples db.types ;"
-        "TUPLE: boat id year name ;"
-        "boat \"BOAT\" {"
-        "    { \"id\" \"ID\" +db-assigned-id+ }"
-        "    { \"year\" \"YEAR\" INTEGER }"
-        "    { \"name\" \"NAME\" TEXT }"
-        "} define-persistent"
-    }
-} ;
-
-HELP: create-table
-{ $values
-     { "class" class } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
-
-HELP: ensure-table
-{ $values
-     { "class" class } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
-
-HELP: ensure-tables
-{ $values
-     { "classes" "a sequence of classes" } }
-{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
-
-HELP: recreate-table
-{ $values
-     { "class" class } }
-{ $description "Drops an existing table and re-creates it from a mapping defined by " { $link define-persistent } ". If the table does not exist the error is silently ignored." }
-{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } $nl
-" Use " { $link ensure-table } " unless you want to delete the data in this table." } ;
-
-{ create-table ensure-table ensure-tables recreate-table } related-words
-
-HELP: drop-table
-{ $values
-     { "class" class } }
-{ $description "Drops an existing table which deletes all of the data. The database will probably throw an error if the table does not exist." }
-{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } } ;
-
-HELP: insert-tuple
-{ $values
-     { "tuple" tuple } }
-{ $description "Inserts a tuple into a database if a relation has been defined with " { $link define-persistent } ". If a mapping states that the database assigns a primary key to the tuple, this value will be set after this word runs." }
-{ $notes "Objects should only be inserted into a database once per object. To store the object after the initial insert, call " { $link update-tuple } "." } ;
-
-HELP: update-tuple
-{ $values
-     { "tuple" tuple } }
-{ $description "Updates a tuple that has already been inserted into a database. The tuple must have a primary key that has been set by " { $link insert-tuple } " or that is user-defined." } ;
-
-HELP: delete-tuples
-{ $values
-     { "tuple" tuple } }
-{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate a SQL statement that deletes tuples." }
-{ $warning "This word will delete your data." } ;
-
-{ insert-tuple update-tuple delete-tuples } related-words
-
-HELP: select-tuple
-{ $values
-     { "query/tuple" tuple }
-     { "tuple/f" { $maybe tuple } } }
-{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
-
-HELP: select-tuples
-{ $values
-     { "query/tuple" tuple }
-     { "tuples" "an array of tuples" } }
-{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns an array of multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
-
-HELP: count-tuples
-{ $values
-     { "query/tuple" tuple }
-     { "n" integer } }
-{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
-
-{ select-tuple select-tuples count-tuples } related-words
-
-
-
-ARTICLE: "db-tuples" "High-level tuple/database integration"
-"Start with a tutorial:"
-{ $subsections "db-tuples-tutorial" }
-"Database types supported:"
-{ $subsections "db.types" }
-"Useful words:"
-{ $subsections "db-tuples-words" }
-"For porting " { $vocab-link "db.tuples" } " to other databases:"
-{ $subsections "db-tuples-protocol" }
-;
-
-ARTICLE: "db-tuples-words" "High-level tuple/database words"
-"Making tuples work with a database:"
-{ $subsections define-persistent }
-"Creating tables:"
-{ $subsections
-    create-table
-    ensure-table
-    ensure-tables
-    recreate-table
-}
-"Dropping tables:"
-{ $subsections drop-table }
-"Inserting a tuple:"
-{ $subsections insert-tuple }
-"Updating a tuple:"
-{ $subsections update-tuple }
-"Deleting tuples:"
-{ $subsections delete-tuples }
-"Querying tuples:"
-{ $subsections
-    select-tuple
-    select-tuples
-    count-tuples
-} ;
-
-ARTICLE: "db-tuples-protocol" "Tuple database protocol"
-"Creating a table:"
-{ $subsections create-sql-statement }
-"Dropping a table:"
-{ $subsections drop-sql-statement }
-"Inserting a tuple:"
-{ $subsections
-    <insert-db-assigned-statement>
-    <insert-user-assigned-statement>
-}
-"Updating a tuple:"
-{ $subsections <update-tuple-statement> }
-"Deleting tuples:"
-{ $subsections <delete-tuples-statement> }
-"Selecting tuples:"
-{ $subsections <select-by-slots-statement> }
-"Counting tuples:"
-{ $subsections <count-statement> } ;
-
-ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
-"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
-"We're going to store books in this tutorial."
-{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
-"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
-"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
-{ $code
-"USING: db.tuples db.types ;
-book \"BOOK\"
-{
-    { \"id\" \"ID\" +db-assigned-id+ }
-    { \"title\" \"TITLE\" VARCHAR }
-    { \"author\" \"AUTHOR\" VARCHAR }
-    { \"date-published\" \"DATE_PUBLISHED\" TIMESTAMP }
-    { \"edition\" \"EDITION\" INTEGER }
-    { \"cover-price\" \"COVER_PRICE\" DOUBLE }
-    { \"condition\" \"CONDITION\" VARCHAR }
-} define-persistent" }
-"That's all we'll have to do with the database for this tutorial. Now let's make a book."
-{ $code "USING: calendar namespaces ;
-T{ book
-    { title \"Factor for Sheeple\" }
-    { author \"Mister Stacky Pants\" }
-    { date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } }
-    { edition 1 }
-    { cover-price 13.37 }
-} book set" }
-"Now we've created a book. Let's save it to the database."
-{ $code "USING: db db.sqlite fry io.files.temp ;
-: with-book-tutorial ( quot -- )
-     '[ \"book-tutorial.db\" temp-file <sqlite-db> _ with-db ] call ; inline
-
-[
-    book recreate-table
-    book get insert-tuple
-] with-book-tutorial" }
-"Is it really there?"
-{ $code "[
-    T{ book { title \"Factor for Sheeple\" } } select-tuples .
-] with-book-tutorial" }
-"Oops, we spilled some orange juice on the book cover."
-{ $code "book get \"Small orange juice stain on cover\" >>condition" }
-"Now let's save the modified book."
-{ $code "[
-    book get update-tuple
-] with-book-tutorial" }
-"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
-{ $code "[
-    T{ book { title \"Factor for Sheeple\" } } select-tuples
-] with-book-tutorial" }
-"Let's drop the table because we're done."
-{ $code "[
-    book drop-table
-] with-book-tutorial" }
-"To summarize, the steps for using Factor's tuple database are:"
-{ $list
-    "Make a new tuple to represent your data"
-    { "Map the Factor types to the database types with " { $link define-persistent } }
-    { "Make a custom database combinator (see " { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
-    { "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
-    { "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
-} ;
-
-ABOUT: "db-tuples"

basis/db/tuples/tuples-tests.factor

@@ -1,645 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.files.temp kernel tools.test db db.tuples classes
-db.types continuations namespaces math
-prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitwise system
-math.ranges strings urls fry db.tuples.private db.private
-db.tester ;
-FROM: math.ranges => [a,b] ;
-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 ;
-
-paste "PASTE"
-{
-    { "n" "ID" +db-assigned-id+ }
-    { "summary" "SUMMARY" TEXT }
-    { "author" "AUTHOR" TEXT }
-    { "channel" "CHANNEL" TEXT }
-    { "mode" "MODE" TEXT }
-    { "contents" "CONTENTS" TEXT }
-    { "timestamp" "DATE" TIMESTAMP }
-    { "annotations" { +has-many+ annotation } }
-} define-persistent
-
-: annotation-schema-foreign-key ( -- )
-    annotation "ANNOTATION"
-    {
-        { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
-        { "summary" "SUMMARY" TEXT }
-        { "author" "AUTHOR" TEXT }
-        { "mode" "MODE" TEXT }
-        { "contents" "CONTENTS" TEXT }
-    } define-persistent ;
-
-: annotation-schema-foreign-key-not-null ( -- )
-    annotation "ANNOTATION"
-    {
-        { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
-        { "summary" "SUMMARY" TEXT }
-        { "author" "AUTHOR" TEXT }
-        { "mode" "MODE" TEXT }
-        { "contents" "CONTENTS" TEXT }
-    } define-persistent ;
-
-: annotation-schema-cascade ( -- )
-    annotation "ANNOTATION"
-    {
-        { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
-            +on-delete+ +cascade+ }
-        { "summary" "SUMMARY" TEXT }
-        { "author" "AUTHOR" TEXT }
-        { "mode" "MODE" TEXT }
-        { "contents" "CONTENTS" TEXT }
-    } define-persistent ;
-
-: annotation-schema-restrict ( -- )
-    annotation "ANNOTATION"
-    {
-        { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
-        { "summary" "SUMMARY" TEXT }
-        { "author" "AUTHOR" TEXT }
-        { "mode" "MODE" TEXT }
-        { "contents" "CONTENTS" TEXT }
-    } define-persistent ;
-
-: test-paste-schema ( -- )
-    [ ] [ paste ensure-table ] unit-test
-    [ ] [ annotation ensure-table ] unit-test
-    [ ] [ annotation drop-table ] unit-test
-    [ ] [ paste drop-table ] unit-test
-    [ ] [ paste create-table ] unit-test
-    [ ] [ annotation create-table ] unit-test
-
-    [ ] [
-        paste new
-            "summary1" >>summary
-            "erg" >>author
-            "#lol" >>channel
-            "contents1" >>contents
-            now >>timestamp
-        insert-tuple
-    ] unit-test
-
-    [ ] [
-        annotation new
-            1 >>paste-id
-            "annotation1" >>summary
-            "erg" >>author
-            "annotation contents" >>contents
-        insert-tuple
-    ] unit-test ;
-
-: test-foreign-key ( -- )
-    [ ] [ annotation-schema-foreign-key ] unit-test
-    test-paste-schema
-    [ paste new 1 >>n delete-tuples ] must-fail ;
-
-: test-foreign-key-not-null ( -- )
-    [ ] [ annotation-schema-foreign-key-not-null ] unit-test
-    test-paste-schema
-    [ paste new 1 >>n delete-tuples ] must-fail ;
-
-: test-cascade ( -- )
-    [ ] [ annotation-schema-cascade ] unit-test
-    test-paste-schema
-    [ ] [ paste new 1 >>n delete-tuples ] unit-test
-    [ 0 ] [ paste new select-tuples length ] unit-test ;
-
-: test-restrict ( -- )
-    [ ] [ annotation-schema-restrict ] unit-test
-    test-paste-schema
-    [ paste new 1 >>n delete-tuples ] must-fail ;
-
-[ test-foreign-key ] test-sqlite
-[ test-foreign-key-not-null ] test-sqlite
-[ test-cascade ] test-sqlite
-[ test-restrict ] test-sqlite
-
-[ test-foreign-key ] test-postgresql
-[ test-foreign-key-not-null ] test-postgresql
-[ test-cascade ] test-postgresql
-[ test-restrict ] test-postgresql
-
-: 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"
-        {
-            { "idd" "ID" +db-assigned-id+ }
-            { "named" "NAME" TEXT }
-            { "score" "SCORE" INTEGER }
-        } define-persistent
-    ] [
-        seq>> { "idd" "named" } =
-    ] must-fail-with
-
-    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
-
-    [ 4 ]
-    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
-
-    [ f ]
-    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
-
-    [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
-
-    [
-        {
-            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. f } } } select-tuples
-    ] unit-test
-
-    [
-        {
-            T{ exam f 1 "Kyle" 100 }
-        }
-    ] [
-        T{ exam f T{ interval f { -1/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. 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 } count-tuples ] unit-test
-
-    [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
-
-    [ 10 ]
-    [ T{ exam { name NULL } } select-tuples first score>> ] 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-of \ not-persistent = ] must-fail-with
-] test-sqlite
-
-[
-    [ does-not-persist create-sql-statement ]
-    [ class-of \ 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
-
-: test-queries ( -- )
-    [ ] [ exam ensure-table ] unit-test
-    [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
-    [ 5 ] [
-        <query>
-        T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
-            >>tuple
-        5 >>limit select-tuples length
-    ] unit-test ;
-
-TUPLE: compound-foo a b c ;
-
-compound-foo "COMPOUND_FOO"
-{
-    { "a" "A" INTEGER +user-assigned-id+ }
-    { "b" "B" INTEGER +user-assigned-id+ }
-    { "c" "C" INTEGER }
-} define-persistent
-
-: test-compound-primary-key ( -- )
-    [ ] [ compound-foo ensure-table ] unit-test
-    [ ] [ compound-foo drop-table ] unit-test
-    [ ] [ compound-foo create-table ] unit-test
-    [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
-    [ 1 2 3 compound-foo boa insert-tuple ] must-fail
-    [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
-    [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
-    [ compound-foo new 4 >>c select-tuple ] unit-test ;
-
-[ test-compound-primary-key ] test-sqlite
-[ test-compound-primary-key ] test-postgresql
-
-
-TUPLE: example id data ;
-
-example "EXAMPLE"
-{
-    { "id" "ID" +db-assigned-id+ }
-    { "data" "DATA" BLOB }
-} define-persistent
-
-: test-blob-select ( -- )
-    example ensure-table
-    [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
-    [
-        T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
-    ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
-
-[ test-blob-select ] test-sqlite
-[ test-blob-select ] test-postgresql

basis/db/tuples/tuples.factor

@@ -1,159 +0,0 @@
-! 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 continuations
-destructors mirrors sets db.types db.private fry
-combinators.short-circuit db.errors ;
-IN: db.tuples
-
-HOOK: create-sql-statement db-connection ( class -- object )
-HOOK: drop-sql-statement db-connection ( class -- object )
-
-HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
-HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
-HOOK: <update-tuple-statement> db-connection ( class -- object )
-HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
-HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
-HOOK: <count-statement> db-connection ( query -- statement )
-HOOK: query>statement db-connection ( query -- statement )
-HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
-
-<PRIVATE
-
-SYMBOL: sql-counter
-
-: next-sql-counter ( -- str )
-    sql-counter [ inc ] [ get ] bi number>string ;
-
-GENERIC: eval-generator ( singleton -- object )
-
-: resulting-tuple ( exemplar-tuple row out-params -- tuple )
-    rot class-of new [
-        '[ slot-name>> _ set-slot-named ] 2each
-    ] keep ;
-
-: query-tuples ( exemplar-tuple statement -- seq )
-    [ out-params>> ] keep query-results [
-        [ sql-row-typed swap resulting-tuple ] 2with query-map
-    ] with-disposal ;
-
-: query-modify-tuple ( tuple statement -- )
-    [ query-results [ sql-row-typed ] with-disposal ] keep
-    out-params>> rot [
-        [ slot-name>> ] dip set-slot-named
-    ] curry 2each ;
-
-: with-disposals ( object quotation -- )
-    over sequence? [
-        [ with-disposal ] curry each
-    ] [
-        with-disposal
-    ] if ; inline
-
-: insert-db-assigned-statement ( tuple -- )
-    dup class-of
-    db-connection get insert-statements>>
-    [ <insert-db-assigned-statement> ] cache
-    [ bind-tuple ] 2keep insert-tuple-set-key ;
-
-: insert-user-assigned-statement ( tuple -- )
-    dup class-of
-    db-connection get insert-statements>>
-    [ <insert-user-assigned-statement> ] cache
-    [ bind-tuple ] keep execute-statement ;
-
-: do-select ( exemplar-tuple statement -- tuples )
-    [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
-
-: do-count ( exemplar-tuple statement -- tuples )
-    [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
-
-PRIVATE>
-
-! High level
-ERROR: no-slots-named class seq ;
-: check-columns ( class columns -- )
-    [ nip ] [
-        [ keys ]
-        [ all-slots [ name>> ] map ] bi* diff
-    ] 2bi
-    [ drop ] [ no-slots-named ] if-empty ;
-
-: define-persistent ( class table columns -- )
-    pick dupd
-    check-columns
-    [ dupd "db-table" set-word-prop dup ] dip
-    [ relation? ] partition swapd
-    dupd [ spec>tuple ] with map
-    "db-columns" set-word-prop
-    "db-relations" set-word-prop ;
-
-TUPLE: query tuple group order offset limit ;
-
-: <query> ( -- query ) \ query new ;
-
-GENERIC: >query ( object -- query )
-
-M: query >query clone ;
-
-M: tuple >query <query> swap >>tuple ;
-
-ERROR: no-defined-persistent object ;
-
-: ensure-defined-persistent ( object -- object )
-    dup { [ class? ] [ "db-table" word-prop ] } 1&& [
-        no-defined-persistent
-    ] unless ;
-
-: create-table ( class -- )
-    ensure-defined-persistent
-    create-sql-statement [ execute-statement ] with-disposals ;
-
-: drop-table ( class -- )
-    ensure-defined-persistent
-    drop-sql-statement [ execute-statement ] with-disposals ;
-
-: recreate-table ( class -- )
-    ensure-defined-persistent
-    [
-        '[
-            [
-                _ drop-sql-statement [ execute-statement ] with-disposals
-            ] ignore-table-missing
-        ] ignore-function-missing
-    ] [ create-table ] bi ;
-
-: ensure-table ( class -- )
-    ensure-defined-persistent
-    '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
-
-: ensure-tables ( classes -- ) [ ensure-table ] each ;
-
-: insert-tuple ( tuple -- )
-    dup class-of ensure-defined-persistent db-assigned?
-    [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
-
-: update-tuple ( tuple -- )
-    dup class-of ensure-defined-persistent
-    db-connection get update-statements>> [ <update-tuple-statement> ] cache
-    [ bind-tuple ] keep execute-statement ;
-
-: delete-tuples ( tuple -- )
-    dup
-    dup class-of ensure-defined-persistent
-    <delete-tuples-statement> [
-        [ bind-tuple ] keep execute-statement
-    ] with-disposal ;
-
-: select-tuples ( query/tuple -- tuples )
-    >query [ tuple>> ] [ query>statement ] bi do-select ;
-
-: select-tuple ( query/tuple -- tuple/f )
-    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
-    do-select ?first ;
-
-: count-tuples ( query/tuple -- n )
-    >query [ tuple>> ] [ <count-statement> ] bi do-count
-    dup length 1 =
-    [ first first string>number ] [ [ first string>number ] map ] if ;

basis/db/types/summary.txt

@@ -1 +0,0 @@
-SQL data type support

basis/db/types/types-docs.factor

@@ -1,185 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings ;
-IN: db.types
-
-HELP: +db-assigned-id+
-{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
-
-HELP: +default+
-{ $description "Allows a default value for a column to be provided." } ;
-
-HELP: +not-null+
-{ $description "Ensures that a column is not null." } ;
-
-HELP: +null+
-{ $description "Allows a column to be null." } ;
-
-HELP: +primary-key+
-{ $description "Makes a column a primary key. Only one column may be a primary key." } ;
-
-HELP: +random-id+
-{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
-
-HELP: +user-assigned-id+
-{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
-
-HELP: <generator-bind>
-{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
-{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
-
-HELP: <literal-bind>
-{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
-{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
-
-HELP: BIG-INTEGER
-{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
-
-HELP: BLOB
-{ $description "A byte array." } ;
-
-HELP: BOOLEAN
-{ $description "Either true or false." } ;
-
-HELP: DATE
-{ $description "A date without a time component." } ;
-
-HELP: DATETIME
-{ $description "A date and a time." } ;
-
-HELP: DOUBLE
-{ $description "Corresponds to Factor's 64-bit floating-point numbers." } ;
-
-HELP: FACTOR-BLOB
-{ $description "A serialized Factor object." } ;
-
-HELP: INTEGER
-{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ;
-
-HELP: NULL
-{ $description "The SQL null type." } ;
-
-HELP: REAL
-{ $description "A real number of unlimited precision. May not be supported on all databases." } ;
-
-HELP: SIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
-
-HELP: TEXT
-{ $description "Stores a string that is longer than a " { $link VARCHAR } ". SQLite uses this type for strings; it does not handle " { $link VARCHAR } " strings." } ;
-
-HELP: TIME
-{ $description "A timestamp without a date component." } ;
-
-HELP: TIMESTAMP
-{ $description "A Factor timestamp." } ;
-
-HELP: UNSIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
-
-{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
-
-HELP: URL
-{ $description "A Factor " { $link "urls" } " object." } ;
-
-HELP: VARCHAR
-{ $description "The SQL varchar type. This type can take an integer as an argument." }
-{ $examples { $unchecked-example "{ VARCHAR 256 }" "" } } ;
-
-HELP: user-assigned-id-spec?
-{ $values
-     { "specs" "a sequence of SQL specs" }
-     { "?" boolean } }
-{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
-
-HELP: bind#
-{ $values
-     { "spec" "a SQL spec" } { "obj" object } }
-{ $description "A generic word that lets a database construct a literal binding." } ;
-
-HELP: bind%
-{ $values
-     { "spec" "a SQL spec" } }
-{ $description "A generic word that lets a database output a binding." } ;
-
-HELP: db-assigned-id-spec?
-{ $values
-     { "specs" "a sequence of SQL specs" }
-     { "?" boolean } }
-{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
-
-HELP: find-primary-key
-{ $values
-     { "specs" "a sequence of SQL specs" }
-     { "seq" "a sequence of SQL specs" } }
-{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
-{ $notes "This is a low-level word." } ;
-
-HELP: no-sql-type
-{ $values
-     { "type" "a SQL type" } }
-{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
-
-HELP: normalize-spec
-{ $values
-     { "spec" "a SQL spec" } }
-{ $description "Normalizes a SQL spec." } ;
-
-HELP: primary-key?
-{ $values
-     { "spec" "a SQL spec" }
-     { "?" boolean } }
-{ $description "Returns true if a SQL spec is a primary key." } ;
-
-HELP: relation?
-{ $values
-     { "spec" "a SQL spec" }
-     { "?" boolean } }
-{ $description "Returns true if a SQL spec is a relation." } ;
-
-HELP: unknown-modifier
-{ $values { "modifier" string } }
-{ $description "Throws an error containing an unknown SQL modifier." } ;
-
-ARTICLE: "db.types" "Database types"
-"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
-"Primary keys:"
-{ $subsections
-    +db-assigned-id+
-    +user-assigned-id+
-    +random-id+
-}
-"Null and boolean types:"
-{ $subsections
-    NULL
-    BOOLEAN
-}
-"Text types:"
-{ $subsections
-    VARCHAR
-    TEXT
-}
-"Number types:"
-{ $subsections
-    INTEGER
-    BIG-INTEGER
-    SIGNED-BIG-INTEGER
-    UNSIGNED-BIG-INTEGER
-    DOUBLE
-    REAL
-}
-"Calendar types:"
-{ $subsections
-    DATE
-    DATETIME
-    TIME
-    TIMESTAMP
-}
-"Factor byte-arrays:"
-{ $subsections BLOB }
-"Arbitrary Factor objects:"
-{ $subsections FACTOR-BLOB }
-"Factor URLs:"
-{ $subsections URL } ;
-
-ABOUT: "db.types"

basis/db/types/types.factor

@@ -1,156 +0,0 @@
-! 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 prettyprint
-words namespaces slots slots.private classes mirrors
-classes.tuple combinators calendar.format classes.singleton
-accessors quotations random db.private ;
-IN: db.types
-
-HOOK: persistent-table db-connection ( -- hash )
-HOOK: compound db-connection ( string 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
-
-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+ ;
-
-SYMBOL: IGNORE
-
-: filter-ignores ( tuple specs -- specs' )
-    [ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
-    [ slot-name>> swap member? ] with reject ;
-
-ERROR: not-persistent class ;
-
-: db-table-name ( class -- object )
-    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
-
-: db-columns ( class -- object )
-    superclasses-of [ "db-columns" word-prop ] map concat ;
-
-: db-relations ( class -- object )
-    "db-relations" word-prop ;
-
-: find-primary-key ( specs -- seq )
-    [ primary-key>> ] filter ;
-
-: set-primary-key ( value tuple -- )
-    [
-        class-of db-columns
-        find-primary-key first slot-name>>
-    ] keep set-slot-named ;
-
-: primary-key? ( spec -- ? )
-    primary-key>> +primary-key+? ;
-
-: db-assigned-id-spec? ( specs -- ? )
-    [ primary-key>> +db-assigned-id+? ] any? ;
-
-: user-assigned-id-spec? ( specs -- ? )
-    [ primary-key>> +user-assigned-id+? ] any? ;
-
-: normalize-spec ( spec -- )
-    dup type>> dup +primary-key+? [
-        >>primary-key drop
-    ] [
-        drop dup modifiers>> [
-            +primary-key+?
-        ] deep-find
-        [ >>primary-key drop ] [ drop ] if*
-    ] if ;
-
-: db-assigned? ( class -- ? )
-    db-columns find-primary-key db-assigned-id-spec? ;
-
-: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-
-SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
-DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
-FACTOR-BLOB NULL URL ;
-
-: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
-    sql-spec new
-        swap >>modifiers
-        swap >>type
-        swap >>column-name
-        swap >>slot-name
-        swap >>class
-        dup normalize-spec ;
-
-: spec>tuple ( class spec -- tuple )
-    3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
-
-: number>string* ( n/string -- string )
-    dup number? [ number>string ] when ;
-
-: remove-db-assigned-id ( specs -- obj )
-    [ +db-assigned-id+? ] reject ;
-
-: remove-relations ( specs -- newcolumns )
-    [ relation? ] reject ;
-
-: remove-id ( specs -- obj )
-    [ primary-key>> ] reject ;
-
-! 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 modifier ;
-
-: lookup-modifier ( obj -- string )
-    {
-        { [ dup array? ] [ unclip lookup-modifier swap compound ] }
-        [ persistent-table ?at [ unknown-modifier ] unless third ]
-    } cond ;
-
-ERROR: no-sql-type type ;
-
-: (lookup-type) ( obj -- string )
-    persistent-table ?at [ no-sql-type ] unless ;
-
-: lookup-type ( obj -- string )
-    dup array? [
-        unclip (lookup-type) first nip
-    ] [
-        (lookup-type) first
-    ] if ;
-
-: lookup-create-type ( obj -- string )
-    dup array? [
-        unclip (lookup-type) second swap compound
-    ] [
-        (lookup-type) second
-    ] if ;
-
-: modifiers ( spec -- string )
-    modifiers>> [ lookup-modifier ] map " " join
-    [ "" ] [ " " prepend ] if-empty ;
-
-HOOK: bind% db-connection ( spec -- )
-HOOK: bind# db-connection ( spec obj -- )
-
-ERROR: no-column column ;
-
-: >reference-string ( string pair -- string )
-    first2
-    [ [ db-table-name " " glue ] [ db-columns ] bi ] dip
-    swap [ column-name>> = ] with find nip
-    [ no-column ] unless*
-    column-name>> "(" ")" surround append ;

basis/db2/binders/binders.factor

@@ -0,0 +1,89 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.tuple constructors db2.types db2.utils
+kernel math math.parser multiline parser quotations sequences ;
+IN: db2.binders
+
+TUPLE: table-ordinal table-name table-ordinal ;
+TUPLE: table-ordinal-column < table-ordinal column-name ;
+CONSTRUCTOR: <table-ordinal> table-ordinal
+    ( table-name table-ordinal -- obj ) ;
+CONSTRUCTOR: <table-ordinal-column> table-ordinal-column
+    ( table-name table-ordinal column-name -- obj ) ;
+
+SYNTAX: TO{
+    \ } [ 2 ensure-length first2 <table-ordinal> ] parse-literal ;
+
+SYNTAX: TOC{
+    \ } [ 3 ensure-length first3 <table-ordinal-column> ] parse-literal ;
+
+TUPLE: binder ;
+TUPLE: low-binder value type ;
+TUPLE: high-binder < low-binder class toc ;
+
+TUPLE: in-binder-low < low-binder ;
+CONSTRUCTOR: <in-binder-low> in-binder-low ( value type -- obj ) ;
+TUPLE: in-binder < high-binder ;
+CONSTRUCTOR: <in-binder> in-binder ( -- obj ) ;
+
+SYNTAX: TYPED{
+    \ } [ first2 <in-binder-low> ] parse-literal ;
+
+TUPLE: out-binder-low < binder type ;
+CONSTRUCTOR: <out-binder-low> out-binder-low ( type -- obj ) ;
+TUPLE: out-binder < high-binder ;
+CONSTRUCTOR: <out-binder> out-binder ( toc type -- obj ) ;
+
+TUPLE: and-binder binders ;
+TUPLE: or-binder binders ;
+
+TUPLE: join-binder < binder toc1 toc2 ;
+CONSTRUCTOR: <join-binder> join-binder ( toc1 toc2 -- obj ) ;
+
+TUPLE: count-function < out-binder ;
+CONSTRUCTOR: <count-function> count-function ( toc -- obj )
+    INTEGER >>type ;
+
+TUPLE: sum-function < out-binder ;
+CONSTRUCTOR: <sum-function> sum-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: average-function < out-binder ;
+CONSTRUCTOR: <average-function> average-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: min-function < out-binder ;
+CONSTRUCTOR: <min-function> min-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: max-function < out-binder ;
+CONSTRUCTOR: <max-function> max-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: first-function < out-binder ;
+CONSTRUCTOR: <first-function> first-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: last-function < out-binder ;
+CONSTRUCTOR: <last-function> last-function ( toc -- obj )
+    REAL >>type ;
+
+TUPLE: equal-binder < in-binder ;
+CONSTRUCTOR: <equal-binder> equal-binder ( -- obj ) ;
+TUPLE: not-equal-binder < in-binder ;
+CONSTRUCTOR: <not-equal-binder> not-equal-binder ( -- obj ) ;
+TUPLE: less-than-binder < in-binder ;
+CONSTRUCTOR: <less-than-binder> less-than-binder ( -- obj ) ;
+TUPLE: less-than-equal-binder < in-binder ;
+CONSTRUCTOR: <less-than-equal-binder> less-than-equal-binder ( -- obj ) ;
+TUPLE: greater-than-binder < in-binder ;
+CONSTRUCTOR: <greater-than-binder> greater-than-binder ( -- obj ) ;
+TUPLE: greater-than-equal-binder < in-binder ;
+CONSTRUCTOR: <greater-than-equal-binder> greater-than-equal-binder ( -- obj ) ;
+
+TUPLE: relation-binder
+class1 toc1 column1
+class2 toc2 column2
+relation-type ;
+
+CONSTRUCTOR: <relation-binder> relation-binder ( class1 toc1 column1 class2 toc2 column2 relation-type -- obj ) ;

basis/db2/connections/connections-tests.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.connections db2.debug ;
+IN: db2.connections.tests
+
+! Tests connection
+
+{ 1 0 } [ [ ] with-db ] must-infer-as

basis/db2/connections/connections.factor

@@ -0,0 +1,19 @@
+! 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 < disposable handle db ;
+
+: new-db-connection ( handle class -- db-connection )
+    new-disposable
+        swap >>handle ; inline
+
+GENERIC: db>db-connection-generic ( db -- db-connection )
+
+: db>db-connection ( db -- db-connection )
+    [ db>db-connection-generic ] keep >>db ; inline
+
+: with-db ( db quot -- )
+    [ db>db-connection db-connection over ] dip
+    '[ _ [ drop @ ] with-disposal ] with-variable ; inline

basis/db2/db2.factor

@@ -0,0 +1,75 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations db2.query-objects db2.result-sets
+db2.statements destructors fry kernel locals math reconstructors
+sequences strings summary vocabs.loader vocabs ;
+IN: db2
+
+ERROR: no-in-types statement ;
+ERROR: no-out-types statement ;
+
+GENERIC: sql-command ( object -- )
+GENERIC: sql-query ( object -- sequence )
+
+M: string sql-command ( string -- )
+    <statement>
+        swap >>sql
+    sql-command ;
+
+M: string sql-query ( string -- sequence )
+    <statement>
+        swap >>sql
+    sql-query ;
+
+ERROR: retryable-failed statement ;
+
+: execute-retry-quotation ( statement -- statement )
+    dup retry-quotation>> call( statement -- statement ) ;
+
+:: (run-retryable) ( statement quot: ( statement -- statement ) -- obj )
+    statement retries>> 0 > [
+        statement [ 1 - ] change-retries drop
+        [
+            statement quot call
+        ] [
+            statement errors>> push
+            statement execute-retry-quotation reset-statement
+            quot (run-retryable)
+        ] recover
+    ] [
+        statement retryable-failed
+    ] if ; inline recursive
+
+: run-retryable ( statement quot -- )
+    over retries>> [
+        '[ _ (run-retryable) ] with-disposal
+    ] [
+        with-disposal
+    ] if ; inline
+
+M: statement sql-command ( statement -- )
+    [
+        prepare-statement
+        [ bind-sequence ] [ statement>result-set ] bi
+    ] run-retryable drop ; inline
+
+M: query sql-command
+    query-object>statement sql-command ;
+
+M: statement sql-query ( statement -- sequence )
+    [
+        [
+            prepare-statement
+            [ bind-sequence ] [ statement>result-sequence ] bi
+        ] [
+            reconstructor>> [ call( obj -- obj ) ] when*
+        ] bi
+    ] run-retryable ; inline
+
+M: sequence sql-command [ sql-command ] each ;
+M: sequence sql-query [ sql-query ] map ;
+M: query sql-query
+    query-object>statement sql-query ;
+
+"db2.queries" require
+"db2.transactions" require

basis/db2/debug/debug.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections postgresql.db2
+sqlite.db2 fry io.files.temp kernel namespaces system tools.test ;
+IN: db2.debug
+
+: 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>db-connection db-connection set ;
+
+: test-sqlite-quot ( quot -- quot' )
+    '[ sqlite-test-db _ with-db ] ; inline
+
+: test-sqlite ( quot -- ) test-sqlite-quot call ; inline
+: test-sqlite0 ( quot -- ) test-sqlite-quot call( -- ) ; inline
+
+: postgresql-test-db ( -- postgresql-db )
+    <postgresql-db>
+        "localhost" >>host
+        "erg" >>username
+        "thepasswordistrust" >>password
+        "factor-test" >>database ;
+
+: set-postgresql-db ( -- )
+    postgresql-db db>db-connection db-connection set ;
+
+: test-postgresql-quot ( quot -- quot' )
+    '[
+        os windows? cpu x86.64? and [
+            [ ] [ postgresql-test-db _ with-db ] unit-test
+        ] unless
+    ] ; inline
+
+: test-postgresql ( quot -- ) test-postgresql-quot call ; inline
+: test-postgresql0 ( quot -- ) test-postgresql-quot call( -- ) ; inline
+
+: test-dbs ( quot -- )
+    {
+        [ test-sqlite0 ]
+        [ test-postgresql0 ]
+    } cleave ;
+
+: with-dummy-postgresql ( quot -- )
+    [ postgresql-test-db ] dip with-db ; inline
+
+: with-dummy-sqlite ( quot -- )
+    [ sqlite-test-db ] dip with-db ; inline

basis/db2/errors/errors.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors continuations db2.connections fry kernel ;
+IN: db2.errors
+
+ERROR: db-error ;
+
+TUPLE: sql-error location ;
+HOOK: parse-sql-error db-connection ( error -- error' )
+
+TUPLE: sql-unknown-error < sql-error message ;
+CONSTRUCTOR: <sql-unknown-error> sql-unknown-error ( message -- error ) ;
+
+TUPLE: sql-table-exists < sql-error table ;
+CONSTRUCTOR: <sql-table-exists> sql-table-exists ( table -- error ) ;
+
+TUPLE: sql-table-missing < sql-error table ;
+CONSTRUCTOR: <sql-table-missing> sql-table-missing ( table -- error ) ;
+
+TUPLE: sql-syntax-error < sql-error message ;
+CONSTRUCTOR: <sql-syntax-error> sql-syntax-error ( message -- error ) ;
+
+TUPLE: sql-function-exists < sql-error message ;
+CONSTRUCTOR: <sql-function-exists> sql-function-exists ( message -- error ) ;
+
+TUPLE: sql-function-missing < sql-error message ;
+CONSTRUCTOR: <sql-function-missing> 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

basis/db2/introspection/introspection.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.connections ;
+IN: db2.introspection
+
+HOOK: all-db-objects db-connection ( -- sequence )
+HOOK: all-tables db-connection ( -- sequence )
+HOOK: all-indices db-connection ( -- sequence )
+HOOK: temporary-db-objects db-connection ( -- sequence )
+
+HOOK: table-columns db-connection ( name -- sequence )
+
+

basis/db2/pools/authors.txt

@@ -1,2 +1 @@
 Slava Pestov
-Doug Coleman

basis/db2/pools/pools-tests.factor

@@ -0,0 +1,20 @@
+USING: accessors continuations db2.pools sqlite.db2
+sqlite.db2.connections destructors io.directories io.files
+io.files.temp kernel math namespaces tools.test ;
+IN: db2.pools.tests
+
+{ 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

basis/db2/pools/pools.factor

@@ -1,20 +1,19 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays namespaces sequences continuations
-io.pools db fry db.private ;
-IN: db.pools
+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 ;
+        swap >>db ; inline
 
 : with-db-pool ( db quot -- )
     [ <db-pool> ] dip with-pool ; inline
 
-M: db-pool make-connection ( pool -- conn )
-    db>> db-open ;
+M: db-pool make-connection ( pool -- connection )
+    db>> db>db-connection ;
 
 : with-pooled-db ( pool quot -- )
     '[ db-connection _ with-variable ] with-pooled-connection ; inline

basis/db2/queries/authors.txt

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

basis/db2/queries/queries-tests.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2 db2.debug db2.queries debugger kernel sequences
+tools.test ;
+IN: db2.queries.tests
+
+: test-table-exists ( -- )
+    [ "drop table table_omg;" sql-command ] try
+    [ f ] [ "table_omg" table-exists? ] unit-test
+    [ ] [ "create table table_omg(id integer);" sql-command ] unit-test
+    [ t ] [ "table_omg" table-exists? ] unit-test
+    [ t ] [ "default_person" table-columns empty? not ] unit-test
+
+    [ ] [ "factor-test" database-tables drop ] unit-test
+    [ ] [ databases drop ] unit-test ;
+
+[ test-table-exists ] test-dbs

basis/db2/queries/queries.factor

@@ -0,0 +1,103 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ascii classes.tuple
+combinators.short-circuit db2 db2.connections db2.statements
+db2.types db2.utils fry kernel sequences strings ;
+IN: db2.queries
+
+TUPLE: sql-object ;
+TUPLE: sql-column ;
+
+HOOK: current-db-name db-connection ( -- string )
+HOOK: sanitize-string db-connection ( string -- string )
+
+HOOK: databases-statement db-connection ( -- statement )
+HOOK: database-tables-statement db-connection ( database -- statement )
+HOOK: database-table-columns-statement db-connection ( database table -- sequence )
+
+HOOK: sql-object-class db-connection ( -- tuple-class )
+HOOK: sql-column-class db-connection ( -- tuple-class )
+
+ERROR: unsafe-sql-string string ;
+
+M: object sanitize-string
+    dup [ { [ Letter? ] [ digit? ] [ "_" member? ] } 1|| ] all?
+    [ unsafe-sql-string ] unless ;
+
+<PRIVATE
+GENERIC: >sql-name* ( object -- string )
+M: tuple-class >sql-name* name>> sql-name-replace ;
+M: string >sql-name* sql-name-replace ;
+PRIVATE>
+
+: >sql-name ( object -- string ) >sql-name* sanitize-string ;
+
+: information-schema-select-sql ( string -- string' )
+    "SELECT * FROM information_schema." " " surround ;
+
+: database-table-schema-select-sql ( string -- string )
+    information-schema-select-sql
+    "WHERE
+            table_catalog=$1 AND
+            table_name=$2 AND
+            table_schema='public'" append ;
+
+: database-schema-select-sql ( string -- string )
+    information-schema-select-sql
+    "WHERE
+            table_catalog=$1 AND
+            table_schema='public'" append ;
+
+M: object database-tables-statement
+    [ <statement> ] dip
+        1array >>in
+        "tables" database-schema-select-sql >>sql ;
+
+M: object databases-statement
+    <statement>
+        "SELECT DISTINCT table_catalog
+        FROM information_schema.tables
+        WHERE
+            table_schema='public'" >>sql ;
+
+M: object database-table-columns-statement ( database table -- sequence )
+    [ <statement> ] 2dip
+        2array >>in
+        "columns" database-table-schema-select-sql >>sql ;
+
+: >sql-objects ( statement -- sequence' )
+    sql-query
+    sql-object-class '[ _ slots>tuple ] map ;
+
+: >sql-columns ( statement -- sequence' )
+    sql-query
+    sql-column-class '[ _ slots>tuple ] map ;
+
+: database-tables ( database -- sequence )
+    database-tables-statement >sql-objects ;
+
+: current-tables ( -- sequence )
+    current-db-name database-tables ;
+
+: table-names ( sequence -- strings )
+    [ table-name>> ] map ;
+
+: database-table-names ( database -- sequence )
+    database-tables table-names ;
+
+: current-table-names ( -- sequence )
+    current-db-name database-table-names ;
+
+: table-exists? ( table -- ? ) current-table-names member? ;
+
+: database-table-columns ( database table -- sequence )
+    database-table-columns-statement >sql-columns ;
+
+: table-columns ( table -- sequence )
+    [ current-db-name ] dip database-table-columns ;
+
+: databases ( -- sequence )
+    databases-statement sql-query concat ;
+
+! [ "select nspname from pg_catalog.pg_namespace" sql-query ] with-dummy-postgresql
+! [ "select schema_name from information_schema.schemata" sql-query ] with-dummy-postgresql

basis/db2/query-objects/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/query-objects/query-objects-tests.factor

@@ -0,0 +1,545 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.binders db2.connections
+postgresql.db2.connections
+postgresql.db2.connections.private db2.query-objects
+sqlite.db2.connections db2.statements db2.types namespaces
+tools.test ;
+IN: db2.query-objects.tests
+
+! TOC - table ordinal column
+
+! Test expansion of insert
+TUPLE: qdog id age ;
+
+! Test joins
+TUPLE: user id name ;
+TUPLE: address id user-id street city state zip ;
+
+[
+T{ statement
+    { sql "INSERT INTO qdog (id) VALUES(?);" }
+    { in
+        {
+            T{ in-binder
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out V{ } }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection [
+        T{ insert
+            { in
+                {
+                    T{ in-binder
+                        { toc TOC{ "qdog" "0" "id" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+[
+T{ statement
+    { sql "INSERT INTO qdog (id) VALUES($1);" }
+    { in
+        {
+            T{ in-binder
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out V{ } }
+    { errors V{ } }
+}
+] [
+    T{ postgresql-db-connection } db-connection
+    [
+        T{ insert
+            { in
+                {
+                    T{ in-binder
+                        { toc TOC{ "qdog" "0" "id" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+
+
+
+
+[
+T{ statement
+    { sql "SELECT qdog0.id, qdog0.age FROM qdog AS qdog0 WHERE qdog0.age = ?;" }
+    { in
+        {
+            T{ equal-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out
+        {
+            T{ out-binder
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { from { TO{ "qdog" "0" } } }
+            { out
+                {
+                    T{ out-binder
+                        { toc TOC{ "qdog" "0" "id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                    }
+                }
+            }
+            { in
+                {
+                    T{ equal-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+
+
+[
+T{ statement
+    { sql "UPDATE qdog SET age = ? WHERE age = ?;" }
+    { in
+        {
+            T{ equal-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+                { value 1 }
+            }
+            T{ equal-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out V{ } }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ update
+            { in
+                {
+                    T{ equal-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                        { value 1 }
+                    }
+                }
+            }
+            { where
+                {
+                    T{ equal-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+[
+T{ statement
+    { sql "DELETE FROM qdog WHERE age = ?;" }
+    { in
+        {
+            T{ equal-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out V{ } }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ delete
+            { where
+                {
+                    T{ equal-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+
+[
+T{ statement
+    { sql "SELECT COUNT(qdog0.id) FROM qdog AS qdog0;" }
+    { in { } }
+    { out
+        {
+            T{ count-function
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { from { TO{ "qdog" "0" } } }
+            { out
+                {
+                    T{ count-function
+                        { toc TOC{ "qdog" "0" "id" } }
+                        { type INTEGER }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+
+
+[
+T{ statement
+    { sql "SELECT COUNT(qdog0.id) FROM qdog AS qdog0 WHERE qdog0.age = ?;" }
+    { in
+        {
+            T{ equal-binder
+                { toc TOC{ "qdog" "0" "age" } }
+                { type INTEGER }
+                { value 0 }
+            }
+        }
+    }
+    { out
+        {
+            T{ count-function
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { from { TO{ "qdog" "0" } } }
+            { out
+                {
+                    T{ count-function
+                        { toc TOC{ "qdog" "0" "id" } }
+                        { type INTEGER }
+                    }
+                }
+            }
+            { in
+                {
+                    T{ equal-binder
+                        { toc TOC{ "qdog" "0" "age" } }
+                        { type INTEGER }
+                        { value 0 }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+[
+T{ statement
+    { sql
+        "SELECT user0.id, user0.name, address0.id, address0.user_id, address0.street, address0.city, address0.zip FROM user AS user0 LEFT JOIN address AS address0 ON user0.id = address0.user_id;"
+    }
+    { in { } }
+    { out
+        {
+            T{ out-binder
+                { toc TOC{ "user" "0" "id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "user" "0" "name" } }
+                { type VARCHAR }
+            }
+            T{ out-binder
+                { toc TOC{ "address" "0" "id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "address" "0" "user_id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "address" "0" "street" } }
+                { type VARCHAR }
+            }
+            T{ out-binder
+                { toc TOC{ "address" "0" "city" } }
+                { type VARCHAR }
+            }
+            T{ out-binder
+                { toc TOC{ "address" "0" "zip" } }
+                { type INTEGER }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { out
+                {
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "name" } }
+                        { type VARCHAR }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "address" "0" "id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "address" "0" "user_id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "address" "0" "street" } }
+                        { type VARCHAR }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "address" "0" "city" } }
+                        { type VARCHAR }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "address" "0" "zip" } }
+                        { type INTEGER }
+                    }
+                }
+            }
+            { from { TO{ "user" "0" } } }
+            { join
+                {
+                    T{ join-binder
+                        { toc1 TOC{ "user" "0" "id" } }
+                        { toc2 TOC{ "address" "0" "user_id" } }
+                    }
+                }
+            }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+
+[
+T{ statement
+    { sql
+        "SELECT user0.id, user0.name FROM user AS user0 WHERE (user0.id = ? AND user0.id = ?);"
+    }
+    { in
+        {
+            T{ equal-binder
+                { toc TOC{ "user" "0" "id" } }
+                { type INTEGER }
+                { value 0 }
+            }
+            T{ equal-binder
+                { toc TOC{ "user" "0" "id" } }
+                { type INTEGER }
+                { value 1 }
+            }
+        }
+    }
+    { out
+        {
+            T{ out-binder
+                { toc TOC{ "user" "0" "id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "user" "0" "name" } }
+                { type VARCHAR }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { in
+                {
+                    T{ and-binder
+                        { binders
+                            {
+                                T{ equal-binder
+                                    { toc TOC{ "user" "0" "id" } }
+                                    { type INTEGER }
+                                    { value 0 }
+                                }
+                                T{ equal-binder
+                                    { toc TOC{ "user" "0" "id" } }
+                                    { type INTEGER }
+                                    { value 1 }
+                                }
+                            }
+                        }
+                    }
+                }
+            }
+            { out
+                {
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "name" } }
+                        { type VARCHAR }
+                    }
+                }
+            }
+            { from { TO{ "user" "0" } } }
+        } query-object>statement
+    ] with-variable
+] unit-test
+
+[
+T{ statement
+    { sql
+        "SELECT user0.id, user0.name FROM user AS user0 WHERE (qdog0.id > ? AND qdog0.id <= ?);"
+    }
+    { in
+        {
+            T{ greater-than-binder
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+                { value 0 }
+            }
+            T{ less-than-equal-binder
+                { toc TOC{ "qdog" "0" "id" } }
+                { type INTEGER }
+                { value 5 }
+            }
+        }
+    }
+    { out
+        {
+            T{ out-binder
+                { toc TOC{ "user" "0" "id" } }
+                { type INTEGER }
+            }
+            T{ out-binder
+                { toc TOC{ "user" "0" "name" } }
+                { type VARCHAR }
+            }
+        }
+    }
+    { errors V{ } }
+}
+] [
+    T{ sqlite-db-connection } db-connection
+    [
+        T{ select
+            { in
+                {
+                    T{ and-binder
+                        { binders
+                            {
+                                T{ greater-than-binder
+                                    { toc TOC{ "qdog" "0" "id" } }
+                                    { type INTEGER }
+                                    { value 0 }
+                                }
+                                T{ less-than-equal-binder
+                                    { toc TOC{ "qdog" "0" "id" } }
+                                    { type INTEGER }
+                                    { value 5 }
+                                }
+                            }
+                        }
+                    }
+                }
+            }
+            { out
+                {
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "id" } }
+                        { type INTEGER }
+                    }
+                    T{ out-binder
+                        { toc TOC{ "user" "0" "name" } }
+                        { type VARCHAR }
+                    }
+                }
+            }
+            { from { TO{ "user" "0" } } }
+        } query-object>statement
+    ] with-variable
+] unit-test

basis/db2/query-objects/query-objects.factor

@@ -0,0 +1,212 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators constructors db2.binders
+db2.statements db2.utils kernel make math namespaces sequences
+sequences.deep sets strings ;
+IN: db2.query-objects
+
+TUPLE: query reconstructor ;
+
+TUPLE: insert < query { in sequence } ;
+CONSTRUCTOR: <insert> insert ( -- insert ) ;
+
+TUPLE: update < query { in sequence } { where sequence } ;
+CONSTRUCTOR: <update> update ( -- update ) ;
+
+TUPLE: delete < query { where sequence } ;
+CONSTRUCTOR: <delete> delete ( -- delete ) ;
+
+TUPLE: select < query
+    { in sequence }
+    { out sequence }
+    { from sequence }
+    { join sequence }
+    { offset integer }
+    { limit integer } ;
+CONSTRUCTOR: <select> select ( -- select ) ;
+
+GENERIC: >table-as ( obj -- string )
+GENERIC: >table-name ( in -- string )
+GENERIC: >column-name ( in -- string )
+GENERIC: >qualified-column-name ( in -- string )
+
+M: binder >table-as ( obj -- string )
+    toc>> >table-as ;
+
+M: string >table-as ( string -- string ) ;
+
+M: table-ordinal >table-as ( obj -- string )
+    { table-name>> table-name>> table-ordinal>> } slots
+    append " AS " glue ;
+
+M: in-binder >table-name toc>> table-name>> ;
+M: out-binder >table-name toc>> table-name>> ;
+
+M: in-binder >column-name toc>> column-name>> ;
+M: out-binder >column-name toc>> column-name>> ;
+
+M: count-function >column-name toc>> column-name>> "COUNT(" ")" surround ;
+M: sum-function >column-name toc>> column-name>> "SUM(" ")" surround ;
+M: average-function >column-name toc>> column-name>> "AVG(" ")" surround ;
+M: min-function >column-name toc>> column-name>> "MIN(" ")" surround ;
+M: max-function >column-name toc>> column-name>> "MAX(" ")" surround ;
+M: first-function >column-name toc>> column-name>> "FIRST(" ")" surround ;
+M: last-function >column-name toc>> column-name>> "LAST(" ")" surround ;
+
+: toc>full-name ( toc -- string )
+    { table-name>> table-ordinal>> column-name>> } slots
+    [ append ] dip "." glue ;
+
+M: table-ordinal-column >qualified-column-name toc>full-name ;
+M: in-binder >qualified-column-name toc>> toc>full-name ;
+M: out-binder >qualified-column-name toc>> toc>full-name ;
+M: and-binder >qualified-column-name
+    binders>> [ toc>> toc>full-name ] map ", " join "(" ")" surround ;
+
+M: count-function >qualified-column-name
+    toc>> toc>full-name "COUNT(" ")" surround ;
+M: sum-function >qualified-column-name
+    toc>> toc>full-name "SUM(" ")" surround ;
+M: average-function >qualified-column-name
+    toc>> toc>full-name "AVG(" ")" surround ;
+M: min-function >qualified-column-name
+    toc>> toc>full-name "MIN(" ")" surround ;
+M: max-function >qualified-column-name
+    toc>> toc>full-name "MAX(" ")" surround ;
+M: first-function >qualified-column-name
+    toc>> toc>full-name "FIRST(" ")" surround ;
+M: last-function >qualified-column-name
+    toc>> toc>full-name "LAST(" ")" surround ;
+
+GENERIC: binder-operator ( obj -- string )
+M: equal-binder binder-operator drop " = " ;
+M: not-equal-binder binder-operator drop " <> " ;
+M: less-than-binder binder-operator drop " < " ;
+M: less-than-equal-binder binder-operator drop " <= " ;
+M: greater-than-binder binder-operator drop " > " ;
+M: greater-than-equal-binder binder-operator drop " >= " ;
+
+GENERIC: >bind-pair ( obj -- string )
+: object-bind-pair ( obj -- string )
+    [ >column-name next-bind-index ] [ binder-operator ] bi glue ;
+: special-bind-pair ( obj join-string -- string )
+    [ binders>> [ object-bind-pair ] map ] dip join "(" ")" surround ;
+M: object >bind-pair object-bind-pair ;
+M: and-binder >bind-pair " AND " special-bind-pair ;
+M: or-binder >bind-pair " OR " special-bind-pair ;
+
+: >column/bind-pairs ( seq -- string )
+    [ >bind-pair ] map ", " join ;
+
+GENERIC: >qualified-bind-pair ( obj -- string )
+: qualified-object-bind-pair ( obj -- string )
+    [ >qualified-column-name next-bind-index ] [ binder-operator ] bi glue ;
+: qualified-special-bind-pair ( obj join-string -- string )
+    [ binders>> [ qualified-object-bind-pair ] map ] dip join "(" ")" surround ;
+M: object >qualified-bind-pair qualified-object-bind-pair ;
+M: and-binder >qualified-bind-pair " AND " qualified-special-bind-pair ;
+M: or-binder >qualified-bind-pair " OR " qualified-special-bind-pair ;
+
+: >qualified-column/bind-pairs ( seq -- string )
+    [ >qualified-bind-pair ] map " AND " join ;
+
+: >table-names ( in -- string )
+    [ >table-name ] map members ", " join ;
+
+: >column-names ( in -- string )
+    [ >column-name ] map ", " join ;
+
+: >qualified-column-names ( in -- string )
+    [ >qualified-column-name ] map ", " join ;
+
+: >bind-indices ( in -- string )
+    length [ next-bind-index ] replicate ", " join ;
+
+GENERIC: query-object>statement* ( statement query-object -- statement )
+
+GENERIC: flatten-binder ( obj -- obj' )
+M: in-binder flatten-binder ;
+M: and-binder flatten-binder binders>> [ flatten-binder ] map ;
+M: or-binder flatten-binder binders>> [ flatten-binder ] map ;
+
+: flatten-in ( seq -- seq' )
+    [
+        [ flatten-binder , ] each
+    ] { } make flatten ;
+
+M: insert query-object>statement*
+    [ "INSERT INTO " add-sql ] dip {
+        [ in>> first >table-name add-sql " (" add-sql ]
+        [ in>> >column-names add-sql ") VALUES(" add-sql ]
+        [ in>> >bind-indices add-sql ");" add-sql ]
+        [ in>> flatten-in >>in ]
+    } cleave ;
+
+: seq>where ( statement seq -- statement )
+    [
+        [ " WHERE " add-sql ] dip
+        >column/bind-pairs add-sql
+    ] unless-empty ;
+
+: qualified-seq>where ( statement seq -- statement )
+    [
+        [ " WHERE " add-sql ] dip
+        >qualified-column/bind-pairs add-sql
+    ] unless-empty ;
+
+: renamed-table-names ( seq -- string )
+    [ >table-as ] map ", " join ;
+
+: select-from ( select -- string )
+    from>> ?1array renamed-table-names ;
+
+GENERIC: >join-string ( join-binder -- string )
+
+M: join-binder >join-string
+    [ toc2>> >table-as " LEFT JOIN " " ON " surround ]
+    [ toc1>> >qualified-column-name ]
+    [ toc2>> >qualified-column-name ]
+    ! [ toc2>> { table-name>> column-name>> } slots "." glue ]
+    tri " = " glue append ;
+
+: select-join ( select -- string )
+    join>> [
+        ""
+    ] [
+        [ >join-string ] map ", " join
+    ] if-empty ;
+
+M: select query-object>statement*
+    [ "SELECT " add-sql ] dip {
+        [ out>> >qualified-column-names add-sql " FROM " add-sql ]
+        [ select-from add-sql ]
+        [ select-join add-sql ]
+        [ in>> qualified-seq>where ";" add-sql ]
+        [ out>> >>out ]
+        [ in>> flatten-in >>in ]
+    } cleave ;
+
+M: update query-object>statement*
+    [ "UPDATE " add-sql ] dip {
+        [ in>> >table-names add-sql " SET " add-sql ]
+        [ in>> >column/bind-pairs add-sql ]
+        [ where>> seq>where ";" add-sql ]
+        [ { in>> where>> } slots append flatten-in >>in ]
+    } cleave ;
+
+M: delete query-object>statement*
+    [ "DELETE FROM " add-sql ] dip {
+        [ where>> >table-names add-sql ]
+        [ where>> seq>where ";" add-sql ]
+        [ where>> flatten-in >>in ]
+    } cleave ;
+
+: query-object>statement ( object1 -- object2 )
+    [
+        init-bind-index
+        [ <statement> ] dip {
+            [ query-object>statement* ]
+            [ reconstructor>> >>reconstructor ]
+        } cleave
+        ! normalize-fql
+    ] with-scope ;

basis/db2/result-sets/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/result-sets/result-sets.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.binders db2.connections db2.types
+destructors fry kernel math.ranges namespaces sequences ;
+IN: db2.result-sets
+
+TUPLE: result-set handle sql in out n max ;
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+GENERIC# column 2 ( result-set column type -- sql )
+GENERIC: get-type ( binder/word -- type )
+HOOK: statement>result-set db-connection ( statement -- result-set )
+
+: init-result-set ( result-set -- result-set )
+    dup #rows >>max
+    0 >>n ; inline
+
+: new-result-set ( query handle class -- result-set )
+    new
+        swap >>handle
+        swap {
+            [ sql>> >>sql ]
+            [ in>> >>in ]
+            [ out>> >>out ]
+        } cleave ; inline
+
+ERROR: result-set-length-mismatch result-set #columns out-length ;
+
+: validate-result-set ( result-set -- result-set )
+    dup [ #columns ] [ out>> length ] bi 2dup = [
+        2drop
+    ] [
+        result-set-length-mismatch
+    ] if ;
+
+: sql-row ( result-set -- seq )
+    [ #columns iota ] [ out>> ] [ ] tri over empty? [
+        nip
+        '[ [ _ ] dip VARCHAR column ] map
+    ] [
+        validate-result-set
+        '[ [ _ ] 2dip get-type column ] 2map
+    ] if ;
+
+M: sql-type get-type ;
+
+M: out-binder get-type type>> ;
+
+M: out-binder-low get-type type>> ;
+
+: result-set-each ( statement quot: ( statement -- ) -- )
+    over more-rows?
+    [ [ call ] 2keep over advance-row result-set-each ]
+    [ 2drop ] if ; inline recursive
+
+: result-set-map ( statement quot -- sequence )
+    collector [ result-set-each ] dip { } like ; inline
+
+: statement>result-sequence ( statement -- sequence )
+    statement>result-set
+    [ [ sql-row ] result-set-map ] with-disposal ;

basis/db2/statements/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/statements/statements.factor

@@ -0,0 +1,77 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations db2.connections db2.errors
+db2.result-sets db2.utils destructors fry kernel sequences math
+vectors ;
+IN: db2.statements
+
+TUPLE: statement handle sql in out after
+retries errors retry-quotation reconstructor ;
+
+: normalize-statement ( statement -- statement )
+    [ object>vector ] change-in
+    [ object>vector ] change-out ; inline
+
+: initialize-statement ( statement -- statement )
+    V{ } clone >>in
+    V{ } clone >>out
+    V{ } clone >>errors ; inline
+ 
+: <sql> ( string -- statement )
+    statement new
+        swap >>sql
+        initialize-statement ; inline
+
+: <statement> ( -- statement )
+    statement new
+        initialize-statement ; inline
+
+HOOK: next-bind-index db-connection ( -- string )
+HOOK: init-bind-index db-connection ( -- )
+
+: add-sql ( statement sql -- statement )
+    '[ _ "" append-as ] change-sql ;
+
+GENERIC: add-in ( statement object -- statement )
+GENERIC: add-out ( statement object -- statement )
+
+: in-vector ( statmenet object -- statement object statement )
+    over [ >vector ] change-in in>> ;
+
+: out-vector ( statmenet object -- statement object statement )
+    over [ >vector ] change-out out>> ;
+
+M: sequence add-in in-vector push-all ;
+M: object add-in in-vector push ;
+M: sequence add-out out-vector push-all ;
+M: object add-out out-vector push ;
+
+HOOK: prepare-statement* db-connection ( statement -- statement' )
+HOOK: dispose-statement db-connection ( statement -- )
+HOOK: bind-sequence db-connection ( statement -- )
+HOOK: reset-statement db-connection ( statement -- statement' )
+
+ERROR: no-database-in-scope ;
+
+M: statement dispose dispose-statement ;
+M: f dispose-statement no-database-in-scope ;
+M: object reset-statement ;
+
+: with-sql-error-handler ( quot -- )
+    [ dup sql-error? [ parse-sql-error ] when rethrow ] recover ; inline
+
+: prepare-statement ( statement -- statement )
+    [ dup handle>> [ prepare-statement* ] unless ] with-sql-error-handler ;
+
+: (run-after-setters) ( tuple statement -- )
+    after>> [
+        [ value>> ] [ setter>> ] bi
+        call( obj val -- obj ) drop
+    ] with each ;
+
+: run-after-setters ( tuple statement -- )
+    dup sequence? [
+        [ (run-after-setters) ] with each
+    ] [
+        (run-after-setters)
+    ] if ;

basis/db2/statements/tests/tests.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations db2 db2.debug db2.errors
+db2.result-sets db2.statements db2.types kernel multiline
+tools.test ;
+IN: db2.statements.tests
+
+{ 1 0 } [ [ drop ] result-set-each ] must-infer-as
+{ 1 1 } [ [ ] result-set-map ] must-infer-as
+
+: create-computer-table ( -- )
+    [ "drop table computer;" sql-command ] ignore-errors
+
+    ! [ "drop table computer;" sql-command ]
+    ! [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with
+
+    [ "drop table computer;" sql-command ] must-fail
+
+    [ ] [
+        "create table computer(name varchar, os varchar, version integer);"
+        sql-command
+    ] unit-test ;
+
+: test-sql-command ( -- )
+    create-computer-table
+
+    [ ] [
+        "insert into computer (name, os) values('rocky', 'mac');"
+        sql-command
+    ] unit-test
+
+    [ ] [
+        <statement>
+            "insert into computer (name, os) values('vio', 'opp');" >>sql
+        sql-command
+    ] unit-test
+
+    [ { { "rocky" "mac" } { "vio" "opp" } } ]
+    [
+        <statement>
+            "select name, os from computer;" >>sql
+        sql-query
+    ] unit-test
+
+    ! [ "insert into" sql-command ] [ sql-syntax-error? ] must-fail-with
+
+    ! [ "selectt" sql-query drop ] [ sql-syntax-error? ] must-fail-with
+
+    [ "drop table default_person" sql-command ] ignore-errors
+
+    [ ] [
+        <statement>
+            "create table default_person(id serial primary key, name text, birthdate timestamp, email text, homepage text)" >>sql
+        sql-command
+    ] unit-test ;
+
+[ test-sql-command ] test-dbs

basis/db2/tester/tester.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors concurrency.combinators db2 db2.pools db2.types
+fry io io.files.temp kernel math math.parser multiline
+namespaces postgresql.db2 prettyprint random sequences
+sqlite.db2 system threads tools.test ;
+IN: db2.tester
+
+/*
+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+ }
+} make-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+ }
+} make-persistent
+
+: test-1-tuple ( -- tuple )
+    f 100 random 100 random 100 random [ number>string ] tri@
+    test-1 boa ;
+
+: db-tester ( test-db -- )
+    [
+        [
+            test-1 ensure-table
+            test-2 ensure-table
+        ] with-db
+    ] [
+        10 iota [
+            drop
+            10 [
+                dup [
+                    test-1-tuple 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 iota [
+                10 [
+                    test-1-tuple insert-tuple yield
+                ] times
+            ] parallel-each
+        ] with-pooled-db
+    ] bi ;
+*/

basis/db2/transactions/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/transactions/transactions.factor

@@ -0,0 +1,26 @@
+! 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

basis/db2/types/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/types/types.factor

@@ -0,0 +1,98 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays classes.mixin classes.parser classes.singleton
+combinators db2.connections kernel lexer sequences ;
+IN: db2.types
+
+HOOK: sql-type>string db-connection ( type -- string )
+HOOK: sql-create-type>string db-connection ( type -- string )
+HOOK: sql-modifiers>string db-connection ( modifiers -- string )
+HOOK: db-type>fql-type db-connection ( name -- table-schema )
+
+HOOK: persistent-type-hashtable db-connection ( -- hashtable )
+
+MIXIN: sql-type
+MIXIN: sql-modifier
+MIXIN: sql-primary-key
+
+INSTANCE: sql-primary-key sql-modifier
+
+<<
+
+: define-sql-instance ( word mixin -- )
+    over define-singleton-class
+    add-mixin-instance ;
+
+: define-sql-type ( word -- )
+    sql-type define-sql-instance ;
+
+: define-sql-modifier ( word -- )
+    sql-modifier define-sql-instance ;
+
+: define-primary-key ( word -- )
+    [ define-sql-type ]
+    [ sql-primary-key add-mixin-instance ] bi ;
+
+SYNTAX: SQL-TYPE:
+    scan-new-class define-sql-type ;
+
+SYNTAX: SQL-TYPES:
+    ";" parse-tokens
+    [ create-class-in define-sql-type ] each ;
+
+SYNTAX: PRIMARY-KEY-TYPE:
+    scan-new-class define-primary-key ;
+
+SYNTAX: PRIMARY-KEY-TYPES:
+    ";" parse-tokens
+    [ create-class-in define-primary-key ] each ;
+
+SYNTAX: SQL-MODIFIER:
+    scan-new-class define-sql-modifier ;
+
+SYNTAX: SQL-MODIFIERS:
+    ";" parse-tokens
+    [ create-class-in define-sql-modifier ] each ;
+
+>>
+
+SQL-TYPES:
+    INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+    DOUBLE REAL
+    BOOLEAN
+    TEXT CHARACTER VARCHAR DATE
+    TIME DATETIME TIMESTAMP
+    BLOB FACTOR-BLOB
+    URL ;
+
+! Delete +not-null+
+SQL-MODIFIERS: SERIAL AUTOINCREMENT UNIQUE DEFAULT NOT-NULL NULL
++on-update+ +on-delete+ +restrict+ +cascade+ +set-null+ +set-default+
++not-null+ +system-random-generator+ ;
+
+PRIMARY-KEY-TYPES: +db-assigned-key+
+    +user-assigned-key+
+    +random-key+
+    +primary-key+ ;
+
+INSTANCE: +user-assigned-key+ sql-modifier
+INSTANCE: +db-assigned-key+ sql-modifier
+
+SYMBOL: IGNORE
+
+ERROR: no-sql-type name ;
+ERROR: no-sql-modifier name ;
+
+: ensure-sql-type ( object -- object )
+    dup sql-type? [ no-sql-type ] unless ;
+
+: ensure-sql-modifier ( object -- object )
+    dup sql-modifier? [ no-sql-modifier ] unless ;
+
+: persistent-type>sql-type ( type -- type' )
+    dup array? [ first ] when
+    {
+        { +db-assigned-key+ [ INTEGER ] }
+        { +random-key+ [ INTEGER ] }
+        [ ]
+    } case ;

basis/db2/utils/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db2/utils/utils.factor

@@ -0,0 +1,121 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays assocs classes
+classes.algebra classes.tuple combinators
+combinators.short-circuit fry kernel libc locals macros math
+math.order math.parser quotations sequences sequences.private
+slots slots.private strings vectors words ;
+IN: db2.utils
+
+SLOT: slot-name
+
+MACRO: slots ( seq -- quot )
+    [ 1quotation ] map '[ _ cleave ] ;
+
+: subclass? ( class1 class2 -- ? )
+    { [ class<= ] [ drop tuple-class? ] } 2&& ;
+
+: quote-sql-name ( string -- string' ) "\"" dup surround ; 
+
+: sql-name-replace ( string -- string' )
+    H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } } substitute ;
+
+: malloc-byte-array/length ( byte-array -- alien length )
+    [ malloc-byte-array &free ] [ length ] bi ;
+
+: object>vector ( obj -- vector )
+    dup sequence? [ >vector ] [ 1vector ] if ;
+
+: trim-double-quotes ( string -- string' )
+    [ CHAR: " = ] trim ;
+
+: ?when ( object quot -- object' ) dupd when ; inline
+
+: ?1array ( obj -- array )
+    dup { [ array? ] [ vector? ] } 1|| [ 1array ] unless ; inline
+
+: ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline
+
+: ?second ( sequence -- object/f ) 1 swap ?nth ;
+: ?third ( sequence -- object/f ) 2 swap ?nth ;
+
+: ?first2 ( sequence -- object1/f object2/f )
+    [ ?first ] [ ?second ] bi ;
+
+: ?first3 ( sequence -- object1/f object2/f object3/f )
+    [ ?first ] [ ?second ] [ ?third ] tri ;
+
+:: 2interleave ( seq1 seq2 between: ( -- ) quot: ( obj1 obj2 -- ) -- )
+    { [ seq1 empty? ] [ seq2 empty? ] } 0|| [
+        seq1 seq2 [ first-unsafe ] bi@ quot call
+        seq1 seq2 [ rest-slice ] bi@
+        2dup { [ nip empty? ] [ drop empty? ] } 2|| [
+            2drop
+        ] [
+            between call
+            between quot 2interleave
+        ] if
+    ] unless ; inline recursive
+
+: assoc-with ( object sequence quot -- obj curry )
+    swapd [ [ -rot ] dip  call ] 2curry ; inline
+
+: ?number>string ( n/string -- string )
+    dup number? [ number>string ] when ;
+
+ERROR: no-accessor name ;
+
+: lookup-accessor ( string -- accessor )
+    dup "accessors" lookup-word [ nip ] [ no-accessor ] if* ;
+
+: lookup-getter ( string -- accessor )
+    ">>" append lookup-accessor ;
+
+: lookup-setter ( string -- accessor )
+    ">>" prepend lookup-accessor ;
+
+ERROR: string-expected object ;
+
+: ensure-string ( object -- string )
+    dup string? [ string-expected ] unless ;
+
+ERROR: length-expected-range seq from to ;
+: ensure-length-range ( seq from to -- seq )
+    3dup [ length ] 2dip between? [
+        2drop
+    ] [
+        length-expected-range
+    ] if ;
+
+ERROR: length-expected seq length ;
+: ensure-length ( seq length -- seq )
+    2dup [ length ] dip = [
+        drop
+    ] [
+        length-expected
+    ] if ;
+
+: new-filled-tuple ( class values setters -- tuple )
+    [ new ] 2dip [ call( tuple obj -- tuple ) ] 2each ;
+
+ERROR: no-slot name specs ;
+
+: offset-of-slot ( string tuple -- n )
+    class-of superclasses-of [ "slots" word-prop ] map concat
+    2dup slot-named [ 2nip offset>> ] [ no-slot ] if* ;
+
+: get-slot-named ( name tuple -- value )
+    [ nip ] [ offset-of-slot ] 2bi slot ;
+
+: set-slot-named ( value name tuple -- )
+    [ nip ] [ offset-of-slot ] 2bi set-slot ;
+
+: change-slot-named ( name tuple quot -- tuple )
+    [ [ get-slot-named ] dip call( obj -- obj' ) ]
+    [ drop [ set-slot-named ] keep ] 3bi ;
+
+: filter-slots ( tuple specs -- specs' )
+    [
+        slot-name>> swap get-slot-named
+        ! dup double-infinite-interval? [ drop f ] when
+    ] with filter ;

basis/furnace/alloy/alloy-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax db ;
+USING: help.markup help.syntax db2.connections ;
 IN: furnace.alloy
 
 HELP: init-furnace-tables

basis/furnace/alloy/alloy.factor

@@ -1,13 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences db.tuples timers calendar db fry
-furnace.db
-furnace.cache
-furnace.asides
-furnace.sessions
-furnace.conversations
-furnace.auth.providers
-furnace.auth.login.permits ;
+USING: calendar db2.connections fry furnace.asides
+furnace.auth.login.permits furnace.auth.providers furnace.cache
+furnace.conversations furnace.db furnace.sessions kernel
+orm.tuples sequences timers ;
 IN: furnace.alloy
 
 CONSTANT: state-classes { session aside conversation permit }

basis/furnace/asides/asides.factor

@@ -1,13 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel sequences accessors hashtables
-urls db.types db.tuples math.parser fry logging combinators
-html.templates.chloe.syntax
-http http.server http.server.filters http.server.redirection
-furnace.cache
-furnace.sessions
-furnace.utilities
-furnace.redirection ;
+USING: accessors assocs combinators db2.types fry furnace.cache
+furnace.redirection furnace.sessions furnace.utilities
+hashtables html.templates.chloe.syntax http http.server
+http.server.filters http.server.redirection kernel logging
+math.parser namespaces orm.persistent orm.tuples sequences urls ;
 IN: furnace.asides
 
 TUPLE: aside < server-state
@@ -16,12 +13,11 @@ session method url post-data ;
 : <aside> ( id -- aside )
     aside new-server-state ;
 
-aside "ASIDES" {
-    { "session" "SESSION" BIG-INTEGER +not-null+ }
-    { "method" "METHOD" { VARCHAR 10 } }
-    { "url" "URL" URL }
-    { "post-data" "POST_DATA" FACTOR-BLOB }
-} define-persistent
+PERSISTENT: { aside "ASIDES" }
+    { "session" BIG-INTEGER +not-null+ }
+    { "method" VARCHAR }
+    { "url" URL }
+    { "post-data" FACTOR-BLOB } ;
 
 CONSTANT: aside-id-key "__a"
 

basis/furnace/auth/features/deactivate-user/deactivate-user.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors db db.tuples urls
+USING: kernel assocs namespaces accessors urls
 http.server.dispatchers
 furnace.asides
 furnace.actions

basis/furnace/auth/login/permits/permits.factor

@@ -1,13 +1,14 @@
-USING: accessors namespaces kernel combinators.short-circuit
-db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
+
+USING: accessors combinators.short-circuit db2.types
+furnace.auth furnace.cache furnace.sessions kernel namespaces
+orm.persistent orm.tuples ;
 IN: furnace.auth.login.permits
 
 TUPLE: permit < server-state session uid ;
 
-permit "PERMITS" {
-    { "session" "SESSION" BIG-INTEGER +not-null+ }
-    { "uid" "UID" { VARCHAR 255 } +not-null+ }
-} define-persistent
+PERSISTENT: { permit "permits" }
+    { "session" BIG-INTEGER +not-null+ }
+    { "uid" { VARCHAR 255 } +not-null+ } ;
 
 : touch-permit ( permit -- )
     realm get touch-state ;

basis/furnace/auth/providers/db/db-tests.factor

@@ -1,11 +1,8 @@
-USING: furnace.actions
-furnace.auth
-furnace.auth.login
-furnace.auth.providers
-furnace.auth.providers.db tools.test
-namespaces db db.sqlite db.tuples continuations
-io.files io.files.temp io.directories accessors kernel
-sequences system ;
+USING: accessors continuations db2.connections furnace.actions
+furnace.auth furnace.auth.login furnace.auth.providers
+furnace.auth.providers.db io.directories io.files io.files.temp
+kernel namespaces orm.tuples sequences sqlite.db2 system
+tools.test ;
 IN: furnace.auth.providers.db.tests
 
 <action> "test" <login-realm> realm set

basis/furnace/auth/providers/db/db.factor

@@ -1,22 +1,20 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types accessors
-furnace.auth.providers kernel continuations
-classes.singleton ;
+USING: accessors classes.singleton continuations
+db2.transactions db2.types furnace.auth.providers kernel
+orm.persistent orm.tuples ;
 IN: furnace.auth.providers.db
 
-user "USERS"
-{
-    { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
-    { "realname" "REALNAME" { VARCHAR 256 } }
-    { "password" "PASSWORD" BLOB +not-null+ }
-    { "salt" "SALT" INTEGER +not-null+ }
-    { "email" "EMAIL" { VARCHAR 256 } }
-    { "ticket" "TICKET" { VARCHAR 256 } }
-    { "capabilities" "CAPABILITIES" FACTOR-BLOB }
-    { "profile" "PROFILE" FACTOR-BLOB }
-    { "deleted" "DELETED" INTEGER +not-null+ }
-} define-persistent
+PERSISTENT: { user "users" }
+    { "username" { VARCHAR 256 } +user-assigned-key+ }
+    { "realname" { VARCHAR 256 } }
+    { "password" BLOB +not-null+ }
+    { "salt" INTEGER +not-null+ }
+    { "email" { VARCHAR 256 } }
+    { "ticket" { VARCHAR 256 } }
+    { "capabilities" FACTOR-BLOB }
+    { "profile" FACTOR-BLOB }
+    { "deleted" INTEGER +not-null+ } ;
 
 SINGLETON: users-in-db
 

basis/furnace/cache/cache.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math.intervals
-system calendar fry
-random db db.tuples db.types
-http.server.filters ;
+USING: accessors calendar db2.types fry http.server.filters
+kernel math.intervals orm.persistent orm.tuples random system ;
 IN: furnace.cache
 
 TUPLE: server-state id expires ;
@@ -11,11 +9,9 @@ TUPLE: server-state id expires ;
 : new-server-state ( id class -- server-state )
     new swap >>id ; inline
 
-server-state f
-{
-    { "id" "ID" +random-id+ system-random-generator }
-    { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
-} define-persistent
+PERSISTENT: server-state
+    { "id" +random-key+ +system-random-generator+ }
+    { "expires" BIG-INTEGER +not-null+ } ;
 
 : get-state ( id class -- state )
     new-server-state select-tuple ;

basis/furnace/conversations/conversations.factor

@@ -1,14 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel sequences accessors hashtables
-urls db.types db.tuples math.parser fry logging combinators
-html.templates.chloe.syntax
-http http.server http.server.filters http.server.redirection
-furnace.cache
-furnace.scopes
-furnace.sessions
-furnace.utilities
-furnace.redirection ;
+USING: accessors assocs combinators db2.types fry furnace.cache
+furnace.redirection furnace.scopes furnace.sessions
+furnace.utilities hashtables html.templates.chloe.syntax http
+http.server http.server.filters http.server.redirection kernel
+logging math.parser namespaces orm.persistent orm.tuples
+sequences urls ;
 IN: furnace.conversations
 
 TUPLE: conversation < scope session ;
@@ -16,9 +13,8 @@ TUPLE: conversation < scope session ;
 : <conversation> ( id -- conversation )
     conversation new-server-state ;
 
-conversation "CONVERSATIONS" {
-    { "session" "SESSION" BIG-INTEGER +not-null+ }
-} define-persistent
+PERSISTENT: { conversation "conversations" }
+    { "session" BIG-INTEGER +not-null+ } ;
 
 CONSTANT: conversation-id-key "__c"
 

basis/furnace/db/db-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax db http.server ;
+USING: db2.connections help.markup help.syntax http.server ;
 IN: furnace.db
 
 HELP: <db-persistence>

basis/furnace/db/db.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors continuations namespaces destructors
-db db.private db.pools io.pools http.server http.server.filters ;
+USING: accessors continuations db2.connections db2.pools
+destructors http.server http.server.filters io.pools kernel
+namespaces ;
 IN: furnace.db
 
 TUPLE: db-persistence < filter-responder pool disposed ;

basis/furnace/recaptcha/example/example.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.sqlite furnace.actions furnace.alloy
+USING: accessors sqlite.db2 furnace.actions furnace.alloy
 furnace.conversations furnace.recaptcha furnace.redirection
 html.templates.chloe.compiler http.server
 http.server.dispatchers http.server.responses io.streams.string

basis/furnace/scopes/scopes.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs destructors
-db.tuples db.types furnace.cache ;
+USING: accessors assocs db2.types destructors furnace.cache
+kernel orm.persistent orm.tuples ;
 IN: furnace.scopes
 
 TUPLE: scope < server-state namespace changed? ;
@@ -10,10 +10,8 @@ TUPLE: scope < server-state namespace changed? ;
     f swap new-server-state
         H{ } clone >>namespace ; inline
 
-scope f
-{
-    { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
-} define-persistent
+PERSISTENT: scope
+    { "namespace" FACTOR-BLOB +not-null+ } ;
 
 : scope-changed ( scope -- )
     t >>changed? drop ;

basis/furnace/sessions/sessions-docs.factor

@@ -36,7 +36,7 @@ $nl
 { $list
     "Continuations cannot be stored at all."
     { "Object identity is not preserved between serialization and deserialization. That is, if an object is stored with " { $link sset } " and later retrieved with " { $link sget } ", the retrieved value will be " { $link = } " to the original, but not necessarily " { $link eq? } "." }
-    { "All objects reachable from the value passed to " { $link sset } " are serialized, so large structures should not be stored in the session state, and neither should anything that can reference the global namespace. Large structures should be persisted in the database directly instead, using " { $vocab-link "db.tuples" } "." }
+    { "All objects reachable from the value passed to " { $link sset } " are serialized, so large structures should not be stored in the session state, and neither should anything that can reference the global namespace. Large structures should be persisted in the database directly instead, using " { $vocab-link "orm.tuples" } "." }
 } ;
 
 ARTICLE: "furnace.sessions" "Furnace sessions"

basis/furnace/sessions/sessions-tests.factor

@@ -2,7 +2,7 @@ USING: tools.test http furnace.sessions furnace.actions
 http.server http.server.responses math namespaces make kernel
 accessors io.sockets io.servers prettyprint
 io.streams.string io.files io.files.temp io.directories
-splitting destructors sequences db db.tuples db.sqlite
+splitting destructors sequences orm.tuples sqlite.db2 db2.connections
 continuations urls math.parser furnace furnace.utilities ;
 IN: furnace.sessions.tests
 

basis/furnace/sessions/sessions.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math.intervals math.parser namespaces
-strings random accessors quotations hashtables sequences
-continuations fry calendar combinators combinators.short-circuit
-destructors io.sockets db db.tuples db.types
+USING: accessors assocs calendar combinators
+combinators.short-circuit continuations db2.types destructors
+fry furnace.cache furnace.scopes furnace.utilities hashtables
 http http.server http.server.dispatchers http.server.filters
-furnace.cache furnace.scopes furnace.utilities ;
+io.sockets kernel math.intervals math.parser namespaces
+orm.persistent orm.tuples quotations random sequences strings ;
 IN: furnace.sessions
 
 TUPLE: session < scope user-agent client ;
@@ -13,11 +13,10 @@ TUPLE: session < scope user-agent client ;
 : <session> ( id -- session )
     session new-server-state ;
 
-session "SESSIONS"
-{
-    { "user-agent" "USER_AGENT" TEXT +not-null+ }
-    { "client" "CLIENT" TEXT +not-null+ }
-} define-persistent
+PERSISTENT: { session "SESSIONS" }
+    { "user-agent" TEXT +not-null+ }
+    { "client" TEXT +not-null+ } ;
+
 
 : get-session ( id -- session )
     dup [ session get-state ] when ;

basis/http/server/requests/requests.factor

@@ -14,13 +14,13 @@ ERROR: invalid-content-length < request-error content-length ;
 
 ERROR: content-length-missing < request-error ;
 
-ERROR: bad-request-line < request-error parse-error ;
+ERROR: bad-request-line < request-error line parse-error ;
 
 : check-absolute ( url -- )
     path>> dup "/" head? [ drop ] [ invalid-path ] if ; inline
 
 : parse-request-line-safe ( string -- triple )
-    [ parse-request-line ] [ nip bad-request-line ] recover ;
+    [ parse-request-line ] [ bad-request-line ] recover ;
 
 : read-request-line ( request -- request )
     read-?crlf [ dup "" = ] [ drop read-?crlf ] while

basis/mysql/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/connections/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/connections/connections.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections destructors kernel
+mysql.db2 mysql.db2.ffi mysql.db2.lib ;
+IN: mysql.db2.connections
+
+TUPLE: mysql-db-connection < db-connection ;
+
+: <mysql-db-connection> ( handle -- db-connection )
+    mysql-db-connection new-db-connection ; inline
+
+M: mysql-db db>db-connection-generic ( db -- db-connection )
+    {
+        [ host>> ]
+        [ username>> ]
+        [ password>> ]
+        [ database>> ]
+        [ port>> ]
+    } cleave mysql-connect <mysql-db-connection> ;
+
+M: mysql-db-connection dispose*
+    [ handle>> mysql_close ] [ f >>handle drop ] bi ;

basis/mysql/db2/db2.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs vocabs.loader ;
+IN: mysql.db2
+
+TUPLE: mysql-db host username password database port ;
+
+: <mysql-db> ( -- db )
+    f f f f 0 mysql-db boa ;
+
+{
+    "mysql.db2.ffi"
+    "mysql.db2.lib"
+    "mysql.db2.connections"
+    "mysql.db2.statements"
+    "mysql.db2.result-sets"
+} [ require ] each

basis/mysql/db2/ffi/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/ffi/ffi.factor

@@ -0,0 +1,676 @@
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax classes.struct
+combinators system alien.libraries ;
+IN: mysql.db2.ffi
+
+! Mysql 5.7.11, 3/6/2016
+<< "mysql" {
+    { [ os windows? ]  [ "libmysql.dll" ] }
+    { [ os macosx? ] [ "libmysqlclient.dylib" ] }
+    { [ os unix?  ]  [ "libmysqlclient.so" ] }
+} cond cdecl add-library >>
+
+LIBRARY: mysql
+
+TYPEDEF: int my_socket
+TYPEDEF: char my_bool
+
+CONSTANT: MYSQL_ERRMSG_SIZE 512
+CONSTANT: SCRAMBLE_LENGTH 20
+
+ENUM: mysql_status
+    MYSQL_STATUS_READY
+    MYSQL_STATUS_GET_RESULT
+    MYSQL_STATUS_USE_RESULT ;
+
+CONSTANT: MYSQL_NO_DATA 100
+CONSTANT: MYSQL_DATA_TRUNCATED 101
+
+ENUM: mysql_option
+    MYSQL_OPT_CONNECT_TIMEOUT
+    MYSQL_OPT_COMPRESS
+    MYSQL_OPT_NAMED_PIPE
+    MYSQL_INIT_COMMAND
+    MYSQL_READ_DEFAULT_FILE
+    MYSQL_READ_DEFAULT_GROUP
+    MYSQL_SET_CHARSET_DIR
+    MYSQL_SET_CHARSET_NAME
+    MYSQL_OPT_LOCAL_INFILE
+    MYSQL_OPT_PROTOCOL
+    MYSQL_SHARED_MEMORY_BASE_NAME
+    MYSQL_OPT_READ_TIMEOUT
+    MYSQL_OPT_WRITE_TIMEOUT
+    MYSQL_OPT_USE_RESULT
+    MYSQL_OPT_USE_REMOTE_CONNECTION
+    MYSQL_OPT_USE_EMBEDDED_CONNECTION
+    MYSQL_OPT_GUESS_CONNECTION
+    MYSQL_SET_CLIENT_IP
+    MYSQL_SECURE_AUTH
+    MYSQL_REPORT_DATA_TRUNCATION
+    MYSQL_OPT_RECONNECT
+    MYSQL_OPT_SSL_VERIFY_SERVER_CERT ;
+
+ENUM: mysql_protocol_type
+    MYSQL_PROTOCOL_DEFAULT
+    MYSQL_PROTOCOL_TCP
+    MYSQL_PROTOCOL_SOCKET
+    MYSQL_PROTOCOL_PIPE
+    MYSQL_PROTOCOL_MEMORY ;
+
+ENUM: mysql_rpl_type
+    MYSQL_RPL_MASTER
+    MYSQL_RPL_SLAVE
+    MYSQL_RPL_ADMIN ;
+
+ENUM: enum_field_types
+    MYSQL_TYPE_DECIMAL
+    MYSQL_TYPE_TINY
+    MYSQL_TYPE_SHORT
+    MYSQL_TYPE_LONG
+    MYSQL_TYPE_FLOAT
+    MYSQL_TYPE_DOUBLE
+    MYSQL_TYPE_NULL
+    MYSQL_TYPE_TIMESTAMP
+    MYSQL_TYPE_LONGLONG
+    MYSQL_TYPE_INT24
+    MYSQL_TYPE_DATE
+    MYSQL_TYPE_TIME
+    MYSQL_TYPE_DATETIME
+    MYSQL_TYPE_YEAR
+    MYSQL_TYPE_NEWDATE
+    MYSQL_TYPE_VARCHAR
+    MYSQL_TYPE_BIT
+    { MYSQL_TYPE_NEWDECIMAL 246 }
+    { MYSQL_TYPE_ENUM 247 }
+    { MYSQL_TYPE_SET 248 }
+    { MYSQL_TYPE_TINY_BLOB 249 }
+    { MYSQL_TYPE_MEDIUM_BLOB 250 }
+    { MYSQL_TYPE_LONG_BLOB 251 }
+    { MYSQL_TYPE_BLOB 252 }
+    { MYSQL_TYPE_VAR_STRING 253 }
+    { MYSQL_TYPE_STRING 254 }
+    { MYSQL_TYPE_GEOMETRY 255 } ;
+
+ENUM: enum_mysql_stmt_state
+    { MYSQL_STMT_INIT_DONE 1 }
+    MYSQL_STMT_PREPARE_DONE
+    MYSQL_STMT_EXECUTE_DONE
+    MYSQL_STMT_FETCH_DONE ;
+
+ENUM: enum_stmt_attr_type
+    STMT_ATTR_UPDATE_MAX_LENGTH
+    STMT_ATTR_CURSOR_TYPE
+    STMT_ATTR_PREFETCH_ROWS ;
+
+! st_list
+STRUCT: LIST
+    { prev LIST* }
+    { next LIST* }
+    { data void* } ;
+
+
+STRUCT: USED_MEM
+    { next USED_MEM* }
+    { left uint }
+    { size uint } ;
+
+TYPEDEF: uint PSI_memory_key
+
+STRUCT: MEM_ROOT
+    { free USED_MEM* }
+    { used USED_MEM* }
+    { pre_alloc USED_MEM* }
+    { min_malloc size_t }
+    { block_size size_t }
+    { block_num uint }
+    { first_block_usage uint }
+    { max_capacity size_t }
+    { allocated_size size_t }
+    { error_for_capacity_exceeded my_bool }
+    { error_handler void* }
+    { m_psi_key PSI_memory_key } ;
+
+! st_mysql_field
+STRUCT: MYSQL_FIELD
+    { name c-string }
+    { org_name c-string }
+    { table c-string }
+    { org_table c-string }
+    { db c-string }
+    { catalog c-string }
+    { def c-string }
+    { length ulong }
+    { max_length ulong }
+    { name_length uint }
+    { org_name_length uint }
+    { table_length uint }
+    { org_table_length uint }
+    { db_length uint }
+    { catalog_length uint }
+    { def_length uint }
+    { flags uint }
+    { decimals uint }
+    { charsetnr uint }
+    { type enum_field_types }
+    { extension void* } ;
+
+STRUCT: st_dynamic_array
+    { buffer uchar* }
+    { elements uint }
+    { max_element uint }
+    { alloc_increment uint }
+    { size_of_element uint } ;
+
+STRUCT: st_mysql_options
+    { connect_timeout uint }
+    { read_timeout uint }
+    { write_timeout uint }
+    { port uint }
+    { protocol uint }
+    { client_flag ulong }
+    { host c-string }
+    { user c-string }
+    { password c-string }
+    { unix_socket c-string }
+    { db c-string }
+    { init_commands st_dynamic_array* }
+    { my_cnf_file c-string }
+    { my_cnf_group c-string }
+    { charset_dir c-string }
+    { charset_name c-string }
+    { ssl_key c-string }
+    { ssl_cert c-string }
+    { ssl_ca c-string }
+    { ssl_capath c-string }
+    { ssl_cipher c-string }
+    { shared_memory_base_name c-string }
+    { max_allowed_packet ulong }
+    { use_ssl my_bool }
+    { compress my_bool }
+    { named_pipe my_bool }
+    { rpl_probe my_bool }
+    { rpl_parse my_bool }
+    { no_master_reads my_bool }
+    { methods_to_use mysql_option }
+    { client_ip c-string }
+    { secure_auth my_bool }
+    { report_data_truncation my_bool }
+    { local_infile_init void* }
+    { local_infile_read void* }
+    { local_infile_end void* }
+    { local_infile_error void* }
+    { local_infile_userdata void* }
+    { extension void* } ;
+
+! my_uni_idx_st
+STRUCT: MY_UNI_IDX
+    { from ushort }
+    { to ushort }
+    { tab uchar* } ;
+
+! unicase_info_st
+STRUCT: MY_UNICASE_INFO
+    { toupper ushort }
+    { tolower ushort }
+    { sort ushort } ;
+
+STRUCT: charset_info_st
+    { number uint }
+    { primary_number uint }
+    { binary_number uint }
+    { state uint }
+    { csname c-string }
+    { name c-string }
+    { comment c-string }
+    { tailoring c-string }
+    { ctype c-string }
+    { to_lower c-string }
+    { to_upper c-string }
+    { sort_order c-string }
+    { contractions ushort* }
+    { sort_order_big ushort** }
+    { tab_to_uni ushort* }
+    { tab_from_uni MY_UNI_IDX* }
+    { caseinfo MY_UNICASE_INFO** }
+    { state_map c-string }
+    { ident_map c-string }
+    { strxfrm_multiply uint }
+    { caseup_multiply uchar }
+    { casedn_multiply uchar }
+    { mbminlen uint }
+    { mbmaxlen uint }
+    { min_sort_char ushort }
+    { max_sort_char ushort }
+    { pad_char uchar }
+    { escape_with_backslash_is_dangerous char }
+    { cset void* }
+    { coll void* } ;
+
+C-TYPE: Vio
+! st_net
+STRUCT: NET
+    { vio Vio* }
+    { buff uchar* }
+    { buff_end uchar* }
+    { write_pos uchar* }
+    { read_pos uchar* }
+    { fd my_socket }
+    { remain_in_buf ulong }
+    { length ulong }
+    { buf_length ulong }
+    { where_b ulong }
+    { max_packet ulong }
+    { max_packet_size ulong }
+    { pkt_nr uint }
+    { compress_pkt_nr uint }
+    { write_timeout uint }
+    { read_timeout uint }
+    { retry_count uint }
+    { fcntl int }
+    { return_status uint* }
+    { reading_or_writing uchar }
+    { save_char char }
+    { unused1 my_bool }
+    { unused2 my_bool }
+    { compress my_bool }
+    { unused3 my_bool }
+    { query_cache_query uchar* }
+    { last_errno uint }
+    { error uchar }
+    { unused4 my_bool }
+    { unused5 my_bool }
+    { last_error char[512] }
+    { sqlstate char[6] }
+    { extension void* } ;
+
+STRUCT: MYSQL
+    { net NET }
+    { connector_fd uchar* }
+    { host c-string }
+    { user c-string }
+    { passwd c-string }
+    { unix_socket c-string }
+    { server_version c-string }
+    { host_info c-string }
+    { info c-string }
+    { db c-string }
+    { charset charset_info_st* }
+    { fields MYSQL_FIELD* }
+    { field_alloc MEM_ROOT }
+    { affected_rows ulonglong }
+    { insert_id ulonglong }
+    { extra_info ulonglong }
+    { thread_id ulong }
+    { packet_length ulong }
+    { port uint }
+    { client_flag ulong }
+    { server_capabilities ulong }
+    { protocol_version uint }
+    { field_count uint }
+    { server_status uint }
+    { server_language uint }
+    { warning_count uint }
+    { options st_mysql_options }
+    { status mysql_status }
+    { free_me bool }
+    { reconnect bool }
+    { scramble char[21] }
+    { rpl_pivot my_bool }
+    { master MYSQL* }
+    { next_slave MYSQL* }
+    { last_used_slave MYSQL* }
+    { last_used_con MYSQL* }
+    { stmts LIST* }
+    { methods void* }
+    { thd void* }
+    { unbuffered_fetch_owner bool* }
+    { info_buffer c-string }
+    { extension void* } ;
+
+TYPEDEF: c-string* MYSQL_ROW
+
+STRUCT: MYSQL_ROWS
+    { next MYSQL_ROWS* }
+    { data MYSQL_ROW }
+    { length ulong } ;
+
+TYPEDEF: MYSQL_ROWS* MYSQL_ROW_OFFSET
+
+STRUCT: MYSQL_DATA
+    { data MYSQL_ROWS* }
+    { embedded_info void* }
+    { alloc MEM_ROOT }
+    { rows ulonglong }
+    { fields uint }
+    { extension void* } ;
+
+STRUCT: MYSQL_RES
+    { row_count ulonglong }
+    { fields MYSQL_FIELD* }
+    { data MYSQL_DATA* }
+    { data_cursor MYSQL_ROWS* }
+    { lengths ulong* }
+    { handle MYSQL* }
+    { methods void* }
+    { row MYSQL_ROW }
+    { current_row MYSQL_ROW }
+    { field_alloc MEM_ROOT }
+    { field_count uint }
+    { current_field uint }
+    { eof bool }
+    { unbuffered_fetch_cancelled bool }
+    { extension void* } ;
+
+
+STRUCT: MYSQL_BIND
+    { length ulong* }
+    { is_null bool* }
+    { buffer void* }
+    { error bool* }
+    { row_ptr uchar* }
+    { store_param_func void* }
+    { fetch_result void* }
+    { skip_result void* }
+    { buffer_length ulong }
+    { offset ulong }
+    { length_value ulong }
+    { param_number uint }
+    { pack_length uint }
+    { buffer_type enum_field_types }
+    { error_value bool }
+    { is_unsigned bool }
+    { long_data_used bool }
+    { is_null_value bool }
+    { extension void* } ;
+
+
+
+! FIXME: Replace with TYPEDEF: void* MYSQL_STMT
+! since no fields are supposed to be used by application?
+
+STRUCT: MYSQL_STMT
+    { mem_root MEM_ROOT }
+    { list LIST }
+    { mysql MYSQL* }
+    { params MYSQL_BIND* }
+    { bind MYSQL_BIND* }
+    { fields MYSQL_FIELD* }
+    { result MYSQL_DATA }
+    { data_cursor MYSQL_ROWS* }
+    { read_row_func void* }
+    { affected_rows ulonglong }
+    { insert_id ulonglong }
+    { stmt_id ulong }
+    { flags ulong }
+    { prefetch_rows ulong }
+    { server_status uint }
+    { last_errno uint }
+    { param_count uint }
+    { field_count uint }
+    { state enum_mysql_stmt_state }
+    { last_error char[MYSQL_ERRMSG_SIZE] }
+    { sqlstate char[6] }
+    { send_types_to_server bool }
+    { bind_param_done bool }
+    { bind_result_done uchar }
+    { unbuffered_fetch_cancelled bool }
+    { update_max_length bool }
+    { extension void* } ;
+
+
+ENUM: enum_mysql_timestamp_type
+    { MYSQL_TIMESTAMP_NONE -2 }
+    { MYSQL_TIMESTAMP_ERROR -1 }
+    { MYSQL_TIMESTAMP_DATE 0 }
+    { MYSQL_TIMESTAMP_DATETIME 1 }
+    { MYSQL_TIMESTAMP_TIME 2 } ;
+
+
+STRUCT: MYSQL_TIME
+    { year uint }
+    { month uint }
+    { day uint }
+    { hour uint }
+    { minute uint }
+    { second uint }
+    { second_part ulong }
+    { neg bool }
+    { time_type enum_mysql_timestamp_type } ;
+
+
+
+FUNCTION: MYSQL* mysql_init ( MYSQL* mysql )
+
+
+FUNCTION: c-string mysql_info ( MYSQL* mysql )
+
+
+
+FUNCTION: uint mysql_errno ( MYSQL* mysql )
+
+FUNCTION: c-string mysql_error ( MYSQL* mysql )
+
+
+FUNCTION: c-string mysql_get_client_info ( )
+
+FUNCTION: ulong mysql_get_client_version ( )
+
+FUNCTION: c-string mysql_get_host_info ( MYSQL* mysql )
+
+FUNCTION: c-string mysql_get_server_info ( MYSQL* mysql )
+
+FUNCTION: ulong mysql_get_server_version ( MYSQL* mysql )
+
+FUNCTION: uint mysql_get_proto_info ( MYSQL* mysql )
+
+FUNCTION: MYSQL_RES* mysql_list_dbs (
+    MYSQL* mysql,
+    c-string wild
+)
+
+FUNCTION: MYSQL_RES* mysql_list_tables (
+    MYSQL* mysql,
+    c-string wild
+)
+
+FUNCTION: MYSQL_RES* mysql_list_processes ( MYSQL* mysql )
+
+
+
+
+FUNCTION: MYSQL* mysql_real_connect (
+    MYSQL* mysql,
+    c-string host,
+    c-string user,
+    c-string passwd,
+    c-string db,
+    uint port,
+    c-string unix_socket,
+    ulong client_flag
+)
+
+FUNCTION: void mysql_close ( MYSQL* mysql )
+
+
+
+FUNCTION: bool mysql_commit ( MYSQL* mysql )
+
+FUNCTION: bool mysql_rollback ( MYSQL* mysql )
+
+FUNCTION: bool mysql_autocommit (
+    MYSQL* mysql,
+    bool auto_mode
+)
+
+FUNCTION: bool mysql_more_results ( MYSQL* mysql )
+
+FUNCTION: int mysql_next_result ( MYSQL* mysql )
+
+
+! <OLD-FUNCTIONS
+FUNCTION: MYSQL* mysql_connect (
+    MYSQL* mysql,
+    c-string host,
+    c-string user,
+    c-string passwd
+)
+
+FUNCTION: int mysql_create_db ( MYSQL* mysql, c-string db )
+
+FUNCTION: int mysql_drop_db ( MYSQL* mysql, c-string db )
+! OLD-FUNCTIONS>
+
+
+
+
+FUNCTION: int mysql_select_db ( MYSQL* mysql, c-string db )
+
+
+
+FUNCTION: int mysql_query ( MYSQL* mysql, c-string stmt_str )
+
+FUNCTION: int mysql_send_query (
+    MYSQL* mysql,
+    c-string stmt_str,
+    ulong length
+)
+
+FUNCTION: int mysql_real_query (
+    MYSQL* mysql,
+    c-string stmt_str,
+    ulong length
+)
+
+FUNCTION: MYSQL_RES* mysql_store_result ( MYSQL* mysql )
+
+FUNCTION: MYSQL_RES* mysql_use_result ( MYSQL* mysql )
+
+
+FUNCTION: int mysql_ping ( MYSQL* mysql )
+
+
+
+
+FUNCTION: ulonglong mysql_num_rows ( MYSQL_RES* mysql )
+
+FUNCTION: uint mysql_num_fields ( MYSQL_RES* mysql )
+
+FUNCTION: bool mysql_eof ( MYSQL_RES* result )
+
+FUNCTION: MYSQL_FIELD* mysql_fetch_field_direct (
+    MYSQL_RES* result,
+    uint fieldnr
+)
+
+FUNCTION: MYSQL_FIELD* mysql_fetch_fields ( MYSQL_RES* result )
+
+
+FUNCTION: uint mysql_field_count ( MYSQL* mysql )
+
+
+
+FUNCTION: MYSQL_ROW mysql_fetch_row ( MYSQL_RES* result )
+
+FUNCTION: MYSQL_FIELD* mysql_fetch_field ( MYSQL_RES* result )
+
+FUNCTION: void mysql_free_result ( MYSQL_RES* result )
+
+
+
+
+
+
+
+
+FUNCTION: MYSQL_STMT* mysql_stmt_init ( MYSQL* mysql )
+
+FUNCTION: int mysql_stmt_prepare (
+    MYSQL_STMT* stmt,
+    c-string query,
+    ulong length
+)
+
+FUNCTION: int mysql_stmt_execute ( MYSQL_STMT* stmt )
+
+FUNCTION: int mysql_stmt_fetch ( MYSQL_STMT* stmt )
+
+FUNCTION: int mysql_stmt_fetch_column (
+    MYSQL_STMT* stmt,
+    MYSQL_BIND* bind_arg,
+    uint column,
+    ulong offset
+)
+
+FUNCTION: int mysql_stmt_store_result ( MYSQL_STMT* stmt )
+
+FUNCTION: ulong mysql_stmt_param_count ( MYSQL_STMT* stmt )
+
+FUNCTION: bool mysql_stmt_attr_set (
+    MYSQL_STMT* stmt,
+    enum_stmt_attr_type attr_type,
+    void* attr
+)
+
+FUNCTION: bool mysql_stmt_attr_get (
+    MYSQL_STMT* stmt,
+    enum_stmt_attr_type attr_type,
+    void* attr
+)
+
+FUNCTION: bool mysql_stmt_bind_param (
+    MYSQL_STMT* stmt,
+    MYSQL_BIND* bnd
+)
+
+FUNCTION: bool mysql_stmt_bind_result (
+    MYSQL_STMT* stmt,
+    MYSQL_BIND* bnd
+)
+
+FUNCTION: bool mysql_stmt_close ( MYSQL_STMT* stmt )
+
+FUNCTION: bool mysql_stmt_reset ( MYSQL_STMT* stmt )
+
+FUNCTION: bool mysql_stmt_free_result ( MYSQL_STMT* stmt )
+
+FUNCTION: bool mysql_stmt_send_long_data (
+    MYSQL_STMT* stmt,
+    uint param_number,
+    c-string data,
+    ulong length
+)
+
+FUNCTION: MYSQL_RES* mysql_stmt_result_metadata ( MYSQL_STMT* stmt )
+
+FUNCTION: MYSQL_RES* mysql_stmt_param_metadata ( MYSQL_STMT* stmt )
+
+FUNCTION: uint mysql_stmt_errno ( MYSQL_STMT* stmt )
+
+FUNCTION: c-string mysql_stmt_error ( MYSQL_STMT* stmt )
+
+FUNCTION: c-string mysql_stmt_sqlstate ( MYSQL_STMT* stmt )
+
+FUNCTION: MYSQL_ROW_OFFSET mysql_stmt_row_seek (
+    MYSQL_STMT* stmt,
+    MYSQL_ROW_OFFSET offset
+)
+
+FUNCTION: MYSQL_ROW_OFFSET mysql_stmt_row_tell (
+    MYSQL_STMT* stmt,
+    MYSQL_ROW_OFFSET offset
+)
+
+FUNCTION: void mysql_stmt_data_seek (
+    MYSQL_STMT* stmt,
+    ulonglong offset
+)
+
+FUNCTION: ulonglong mysql_stmt_num_rows ( MYSQL_STMT* stmt )
+
+FUNCTION: ulonglong mysql_stmt_affected_rows ( MYSQL_STMT* stmt )
+
+FUNCTION: ulonglong mysql_stmt_insert_id ( MYSQL_STMT* stmt )
+
+FUNCTION: uint mysql_stmt_field_count ( MYSQL_STMT* stmt )
+

basis/mysql/db2/lib/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/lib/lib.factor

@@ -0,0 +1,204 @@
+! Copyright (C) 2010 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors alien alien.c-types alien.data alien.strings
+calendar.format classes.struct combinators db2.errors db2.types
+fry generalizations io.encodings.utf8 kernel layouts locals
+make math math.parser mysql.db2.ffi present sequences serialize ;
+FROM: alien.c-types => short ;
+IN: mysql.db2.lib
+
+ERROR: mysql-error < db-error n string ;
+ERROR: mysql-sql-error < sql-error n string ;
+
+: mysql-check-result ( mysql n -- )
+    dup { 0 f } member? [ 2drop ] [
+        swap mysql_error mysql-error
+    ] if ;
+
+ERROR: mysql-connect-fail string mysql ;
+
+: mysql-check-connect ( mysql1 mysql2 -- )
+    dup net>> last_errno>> 0 = [
+        2drop
+    ] [
+        [ mysql_error ] dip mysql-connect-fail
+    ] if ;
+
+: mysql-stmt-check-result ( stmt n -- )
+    dup { 0 f } member? [ 2drop ] [
+        swap mysql_stmt_error mysql-error ! FIXME: mysql-sql-error
+    ] if ;
+
+:: mysql-connect ( host user passwd db port -- mysql/f )
+    f mysql_init :> mysql
+    mysql host user passwd db port f 0 mysql_real_connect :> handle
+    mysql dup mysql-check-connect handle ;
+
+: mysql-#rows ( result -- n )
+    mysql_num_rows ;
+
+: mysql-#columns ( result -- n )
+    mysql_num_fields ;
+
+: mysql-next ( result -- ? )
+    mysql_fetch_row ;
+
+
+: mysql-column ( result n -- value )
+    swap [ cell * ] [ current_row>> ] bi* <displaced-alien>
+    void* deref utf8 alien>string ;
+
+: mysql-row ( result -- seq )
+    [ current_row>> ] [ mysql-#columns ] bi [
+        [ void* deref utf8 alien>string ]
+        [ cell swap <displaced-alien> ] bi swap
+    ] replicate nip ;
+
+! returns a result or f
+: mysql-query ( mysql query -- result/f )
+    dupd mysql_query dupd mysql-check-result mysql_store_result ;
+
+! Throws if fails
+: mysql-command ( mysql query -- )
+    dupd mysql_query mysql-check-result ;
+
+: mysql-reset-statement ( statement -- )
+    handle>> dup mysql_stmt_reset mysql-stmt-check-result ;
+
+: mysql-free-statement ( statement -- )
+    handle>> dup mysql_stmt_free_result mysql-stmt-check-result ;
+
+: mysql-free-result ( result -- )
+    handle>> mysql_free_result ;
+
+
+: <mysql-time> ( timestamp -- MYSQL_TIME )
+    MYSQL_TIME <struct>
+        over year>> >>year
+        over month>> >>month
+        over day>> >>day
+        over hour>> >>hour
+        over minute>> >>minute
+        swap second>> >>second ;
+
+:: <mysql-bind> ( index key value type -- mysql_BIND )
+    MYSQL_BIND <struct>
+        index >>param_number
+        value type {
+            { INTEGER [ MYSQL_TYPE_LONG ] }
+            { BIG-INTEGER [ MYSQL_TYPE_LONGLONG ] }
+            { SIGNED-BIG-INTEGER [ MYSQL_TYPE_LONGLONG ] }
+            { UNSIGNED-BIG-INTEGER [ MYSQL_TYPE_LONGLONG ] }
+            { BOOLEAN [ MYSQL_TYPE_BIT ] }
+            { TEXT [ MYSQL_TYPE_VARCHAR ] }
+            { VARCHAR [ MYSQL_TYPE_VARCHAR ] }
+            { DOUBLE [ MYSQL_TYPE_DOUBLE ] }
+            { DATE [ timestamp>ymd MYSQL_TYPE_DATE ] }
+            { TIME [ timestamp>hms MYSQL_TYPE_TIME ] }
+            { DATETIME [ timestamp>ymdhms MYSQL_TYPE_DATETIME ] }
+            { TIMESTAMP [ timestamp>ymdhms MYSQL_TYPE_DATETIME ] }
+            { BLOB [ MYSQL_TYPE_BLOB ] }
+            { FACTOR-BLOB [ object>bytes MYSQL_TYPE_BLOB ] }
+            { URL [ present MYSQL_TYPE_VARCHAR ] }
+            { +db-assigned-key+ [ MYSQL_TYPE_LONG ] }
+            { +random-key+ [ MYSQL_TYPE_LONGLONG ] }
+            { NULL [ MYSQL_TYPE_NULL ] }
+            [ no-sql-type ]
+        } case >>buffer_type >>buffer
+        ! FIXME: buffer_length
+        ! FIXME: is_null
+    ;
+
+
+
+
+<PRIVATE
+
+CONSTANT: MIN_CHAR -255
+CONSTANT: MAX_CHAR 256
+
+CONSTANT: MIN_SHORT -65535
+CONSTANT: MAX_SHORT 65536
+
+CONSTANT: MIN_INT -4294967295
+CONSTANT: MAX_INT 4294967296
+
+CONSTANT: MIN_LONG -18446744073709551615
+CONSTANT: MAX_LONG 18446744073709551616
+
+FROM: alien.c-types => short ;
+
+: fixnum>c-ptr ( n -- c-ptr )
+    dup 0 < [ abs 1 + ] when {
+        { [ dup MAX_CHAR  <= ] [ char <ref> ] }
+        { [ dup MAX_SHORT <= ] [ short <ref> ] }
+        { [ dup MAX_INT   <= ] [ int <ref> ] }
+        { [ dup MAX_LONG  <= ] [ longlong <ref> ] }
+        [ "too big" throw ]
+    } cond ;
+
+PRIVATE>
+
+
+! : mysql-stmt-query ( stmt -- result )
+!     dup mysql_stmt_execute dupd mysql-stmt-check-result
+!     mysql_stmt_store_result ;
+
+
+: mysql-column-typed ( result n -- value )
+    [ mysql-column ] [ mysql_fetch_field_direct ] 2bi type>> {
+        { MYSQL_TYPE_DECIMAL  [ string>number ] }
+        { MYSQL_TYPE_SHORT    [ string>number ] }
+        { MYSQL_TYPE_LONG     [ string>number ] }
+        { MYSQL_TYPE_FLOAT    [ string>number ] }
+        { MYSQL_TYPE_DOUBLE   [ string>number ] }
+        { MYSQL_TYPE_LONGLONG [ string>number ] }
+        { MYSQL_TYPE_INT24    [ string>number ] }
+        [ drop ]
+    } case ;
+
+
+
+
+: create-db ( mysql db -- )
+    dupd mysql_create_db mysql-check-result ;
+
+: drop-db ( mysql db -- )
+    dupd mysql_drop_db mysql-check-result ;
+
+: select-db ( mysql db -- )
+    dupd mysql_select_db mysql-check-result ;
+
+<PRIVATE
+
+: cols ( result n -- cols )
+    [ dup mysql_fetch_field name>> ] replicate nip ;
+
+: row ( result n -- row/f )
+    swap mysql_fetch_row [
+        swap [
+            [ void* deref utf8 alien>string ]
+            [ cell swap <displaced-alien> ] bi swap
+        ] replicate nip
+    ] [ drop f ] if* ;
+
+: rows ( result n -- rows )
+    [ '[ _ _ row dup ] [ , ] while drop ] { } make ;
+
+PRIVATE>
+
+: list-dbs ( mysql -- seq )
+    f mysql_list_dbs dup mysql_num_fields rows concat ;
+
+: list-tables ( mysql -- seq )
+    f mysql_list_tables dup mysql_num_fields rows concat ;
+
+: list-processes ( mysql -- seq )
+    mysql_list_processes dup mysql_num_fields rows ;
+
+: query-db ( mysql sql -- cols rows )
+    mysql-query [
+        dup mysql_num_fields [ cols ] [ rows ] 2bi
+    ] [ mysql_free_result ] bi ;
+

basis/mysql/db2/result-sets/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/result-sets/result-sets.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data classes.struct
+combinators db2.result-sets destructors kernel locals
+mysql.db2.connections mysql.db2.ffi mysql.db2.lib libc
+specialized-arrays sequences ;
+IN: mysql.db2.result-sets
+
+SPECIALIZED-ARRAY: MYSQL_BIND
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: ulong
+
+TUPLE: mysql-result-set < result-set bind #columns nulls lengths errors ;
+
+M: mysql-result-set dispose ( result-set -- )
+    ! the handle is a stmt handle here, not a result_set handle
+    [ mysql-free-statement ]
+    [ f >>handle drop ] bi ;
+
+M: mysql-result-set #columns ( result-set -- n ) #columns>> ;
+
+M: mysql-result-set advance-row ( result-set -- ) drop ;
+
+M: mysql-result-set column
+    B
+    3drop f
+    ;
+
+M: mysql-result-set more-rows? ( result-set -- ? )
+    handle>> [
+        mysql_stmt_fetch {
+            { 0 [ t ] }
+            { MYSQL_NO_DATA [ f ] }
+            { MYSQL_DATA_TRUNCATED [ "truncated, bailing out.." throw ] }
+        } case
+    ] [
+        f
+    ] if* ;
+
+
+! Reference: http://dev.mysql.com/doc/refman/5.6/en/mysql-stmt-fetch.html
+M:: mysql-db-connection statement>result-set ( statement -- result-set )
+    statement handle>> :> handle
+    [
+        ! 0 int <ref> malloc-byte-array |free :> buffer0
+        256 malloc :> buffer0
+        256 :> buffer_length0
+        0 ulong <ref> malloc-byte-array |free :> length0
+        f bool <ref> malloc-byte-array |free :> error0
+        f bool <ref> malloc-byte-array |free :> is_null0
+
+        handle mysql_stmt_execute
+        [ handle ] dip mysql-stmt-check-result
+
+        statement handle \ mysql-result-set new-result-set :> result-set
+
+        handle mysql_stmt_result_metadata :> metadata
+        metadata field_count>> :> #columns
+
+        #columns MYSQL_BIND malloc-array |free :> binds
+        #columns ulong malloc-array |free :> lengths
+        #columns bool malloc-array |free :> is_nulls
+        #columns bool malloc-array |free :> errors
+
+        binds [
+            MYSQL_TYPE_STRING >>buffer_type
+            256 malloc >>buffer
+            256 >>buffer_length
+            is_null0 >>is_null
+            length0 >>length
+            error0 >>error
+        ] map drop
+        
+
+
+        MYSQL_BIND malloc-struct |free
+            ! MYSQL_TYPE_LONG >>buffer_type
+            MYSQL_TYPE_STRING >>buffer_type
+            buffer0 >>buffer
+            buffer_length0 >>buffer_length
+            is_null0 >>is_null
+            length0 >>length
+            error0 >>error
+        :> bind0
+
+
+        bind0 result-set bind<<
+        
+        handle bind0 mysql_stmt_bind_result
+            f = [ handle mysql_stmt_error throw ] unless
+        handle mysql_stmt_store_result
+            0 = [ "mysql store_result error" throw ] unless
+
+        ! handle mysql_stmt_fetch .
+        ! bind0 buffer>> alien>native-string .
+
+        ! handle mysql_stmt_fetch .
+        ! bind0 buffer>> alien>native-string .
+
+        result-set
+    ] with-destructors
+    ;
+    ! TODO: bind data here before more-rows? calls mysql_stmt_fetch
+

basis/mysql/db2/statements/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/db2/statements/statements.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections db2.statements
+io.encodings.string io.encodings.utf8 kernel
+mysql.db2.connections mysql.db2.ffi mysql.db2.lib namespaces
+sequences locals ;
+IN: mysql.db2.statements
+
+:: mysql-prepare ( stmt sql -- stmt )
+    stmt sql utf8 encode dup length mysql_stmt_prepare
+    [ stmt ] dip mysql-stmt-check-result stmt ;
+
+: mysql-maybe-prepare ( statement -- statement )
+    dup handle>> [
+        db-connection get handle>> mysql_stmt_init
+        over sql>> mysql-prepare >>handle
+    ] unless ;
+
+M: mysql-db-connection prepare-statement*
+    mysql-maybe-prepare ;
+
+M: mysql-db-connection bind-sequence
+    drop ;
+
+M: mysql-db-connection reset-statement
+    [ handle>> mysql-reset-statement ] keep ;
+
+M: mysql-db-connection dispose-statement
+    f >>handle drop ;
+
+! M: mysql-db-connection next-bind-index "?" ;
+
+! M: mysql-db-connection init-bind-index ;
+
+

basis/mysql/mysql.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2010 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs vocabs.loader ;
+IN: mysql
+
+[
+    "mysql.db2"
+    "mysql.orm"
+] [ require ] each

basis/mysql/orm/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/mysql/orm/orm.factor

@@ -0,0 +1,5 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: mysql.orm
+

basis/orm/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/orm/binders/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/orm/binders/binders.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors ;
+IN: orm.binders
+
+TUPLE: column-binder-in column value ;
+CONSTRUCTOR: <column-binder-in> column-binder-in ( column value -- obj ) ;
+
+TUPLE: column-binder-out column ;
+CONSTRUCTOR: <column-binder-out> column-binder-out ( column -- obj ) ;