--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors 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 ) ;
--- /dev/null
+! 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
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors fry kernel namespaces ;
+IN: db2.connections
+
+TUPLE: db-connection < 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
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections 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
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 )
+
+
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections fry io.pools kernel namespaces ;
+IN: db2.pools
+
+TUPLE: db-pool < pool db ;
+
+: <db-pool> ( db -- pool )
+ db-pool <pool>
+ swap >>db ; inline
+
+: with-db-pool ( db quot -- )
+ [ <db-pool> ] dip with-pool ; inline
+
+M: db-pool make-connection ( pool -- connection )
+ db>> db>db-connection ;
+
+: with-pooled-db ( pool quot -- )
+ '[ db-connection _ with-variable ] with-pooled-connection ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.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
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.binders db2.connections
+db2.types
+destructors fry kernel 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors 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 ;
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
+*/
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations db2 db2.connections namespaces ;
+IN: db2.transactions
+
+SYMBOL: in-transaction
+
+HOOK: begin-transaction db-connection ( -- )
+
+HOOK: commit-transaction db-connection ( -- )
+
+HOOK: rollback-transaction db-connection ( -- )
+
+M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
+
+M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
+
+M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 )
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
+
+
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: mysql.orm
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ) ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar constructors db2.types orm
+orm.persistent sequences multiline ;
+IN: orm.examples
+
+TUPLE: user id name age ;
+CONSTRUCTOR: <user> user ( name age -- obj ) ;
+TUPLE: score id user score ;
+
+PERSISTENT: user
+ { "id" +db-assigned-key+ }
+ { "name" VARCHAR }
+ { "age" INTEGER } ;
+
+PERSISTENT: score
+ { "id" +db-assigned-key+ }
+ { "user" user }
+ { "score" INTEGER } ;
+
+
+TUPLE: user2 id name age ;
+CONSTRUCTOR: <user2> user2 ( name age -- obj ) ;
+TUPLE: score2 id user score ;
+
+PERSISTENT: user2
+ { "id" INTEGER +primary-key+ }
+ { "name" VARCHAR }
+ { "age" INTEGER } ;
+
+PERSISTENT: score2
+ { "id" INTEGER +primary-key+ }
+ { "user" user2 }
+ { "score" INTEGER } ;
+
+
+TUPLE: user3 id name age ;
+CONSTRUCTOR: <user3> user3 ( name age -- obj ) ;
+TUPLE: score3 id user score ;
+
+PERSISTENT: user3
+ { "id" INTEGER +primary-key+ }
+ { "name" VARCHAR NOT-NULL }
+ { "age" INTEGER NOT-NULL } ;
+
+PERSISTENT: score3
+ { "id" INTEGER +primary-key+ }
+ { "user" user3 NOT-NULL }
+ { "score" INTEGER NOT-NULL } ;
+
+
+/*
+
+T{ score2
+ {
+ user
+ T{ user { "name" "erg" } }
+ }
+} select-tuples
+
+{
+ T{ score
+ { id 0 }
+ { user T{ user { id 0 } { name "erg" } { age 28 } } }
+ { score 100 }
+ }
+ T{ score
+ { id 1 }
+ { user T{ user { id 0 } { name "erg" } { age 28 } } }
+ { score 106 }
+ }
+}
+*/
+
+TUPLE: jar id name beans ;
+TUPLE: bean id ;
+
+PERSISTENT: bean
+ { "id" INTEGER +primary-key+ } ;
+
+PERSISTENT: jar
+ { "id" INTEGER +primary-key+ }
+ { "name" VARCHAR }
+ { "beans" { bean sequence } } ;
+
+/*
+
+T{ bean } select-tuples
+{
+ T{ bean { id 1 } }
+ T{ bean { id 2 } }
+ T{ bean { id 3 } }
+ T{ bean { id 4 } }
+}
+
+T{ jar } select-tuples
+{
+ T{ jar { id 1 } { "beans1" }
+ { beans { T{ bean { id 1 } } T{ bean { id 2 } } } }
+ }
+ T{ jar { id 2 } { "beans2" }
+ { beans { T{ bean { id 3 } } T{ bean { id 4 } } } }
+ }
+}
+
+T{ jar { beans IGNORE } } select-tuples
+{
+ T{ jar { id 1 } { "beans1" } }
+ T{ jar { id 2 } { "beans2" } }
+}
+
+*/
+
+! Blogs
+TUPLE: entity id author date content ;
+CONSTRUCTOR: <entity> entity ( author content -- entity ) now >>date ;
+PERSISTENT: entity
+ { "id" +db-assigned-key+ }
+ { "author" VARCHAR NOT-NULL } ! uid
+ { "date" TIMESTAMP NOT-NULL }
+ { "content" TEXT NOT-NULL } ;
+
+TUPLE: post < entity title comments ;
+CONSTRUCTOR: <post> post ( title -- entity ) now >>date ;
+PERSISTENT: post
+ { "title" VARCHAR NOT-NULL }
+ { "comments" { entity sequence } } ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.tuple
+combinators db2.query-objects db2.types fry kernel make
+namespaces orm.persistent sequences shuffle db2.utils
+locals vocabs multiline ;
+IN: orm
+
+USE: vocabs.loader
+"orm.query-objects" require
+
+
+
+/*
+
+TUPLE: relations internal external ;
+
+SYMBOL: table-counter
+
+: (tuple>relations) ( n tuple -- )
+ [ ] [ >persistent columns>> ] bi [
+ dup relation-category [
+ 2dup getter>> call( obj -- obj' ) dup IGNORE = [
+ 4drop
+ ] [
+ [ dup relation-class new ] unless*
+ over relation-category [
+ swap [
+ [
+ [ class swap 2array ]
+ [ relation-class table-counter [ inc ] [ get ] bi 2array ] bi*
+ ] dip 3array ,
+ ] dip
+ [ table-counter get ] dip (tuple>relations)
+ ] [
+ 4drop
+ ] if*
+ ] if
+ ] [
+ 3drop
+ ] if
+ ] with with each ;
+
+: tuple>relations ( tuple -- seq )
+ 0 table-counter [
+ [ 0 swap (tuple>relations) ] { } make
+ ] with-variable ;
+
+: internal-class-relations ( class -- seq )
+ dup >persistent columns>> [
+ type>> dup tuple-class? [ 2array ] [ 2drop f ] if
+ ] with filter ;
+
+: external-class-relations ( class -- seq )
+ [ inherited-persistent-table get-global ] dip
+ '[
+ nip columns>> [ type>> _ eq? ] any?
+ ] assoc-filter ;
+
+: class-relations ( class -- internal external )
+ [ internal-class-relations ]
+ [ external-class-relations ] bi ;
+
+! Don't introspect the quotation at runtime.
+
+: column-contains-many? ( column -- ? )
+ type>> dup array? [
+ ?first2 [ tuple-class? ] [ sequence = ] bi* and
+ ] [
+ drop f
+ ] if ;
+
+: find-contains-many ( class -- seq )
+ >persistent columns>> [ column-contains-many? ] filter ;
+
+: find-one:one ( class -- seq )
+ ;
+
+: class>relations ( class -- relation )
+ >persistent columns>> [ tuple-class? ] filter ;
+
+
+: relation>join ( triple -- seq )
+
+ ;
+
+: relations>joins ( seq -- seq' )
+ [ relation>join ] map concat ;
+
+: tuple>select-statement ( tuple -- select )
+ [ select new ] dip
+ {
+ ! [ tuple>relations relations>joins 1array >>join ]
+ ! [ ]
+ } cleave ;
+*/
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+IN: orm.persistent.tests
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors annotations arrays assocs classes
+classes.tuple combinators combinators.short-circuit
+constructors db2.types db2.utils kernel math namespaces
+parser quotations sequences sets strings words make
+fry lexer db2.binders random multiline ;
+QUALIFIED-WITH: namespaces n
+IN: orm.persistent
+
+ERROR: bad-table-name obj ;
+ERROR: bad-type-modifier obj ;
+ERROR: not-persistent obj ;
+ERROR: duplicate-persistent-columns obj ;
+
+SYMBOL: raw-persistent-table
+SYMBOL: inherited-persistent-table
+
+raw-persistent-table [ H{ } clone ] initialize
+inherited-persistent-table [ H{ } clone ] initialize
+
+<PRIVATE
+
+GENERIC: parse-table-name ( object -- class table )
+GENERIC: parse-name ( object -- accessor column )
+GENERIC: parse-column-type ( object -- string )
+GENERIC: parse-column-modifiers ( object -- string )
+GENERIC: lookup-raw-persistent ( obj -- obj' )
+
+PRIVATE>
+
+GENERIC: >persistent ( obj -- persistent )
+
+SYMBOL: deferred-persistent
+
+: ?>persistent ( class -- persistent/f )
+ raw-persistent-table get ?at [ drop f ] unless ;
+
+: >persistent* ( class -- persistent/f )
+ raw-persistent-table get ?at [ not-persistent ] unless ;
+
+: check-sql-name ( string -- string )
+ [ ] [ ] [ sql-name-replace ] tri = [ bad-table-name ] unless ;
+
+TUPLE: persistent class table-name columns primary-key incomplete? ;
+
+CONSTRUCTOR: <persistent> persistent ( class table-name columns -- obj ) ;
+
+TUPLE: db-column persistent
+slot-name column-name type modifiers getter setter generator ;
+
+GENERIC: compute-generator ( tuple type -- quotation/f )
+
+M: object compute-generator 2drop f ;
+
+M: +random-key+ compute-generator
+ 2drop [ drop 32 random-bits ] ;
+
+: set-generator ( tuple -- tuple )
+ [ dup type>> compute-generator ] [ generator<< ] [ ] tri ;
+
+: <db-column> ( slot-name column-name type modifiers -- obj )
+ db-column new
+ swap ??1array >>modifiers
+ swap >>type
+ swap >>column-name
+ swap >>slot-name
+ set-generator ; inline
+
+: ?cut ( seq n -- before after ) [ short head ] [ short tail ] 2bi ;
+
+ERROR: db-column-must-be-triple extra ;
+: parse-column ( seq -- db-column )
+ 3 ?cut [ db-column-must-be-triple ] unless-empty
+ ?first3
+ [ parse-name ]
+ [ parse-column-type ]
+ [ parse-column-modifiers ] tri* <db-column> ;
+
+: superclass-persistent-columns ( class -- columns )
+ superclasses-of [ ?>persistent ] map
+ sift \ deferred-persistent swap remove
+ [ columns>> ] map concat ;
+
+: join-persistent-hierarchy ( class -- persistent )
+ [ superclass-persistent-columns [ clone ] map ]
+ [ >persistent* clone ] bi
+ [ columns<< ] keep ;
+
+: compute-persistent-slots ( persistent -- )
+ dup columns>>
+ [ [ clone ] change-persistent ] map
+ [ persistent<< ] with each ;
+
+: compute-setters ( persistent -- )
+ columns>> [
+ dup slot-name>>
+ [ lookup-getter 1quotation >>getter ]
+ [ lookup-setter 1quotation >>setter ] bi drop
+ ] each ;
+
+: column-primary-key? ( column -- ? )
+ {
+ [ type>> sql-primary-key? ]
+ [ modifiers>> [ sql-primary-key? ] any? ]
+ } 1|| ;
+
+GENERIC: table-name* ( column -- string )
+
+M: sequence table-name* first table-name* ;
+
+M: db-column table-name* persistent>> table-name>> ;
+
+M: tuple-class table-name* >persistent table-name>> ;
+
+M: tuple table-name* >persistent table-name>> ;
+
+M: in-binder table-name* table-name>> ;
+
+M: out-binder table-name* table-name>> ;
+
+: table-name ( obj -- string )
+ table-name* ;
+
+: quoted-table-name ( obj -- string )
+ table-name* "\"" dup surround ;
+
+GENERIC: find-primary-key ( obj -- seq )
+
+M: persistent find-primary-key ( persistent -- seq )
+ columns>> [ column-primary-key? ] filter ;
+
+M: tuple-class find-primary-key ( class -- seq )
+ >persistent primary-key>> ;
+
+M: tuple find-primary-key ( class -- seq )
+ class-of find-primary-key ;
+
+: db-assigned-key? ( persistent -- ? )
+ find-primary-key [
+ {
+ [ type>> +db-assigned-key+ = ]
+ [ modifiers>> +db-assigned-key+ swap member? ]
+ } 1||
+ ] all? ;
+
+: user-assigned-key? ( class -- ? )
+ find-primary-key [ modifiers>> +primary-key+ swap member? ] all? ;
+
+: compute-primary-key ( persistent -- )
+ dup find-primary-key >>primary-key drop ;
+
+: primary-key-slots ( obj -- seq )
+ >persistent
+ find-primary-key [ [ table-name ] [ slot-name>> ] bi "." glue ] map ;
+
+: remove-primary-key ( slots -- slots' )
+ [ type>> sql-primary-key? not ] filter ;
+ ! [ modifiers>> +primary-key+ swap member? not ] filter ;
+
+: process-persistent ( persistent -- persistent )
+ {
+ [ compute-persistent-slots ]
+ [ compute-setters ]
+ [ compute-primary-key ]
+ [ ]
+ } cleave ;
+
+: check-columns ( persistent -- persistent )
+ dup columns>> [ column-name>> ] map all-unique?
+ [ duplicate-persistent-columns ] unless ;
+
+M: persistent lookup-raw-persistent ;
+M: tuple lookup-raw-persistent class-of lookup-raw-persistent ;
+M: tuple-class lookup-raw-persistent raw-persistent-table get at ;
+
+M: persistent >persistent ;
+
+M: tuple >persistent class-of >persistent ;
+
+M: tuple-class >persistent
+ ! inherited-persistent-table get [
+ join-persistent-hierarchy
+ process-persistent
+ check-columns ;
+ ! ] cache ;
+
+: ensure-persistent ( obj -- obj )
+ dup lookup-raw-persistent [ not-persistent ] unless ;
+
+: ensure-type ( obj -- obj )
+ dup tuple-class? [ ensure-persistent ] [ ensure-sql-type ] if ;
+
+: ensure-type-modifier ( obj -- obj )
+ {
+ { [ dup { sequence } member? ] [ ] }
+ { [ dup integer? ] [ ] }
+ [ bad-type-modifier ]
+ } cond ;
+
+: clear-persistent ( -- )
+ inherited-persistent-table get clear-assoc ;
+
+: rebuild-persistent ( -- )
+ clear-persistent
+ raw-persistent-table get
+ [ deferred-persistent = [ >persistent ] unless drop ] assoc-each ;
+
+: save-persistent ( persistent -- )
+ dup class>> raw-persistent-table get set-at ;
+
+: make-persistent ( class name columns -- )
+ <persistent> save-persistent
+ rebuild-persistent ;
+
+SYNTAX: PERSISTENT:
+ scan-object parse-table-name check-sql-name
+ \ ; parse-until
+ [ parse-column ] map make-persistent ;
+
+! SYNTAX: RECONSTRUCTOR:
+ ! scan scan-object
+ ! [ >persistent ] [ >>reconstructor drop ] bi* ;
+
+SYNTAX: DEFER-PERSISTENT:
+ \ deferred-persistent scan-object
+ raw-persistent-table get ?at [
+ 2drop
+ ] [
+ raw-persistent-table get set-at
+ ] if ;
+
+M: integer parse-table-name throw ;
+
+M: sequence parse-table-name
+ unclip swap
+ unclip swap
+ [ ] [ "." join ] bi* [ "." glue ] unless-empty ;
+
+M: tuple-class parse-table-name
+ dup name>> sql-name-replace ;
+
+M: sequence parse-name
+ 2 ensure-length first2
+ [ ensure-string ] bi@ sql-name-replace ;
+
+M: string parse-name dup 2array parse-name ;
+
+M: word parse-column-type ensure-type ;
+
+M: sequence parse-column-type
+ 2 ensure-length first2
+ [ ensure-type ] [ ensure-type-modifier ] bi* 2array ;
+
+M: word parse-column-modifiers ensure-sql-modifier ;
+
+M: sequence parse-column-modifiers
+ [ ensure-sql-modifier ] map ;
+
+
+
+
+
+
+SYMBOL: table-names
+
+SINGLETONS: one:one one:many many:one many:many ;
+
+ERROR: bad-relation-category obj ;
+ERROR: bad-relation-class obj ;
+
+
+GENERIC: relation-category? ( obj -- ? )
+
+M: sequence relation-category?
+ dup length {
+ { 1 [ first relation-category? ] }
+ { 2 [ first relation-category? ] }
+ [ drop bad-relation-category ]
+ } case ;
+
+M: db-column relation-category? type>> relation-category? ;
+
+M: tuple-class relation-category? drop t ;
+
+M: word relation-category? drop f ;
+
+: relation-columns ( obj -- columns )
+ >persistent
+ columns>> [ type>> relation-category? ] filter ;
+
+
+
+GENERIC: relation-category ( obj -- obj' )
+
+M: db-column relation-category
+ type>> relation-category ;
+
+M: object relation-category drop f ;
+M: tuple-class relation-category drop one:one ;
+
+M: sequence relation-category
+ dup length {
+ { 1 [ first relation-category ] }
+ { 2 [ first2 sequence = [ drop one:many ] [ bad-relation-category ] if ] }
+ [ drop bad-relation-category ]
+ } case ;
+
+
+
+GENERIC: relation-class* ( obj -- obj' )
+
+: relation-class ( column -- obj )
+ type>> relation-class* ;
+
+M: tuple-class relation-class* ;
+
+M: sequence relation-class*
+ dup length {
+ { 0 [ bad-relation-class ] }
+ [ drop first ]
+ } case ;
+
+M: object relation-class* drop f ;
+
+
+: query-shape ( class -- seq )
+ >persistent columns>> [ dup relation-category ] { } map>assoc ;
+
+: filter-persistent ( quot -- seq )
+ [ raw-persistent-table get values ] dip filter ; inline
+
+: map-persistent ( quot -- seq )
+ [ raw-persistent-table get values ] dip { } map-as ; inline
+
+: each-persistent ( quot -- )
+ [ raw-persistent-table get values ] dip each ; inline
+
+: find-many:many-relations ( class -- seq )
+ sequence 2array
+ '[
+ columns>> [ type>> _ = ] filter empty? not
+ ] filter-persistent ;
+
+GENERIC: select-columns* ( obj -- )
+
+M: persistent select-columns*
+ columns>> [ select-columns* ] each ;
+
+M: db-column select-columns*
+ dup type>> {
+ { [ dup tuple-class? ] [ nip >persistent select-columns* ] }
+ [ drop , ]
+ } cond ;
+
+: select-columns ( obj -- seq )
+ [ select-columns* ] { } make ;
+
+
+
+SYMBOL: seq
+SYMBOL: n
+
+GENERIC: select-reconstructor* ( obj -- )
+
+M: persistent select-reconstructor*
+ columns>> [ select-reconstructor* ] each ;
+
+M: db-column select-reconstructor*
+ dup relation-category {
+ { one:one [
+ [ type>> >persistent select-reconstructor* ]
+ [ setter>> , ] bi
+ ] }
+ { one:many [
+ [ relation-class >persistent select-reconstructor* ]
+ [ getter>> '[ over _ push ] , ] bi
+ ] }
+ [ drop n get n inc , seq , \ get , \ nth , setter>> % ]
+ } case ;
+
+: select-reconstructor ( obj -- seq )
+ [
+ 0 n n:set
+ { 1 2 3 4 5 } seq n:set
+ [ select-reconstructor* ] [ ] make
+ ] with-scope ;
+
+: ((column>create-text)) ( db-column -- )
+ {
+ [ type>> sql-create-type>string % ]
+ [ modifiers>> [ " " % sql-modifiers>string % ] when* ]
+ } cleave ;
+
+: (column>create-text) ( db-column -- string )
+ [
+ [ slot-name>> sql-name-replace % " " % ]
+ [ ((column>create-text)) ] bi
+ ] "" make ;
+
+: (columns>create-text) ( seq -- seq )
+ [ (column>create-text) ] map sift ;
+
+: columns>create-text ( seq -- string )
+ (columns>create-text) ", " join ;
+
+: class>foreign-key-create ( class -- string )
+ [ table-name ] [ find-primary-key (columns>create-text) ] bi
+ [ "_" glue ] with map ", " join ;
+
+: class>primary-key-create ( class -- string )
+ find-primary-key [
+ f
+ ] [
+ [ column-name>> ] map "," join
+ ", primary key(" ")" surround
+ ] if-empty ;
+
+: column>create-text ( db-column -- string )
+ dup relation-category {
+ { one:one [ relation-class class>foreign-key-create ] }
+ { one:many [ drop f ] }
+ { many:one [ relation-class class>foreign-key-create ] }
+ { many:many [ drop f ] }
+ { f [ (column>create-text) ] }
+ [ bad-relation-category ]
+ } case ;
+
+: find-one:many-columns ( obj -- seq ) >persistent class>> '[
+ columns>> [ [ relation-class _ = ] [ relation-category one:many =
+ ] bi and ] filter ] map-persistent concat ;
+
+: class>one:many-relations ( class -- string )
+ find-one:many-columns
+ [ persistent>> class>> class>foreign-key-create ] map ", " join ;
+
+: set-primary-key ( tuple obj -- tuple' )
+ over find-primary-key 1 ensure-length
+ first setter>> call( tuple obj -- tuple ) ;
+
+/*
+: select-joins ( obj -- seq )
+ query-shape
+ [ nip ] assoc-filter
+ [
+ {
+ [ first relation-class table-name ]
+ [ first relation-class table-name ]
+ [ first persistent>> primary-key-slots ]
+ [ first relation-class table-name ]
+ [ first relation-class primary-key-slots ]
+ } cleave <left-join>
+ ] map ;
+*/
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations db2.debug orm.examples orm.queries
+orm.tuples tools.test ;
+IN: orm.queries.tests
+
+[ [ \ user drop-table ] ignore-errors ] test-dbs
+
+[ \ user create-table ] test-dbs
+[ \ user drop-table ] test-dbs
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators db2 db2.binders
+db2.connections db2.statements db2.types db2.utils fry kernel
+locals make orm.persistent sequences reconstructors arrays
+orm.binders db2.query-objects ;
+IN: orm.queries
+
+HOOK: create-table-sql db-connection ( tuple-class -- object )
+HOOK: ensure-table-sql db-connection ( tuple-class -- object )
+HOOK: drop-table-sql db-connection ( tuple-class -- object )
+
+HOOK: insert-db-assigned-key-sql db-connection ( tuple -- object )
+HOOK: insert-user-assigned-key-sql db-connection ( tuple -- object )
+HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
+HOOK: update-tuple-sql db-connection ( tuple -- object )
+HOOK: delete-tuple-sql db-connection ( tuple -- object )
+HOOK: select-tuple-sql db-connection ( tuple -- object )
+
+ERROR: can't-reconstruct query ;
+
+: set-reconstructor ( query -- query )
+ ! { { bag >>id } { bean >>id >>bag-id >>color } } rows>tuples
+ dup from>> length 1 = [ can't-reconstruct ] unless
+ {
+ [ from>> first class>> 1array ]
+ [
+ out>> [ column>> setter>> first ] map append 1array
+ '[ _ rows>tuples concat ]
+ ]
+ [ reconstructor<< ]
+ [ ]
+ } cleave ;
+
+HOOK: n>bind-sequence db-connection ( n -- sequence )
+HOOK: continue-bind-sequence db-connection ( previous n -- sequence )
+
+: n>bind-string ( n -- string ) n>bind-sequence "," join ;
+M: object n>bind-sequence "?" <repetition> ;
+M: object continue-bind-sequence nip "?" <repetition> ;
+
+M: object create-table-sql
+ >persistent dup table-name>> quote-sql-name
+ [
+ [
+ [ columns>> ] dip
+ "CREATE TABLE " % %
+ "(" % [ ", " % ] [
+ [ column-name>> % " " % ]
+ [ type>> sql-create-type>string % ]
+ [ modifiers>> " " join % ] tri
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " %
+ "PRIMARY KEY(" %
+ [ "," % ] [ column-name>> % ] interleave
+ ")" %
+ ] unless-empty
+ ");" %
+ ] 2bi
+ ] "" make ;
+
+M: object drop-table-sql
+ >persistent table-name>> quote-sql-name
+ "DROP TABLE " ";" surround ;
+
+: columns>in-binders ( columns tuple -- sequence )
+ '[
+ [ _ swap getter>> ( obj -- slot-value ) call-effect ]
+ [ type>> ] bi
+ <in-binder-low>
+ ] { } map-as ;
+
+M:: object delete-tuple-sql ( tuple -- statement )
+ <statement> :> statement
+ tuple >persistent :> persistent
+
+ statement
+ persistent table-name>> "DELETE FROM " prepend add-sql
+ persistent find-primary-key :> columns:primary-key
+ columns:primary-key length :> #primary-key
+
+ " WHERE " add-sql
+ columns:primary-key tuple columns>in-binders add-in
+
+ columns:primary-key [ column-name>> ] map
+ #primary-key n>bind-sequence zip
+ [ " = " glue ] { } assoc>map ", " join add-sql ;
+
+: call-generators ( columns tuple -- )
+ '[
+ _
+ 2dup swap getter>> call( obj -- obj ) [
+ 2drop
+ ] [
+ over generator>> [
+ dupd call( obj -- obj )
+ rot setter>> call( obj obj -- obj ) drop
+ ] [
+ 2drop
+ ] if*
+ ] if
+ ] each ;
+
+! XXX: include the assoc-filter?
+: filter-tuple-values ( persistent tuple -- assoc )
+ [ columns>> ] dip
+ 2dup call-generators
+ '[ _ over getter>> call( obj -- slot-value ) ] { } map>assoc ;
+
+: filter-empty-tuple-values ( persistent tuple -- assoc )
+ filter-tuple-values
+ [ nip ] assoc-filter ;
+
+! : where-primary-key ( statement persistent tuple -- statement )
+ ! [ find-primary-key ] dip
+ ! [ columns>in-binders add-in ]
+ ! [ drop [ column-name>> ] map " WHERE " prepend add-sql ] 2bi ;
+
+M:: object update-tuple-sql ( tuple -- statement )
+ <statement> :> statement
+ tuple >persistent :> persistent
+
+ statement
+ persistent table-name>> "UPDATE " " SET " surround add-sql
+ persistent columns>> remove-primary-key :> columns:no-primary-key
+ persistent find-primary-key :> columns:primary-key
+ columns:no-primary-key length :> #columns
+ columns:no-primary-key length :> #primary-key
+
+ columns:no-primary-key [ column-name>> ] map
+ #columns n>bind-sequence zip [ " = " glue ] { } assoc>map ", " join add-sql
+
+ columns:no-primary-key tuple columns>in-binders add-in
+ " WHERE " add-sql
+ columns:primary-key tuple columns>in-binders add-in
+
+ columns:primary-key [ column-name>> ] map
+ #columns #primary-key continue-bind-sequence zip [ " = " glue ] { } assoc>map ", " join add-sql ;
+
+
+M: object select-tuple-sql ( tuple -- object )
+ [ <select> ] dip
+ [ >persistent ] [ ] bi {
+ [ filter-empty-tuple-values [ first2 <column-binder-in> ] map >>in ]
+ [ drop columns>> [ <column-binder-out> ] map >>out ]
+ [ drop 1array >>from ]
+ } 2cleave ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.query-objects kernel orm.binders sequences
+orm.persistent ;
+IN: orm.query-objects
+
+: column-binder>qualified-column-name ( column-binder -- string )
+ column>>
+ [ persistent>> table-name>> ] [ column-name>> ] bi "." glue ;
+
+M: column-binder-out >qualified-column-name
+ column-binder>qualified-column-name ;
+
+M: column-binder-in >qualified-column-name
+ column-binder>qualified-column-name ;
+
+M: persistent >table-as table-name>> ;
+
+
+M: column-binder-in binder-operator
+ drop " = " ;
+
+M: column-binder-in flatten-binder ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2 db2.debug db2.types debugger
+kernel orm.persistent orm.tuples sequences
+tools.test ;
+IN: orm.tuples.tests
+
+TUPLE: foo-1 a b ;
+
+PERSISTENT: foo-1
+{ "a" INTEGER +primary-key+ }
+{ "b" VARCHAR } ;
+
+: test-1 ( -- )
+ [ "drop table foo_1" sql-command ] try
+
+ [ ]
+ [ "create table foo_1 (a integer primary key, b varchar)" sql-command ] unit-test
+
+ [ ]
+ [ 1 "lol" foo-1 boa insert-tuple ] unit-test
+
+ [ { { "1" "lol" } } ]
+ [ "select * from foo_1" sql-query ] unit-test
+
+ [ ]
+ [ 1 "omg" foo-1 boa update-tuple ] unit-test
+
+ [ { { "1" "omg" } } ]
+ [ "select * from foo_1" sql-query ] unit-test
+
+ [ { { "1" "omg" } } ]
+ [ "select * from foo_1" sql-query ] unit-test
+
+ [ { T{ foo-1 { a 1 } { b "omg" } } } ]
+ [ T{ foo-1 } select-tuples ] unit-test
+
+ [ ] [ 1 f foo-1 boa delete-tuples ] unit-test
+
+ [ { } ] [ "select * from foo_1" sql-query ] unit-test
+ [ { } ] [ T{ foo-1 } select-tuples ] unit-test
+
+ [ ] [ 1 "lol" foo-1 boa insert-tuple ] unit-test
+
+ [ { T{ foo-1 { a 1 } { b "lol" } } } ]
+ [ T{ foo-1 f 1 } select-tuples ] unit-test
+
+ [ { T{ foo-1 { a 1 } { b "lol" } } } ]
+ [ T{ foo-1 f f "lol" } select-tuples ] unit-test
+
+ [ { T{ foo-1 { a 1 } { b "lol" } } } ]
+ [ T{ foo-1 f 1 "lol" } select-tuples ] unit-test
+ ;
+
+[ test-1 ] test-dbs
+
+TUPLE: foo-2 id a ;
+PERSISTENT: foo-2
+{ "id" INTEGER +primary-key+ }
+{ "a" VARCHAR } ;
+
+TUPLE: bar-2 id b ;
+PERSISTENT: bar-2
+{ "id" INTEGER +primary-key+ }
+{ "b" { foo-2 sequence } } ;
+
+: setup-test-2-sql ( -- )
+ [ "drop table foo_2" sql-command ] try
+ [ "drop table bar_2" sql-command ] try
+
+ [ ] [ "create table foo_2(id integer primary key, a varchar, bar_2_id integer)" sql-command ] unit-test
+ [ ] [ "create table bar_2(id integer primary key)" sql-command ] unit-test
+
+ [ ] [ "insert into foo_2(id, a, bar_2_id) values(0, 'first', 0);" sql-command ] unit-test
+ [ ] [ "insert into foo_2(id, a, bar_2_id) values(1, 'second', 0);" sql-command ] unit-test
+
+ [ ] [ "insert into bar_2(id) values(0);" sql-command ] unit-test
+
+ [
+ {
+ { "0" "0" "first" }
+ { "0" "1" "second" }
+ }
+ ] [ "select bar_2.id, foo_2.id, foo_2.a from bar_2 left join foo_2 on foo_2.bar_2_id = bar_2.id where bar_2.id = 0" sql-query ] unit-test
+
+ ;
+
+: test-2 ( -- )
+ setup-test-2-sql
+
+ ! [ ] [ T{ bar-2 f 0 } select-tuples ] unit-test
+ ;
+
+[ setup-test-2-sql ] test-dbs
+
+[ test-2 ] test-dbs
+
+
+TUPLE: foo-3 id a ;
+PERSISTENT: foo-3
+{ "id" INTEGER +primary-key+ }
+{ "a" VARCHAR } ;
+
+TUPLE: bar-3 id b ;
+PERSISTENT: bar-3
+{ "id" INTEGER +primary-key+ }
+{ "b" { foo-3 sequence } } ;
+
+TUPLE: baz-3 id c ;
+PERSISTENT: baz-3
+{ "id" INTEGER +primary-key+ }
+{ "c" { bar-3 sequence } } ;
+
+: setup-test-3-sql ( -- )
+ [ "drop table foo_3" sql-command ] try
+ [ "drop table bar_3" sql-command ] try
+ [ "drop table baz_3" sql-command ] try
+
+ [ ] [ "create table foo_3(id integer primary key, a varchar, bar_3_id integer)" sql-command ] unit-test
+ [ ] [ "create table bar_3(id integer primary key, baz_3_id integer)" sql-command ] unit-test
+ [ ] [ "create table baz_3(id integer primary key)" sql-command ] unit-test
+
+ [ ] [ "insert into foo_3(id, a, bar_3_id) values(0, 'first', 0);" sql-command ] unit-test
+ [ ] [ "insert into foo_3(id, a, bar_3_id) values(1, 'second', 0);" sql-command ] unit-test
+
+ [ ] [ "insert into foo_3(id, a, bar_3_id) values(2, 'third', 1);" sql-command ] unit-test
+ [ ] [ "insert into foo_3(id, a, bar_3_id) values(3, 'fourth', 1);" sql-command ] unit-test
+
+ [ ] [ "insert into bar_3(id, baz_3_id) values(0, 0);" sql-command ] unit-test
+ [ ] [ "insert into bar_3(id, baz_3_id) values(1, 0);" sql-command ] unit-test
+
+ [ ] [ "insert into baz_3(id) values(0);" sql-command ] unit-test
+
+ [
+ {
+ { "0" "0" "0" "first" }
+ { "0" "0" "1" "second" }
+ { "0" "1" "2" "third" }
+ { "0" "1" "3" "fourth" }
+ }
+ ] [ "select baz_3.id, bar_3.id, foo_3.id, foo_3.a
+ from baz_3
+ left join bar_3 on baz_3.id = bar_3.baz_3_id
+ left join foo_3 on bar_3.id = foo_3.bar_3_id
+ where baz_3.id = 0 order by baz_3.id, bar_3.id, foo_3.id"
+ sql-query
+ ] unit-test ;
+
+[ setup-test-3-sql ] test-dbs
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators combinators.smart db2
+db2.binders db2.errors db2.query-objects db2.types db2.utils fry
+kernel macros make math math.parser mirrors namespaces
+orm orm.persistent orm.queries sequences sets
+splitting.monotonic destructors multiline ;
+IN: orm.tuples
+
+: create-table ( tuple-class -- )
+ create-table-sql sql-command ;
+
+: drop-table ( tuple-class -- )
+ drop-table-sql sql-command ;
+
+: ensure-table ( tuple-class -- )
+ ensure-persistent
+ '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
+
+: ensure-tables ( classes -- ) [ ensure-table ] each ;
+
+: recreate-table ( tuple-class -- )
+ ensure-persistent
+ [
+ '[
+ [
+ _ drop-table-sql sql-command
+ ] ignore-table-missing
+ ] ignore-function-missing
+ ] [ create-table ] bi ;
+
+: recreate-tables ( tuple-classes -- )
+ [ recreate-table ] each ;
+
+: insert-tuple ( tuple -- )
+ dup db-assigned-key? [
+ dup insert-db-assigned-key-sql insert-tuple-set-key
+ ] [
+ insert-user-assigned-key-sql sql-command
+ ] if ;
+
+: update-tuple ( tuple -- )
+ update-tuple-sql sql-command ;
+
+: select-tuples ( tuple -- seq )
+ select-tuple-sql set-reconstructor sql-query ;
+
+: select-tuple ( tuple -- elt/f )
+ select-tuples ?first ;
+
+: count-tuples ( tuple -- n )
+ select-tuples length ;
+
+: delete-tuples ( tuple -- )
+ delete-tuple-sql sql-command ;
+
+
+
+/*
+
+
+: tuple>pairs ( tuple -- seq )
+ [ >persistent columns>> ] [ <mirror> >alist ] bi
+ [ first2 dup IGNORE = [ 3drop f ] [ nip 2array ] if ] 2map sift ;
+
+GENERIC# pair>binder* 1 ( binder pair -- binder )
+
+: (pair>binder) ( binder pair -- binder )
+ {
+ [ first persistent>> class>> >>class ]
+ [
+ first
+ [ persistent>> table-name>> "0" ]
+ [ column-name>> ] bi <table-ordinal-column> >>toc
+ ]
+ [ first type>> >>type ]
+ } cleave ;
+
+M: in-binder pair>binder* ( binder-class pair -- binder )
+ [ (pair>binder) ] [ second >>value ] bi ;
+
+M: out-binder pair>binder* ( binder-class pair -- binder )
+ (pair>binder) ;
+
+: pair>binder ( pair binder-class -- binder ) new swap pair>binder* ;
+
+: tuple>binders ( tuple binder -- seq )
+ [ tuple>pairs ] dip '[ _ pair>binder ] map ;
+
+: insert-tuple ( tuple -- )
+ [ <insert> ] dip
+ in-binder tuple>binders >>in
+ query-object>statement sql-command ;
+
+
+: tuple>primary-key-binders ( tuple -- seq )
+ [ find-primary-key ] keep '[
+ dup slot-name>> _ get-slot-named
+ 2array equal-binder pair>binder
+ ] map ;
+
+
+: update-tuple ( tuple -- )
+ [ <update> ] dip
+ {
+ [ equal-binder tuple>binders >>in ]
+ [ tuple>primary-key-binders >>where ]
+ } cleave
+ query-object>statement sql-command ;
+
+
+: delete-tuples ( tuple -- )
+ [ <delete> ] dip
+ tuple>primary-key-binders >>where
+ query-object>statement sql-command ;
+
+ERROR: no-setter ;
+
+: out-binder>setter ( toc -- word )
+ [ class>> >persistent columns>> ]
+ [ toc>> column-name>> ] bi '[ column-name>> _ = ] find
+ nip [ no-setter ] unless* setter>> ;
+
+MACRO: query-object>reconstructor ( tuple -- quot )
+B
+ out>> [ [ class>> ] bi@ = ] monotonic-split
+ [ [ first class>> ] [ [ out-binder>setter ] map ] bi ] { } map>assoc
+ [
+ [
+ first2
+ [ , \ new , ]
+ [ reverse [ \ swap , , (( obj obj -- obj )) , \ call-effect , ] each ] bi*
+ ] each
+ ] [ ] make '[ [ _ input<sequence ] ] ;
+
+SYMBOL: ordinal
+
+: next-ordinal ( -- string )
+ ordinal [ dup 1 + ] change number>string ;
+
+: (select-tuples) ( tuple -- tuple )
+ 0 ordinal [
+ [ <select> ] dip {
+ [ out-binder tuple>binders >>out ]
+ [ equal-binder tuple>binders [ value>> ] filter >>in ]
+ [
+ tuple>pairs [ first persistent>> table-name>> ] map members
+ [ next-ordinal <table-ordinal> ] map >>from
+ ]
+ } cleave
+ ] with-variable ;
+
+MACRO: select-tuples ( tuple -- tuples )
+ (select-tuples)
+ [ query-object>statement sql-query ] keep
+B
+ query-object>reconstructor
+ '[ [ @ ] map ] ;
+
+: reconstruct ( seq quot tuple -- seq' )
+ 2drop
+ ;
+
+! : select-tuple ( tuple -- tuple/f )
+ ! [ (select-tuples) 1 >>limit sql-query ] [ make-reconstructor ] [ ] tri reconstruct ;
+
+: count-tuples ( tuple -- n )
+ ;
+*/
+
+
+/*
+TUPLE: foo a b ;
+
+PERSISTENT: foo
+{ "a" INTEGER +primary-key+ }
+{ "b" VARCHAR } ;
+[ [ "drop table foo" sql-command ] test-sqlite ] try
+[ "create table foo (a integer primary key, b varchar)" sql-command ] test-sqlite
+[ 1 "lol" foo boa insert-tuple ] test-sqlite
+[ "select * from foo" sql-query . ] test-sqlite
+[ "update foo set a=1, b='omg' where a=1" sql-command ] test-sqlite
+[ "select * from foo" sql-query . ] test-sqlite
+[ 1 f foo boa (select-tuples) query-object>statement ] test-sqlite
+*/
+
+
+/*
+ERROR: unimplemented ;
+
+: select-relations ( tuple relations -- seq )
+ unimplemented
+ drop
+ ;
+
+: select-no-relations ( tuple -- seq )
+
+ ;
+
+
+
+: select-tuples2 ( tuple -- seq )
+ dup tuple>relations [
+ select-no-relations
+ ] [
+ select-relations
+ ] if-empty ;
+
+*/
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: postgresql.db2.connections db2.debug tools.test ;
+IN: postgresql.db2.connections.tests
+
+[ ] [
+ [ ] test-postgresql
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.errors
+postgresql.db2 postgresql.db2.errors postgresql.db2.ffi
+postgresql.db2.lib kernel sequences splitting destructors ;
+IN: postgresql.db2.connections
+
+<PRIVATE
+
+TUPLE: postgresql-db-connection < db-connection ;
+
+: <postgresql-db-connection> ( handle -- db-connection )
+ \ postgresql-db-connection new-db-connection ;
+
+PRIVATE>
+
+M: postgresql-db db>db-connection-generic ( db -- db-connection )
+ {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ database>> ]
+ [ username>> ]
+ [ password>> ]
+ } cleave connect-postgres <postgresql-db-connection> ;
+
+M: postgresql-db-connection dispose* ( db-connection -- )
+ [ handle>> PQfinish ] [ f >>handle drop ] bi ;
+
+ERROR: postgresql:sql-error string length ;
+
+M: postgresql-db-connection parse-sql-error
+ "\n" split dup length {
+ { 1 [ first parse-postgresql-sql-error ] }
+ { 3 [
+ first3
+ [ parse-postgresql-sql-error ] 2dip
+ postgresql-location >>location
+ ] }
+ [ postgresql:sql-error ]
+ } case ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs.loader vocabs ;
+IN: postgresql.db2
+
+TUPLE: postgresql-db
+ host port pgopts pgtty database username password ;
+
+: <postgresql-db> ( -- postgresql-db )
+ postgresql-db new ; inline
+
+{
+ "postgresql.db2.connections"
+ "postgresql.db2.errors"
+ "postgresql.db2.ffi"
+ "postgresql.db2.lib"
+ "postgresql.db2.result-sets"
+ "postgresql.db2.statements"
+ "postgresql.db2.types"
+ "postgresql.db2.queries"
+ ! "postgresql.db2.introspection"
+
+ "postgresql.orm"
+} [ require ] each
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.errors kernel locals.types math math.parser
+multiline peg.ebnf sequences strings ;
+IN: postgresql.db2.errors
+
+EBNF: parse-postgresql-sql-error [=[
+
+Error = "ERROR:" [ ]+
+
+TableError =
+ Error ("relation "|"table ")(!(" already exists").)+:table " already exists"
+ => [[ table >string unquote <sql-table-exists> ]]
+ | Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist"
+ => [[ table >string unquote <sql-table-missing> ]]
+
+FunctionError =
+ Error "function" (!(" already exists").)+:table " already exists"
+ => [[ table >string <sql-function-exists> ]]
+ | Error "function" (!(" does not exist").)+:table " does not exist"
+ => [[ table >string <sql-function-missing> ]]
+
+SyntaxError =
+ Error "syntax error at end of input":error
+ => [[ error >string <sql-syntax-error> ]]
+ | Error "syntax error at or near " .+:syntaxerror
+ => [[ syntaxerror >string unquote <sql-syntax-error> ]]
+
+UnknownError = .* => [[ >string <sql-unknown-error> ]]
+
+PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
+
+]=]
+
+TUPLE: parse-postgresql-location column line text ;
+C: <parse-postgresql-location> parse-postgresql-location
+
+EBNF: parse-postgresql-line-error [=[
+
+Line = "LINE " [0-9]+:line ": " .+:sql
+ => [[ f line >string string>number sql >string <parse-postgresql-location> ]]
+
+]=]
+
+:: set-caret-position ( error caret-line -- error )
+ caret-line length
+ error line>> number>string length "LINE : " length +
+ - [ error ] dip >>column ;
+
+: postgresql-location ( line column -- obj )
+ [ parse-postgresql-line-error ] dip
+ set-caret-position ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! tested on debian linux with postgresql 8.1
+USING: alien alien.c-types alien.syntax combinators system
+alien.libraries ;
+IN: postgresql.db2.ffi
+
+<< "postgresql" {
+ { [ os windows? ] [ "libpq.dll" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
+ { [ os unix? ] [ "libpq.so" ] }
+} cond cdecl add-library >>
+
+! ConnSatusType
+CONSTANT: CONNECTION_OK 0
+CONSTANT: CONNECTION_BAD 1
+CONSTANT: CONNECTION_STARTED 2
+CONSTANT: CONNECTION_MADE 3
+CONSTANT: CONNECTION_AWAITING_RESPONSE 4
+CONSTANT: CONNECTION_AUTH_OK 5
+CONSTANT: CONNECTION_SETENV 6
+CONSTANT: CONNECTION_SSL_STARTUP 7
+CONSTANT: CONNECTION_NEEDED 8
+
+! PostgresPollingStatusType
+CONSTANT: PGRES_POLLING_FAILED 0
+CONSTANT: PGRES_POLLING_READING 1
+CONSTANT: PGRES_POLLING_WRITING 2
+CONSTANT: PGRES_POLLING_OK 3
+CONSTANT: PGRES_POLLING_ACTIVE 4
+
+! ExecStatusType;
+CONSTANT: PGRES_EMPTY_QUERY 0
+CONSTANT: PGRES_COMMAND_OK 1
+CONSTANT: PGRES_TUPLES_OK 2
+CONSTANT: PGRES_COPY_OUT 3
+CONSTANT: PGRES_COPY_IN 4
+CONSTANT: PGRES_BAD_RESPONSE 5
+CONSTANT: PGRES_NONFATAL_ERROR 6
+CONSTANT: PGRES_FATAL_ERROR 7
+
+! PGTransactionStatusType;
+CONSTANT: PQTRANS_IDLE 0
+CONSTANT: PQTRANS_ACTIVE 1
+CONSTANT: PQTRANS_INTRANS 2
+CONSTANT: PQTRANS_INERROR 3
+CONSTANT: PQTRANS_UNKNOWN 4
+
+! PGVerbosity;
+CONSTANT: PQERRORS_TERSE 0
+CONSTANT: PQERRORS_DEFAULT 1
+CONSTANT: PQERRORS_VERBOSE 2
+
+CONSTANT: InvalidOid 0
+
+TYPEDEF: int ConnStatusType
+TYPEDEF: int ExecStatusType
+TYPEDEF: int PostgresPollingStatusType
+TYPEDEF: int PGTransactionStatusType
+TYPEDEF: int PGVerbosity
+
+C-TYPE: PGconn
+C-TYPE: PGresult
+C-TYPE: PGcancel
+TYPEDEF: uint Oid
+TYPEDEF: char pqbool
+C-TYPE: PQconninfoOption
+C-TYPE: PGnotify
+C-TYPE: PQArgBlock
+C-TYPE: PQprintOpt
+C-TYPE: SSL
+C-TYPE: FILE
+
+LIBRARY: postgresql
+
+! Exported functions of libpq
+
+! make a new client connection to the backend
+! Asynchronous (non-blocking)
+FUNCTION: PGconn* PQconnectStart ( c-string conninfo )
+FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn )
+
+! Synchronous (blocking)
+FUNCTION: PGconn* PQconnectdb ( c-string conninfo )
+FUNCTION: PGconn* PQsetdbLogin ( c-string pghost, c-string pgport,
+ c-string pgoptions, c-string pgtty,
+ c-string dbName,
+ c-string login, c-string pwd )
+
+: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
+ f f PQsetdbLogin ;
+
+! close the current connection and free the PGconn data structure
+FUNCTION: void PQfinish ( PGconn* conn )
+
+! get info about connection options known to PQconnectdb
+FUNCTION: PQconninfoOption* PQconndefaults ( )
+
+! free the data structure returned by PQconndefaults()
+FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions )
+
+! Asynchronous (non-blocking)
+FUNCTION: int PQresetStart ( PGconn* conn )
+FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn )
+
+! Synchronous (blocking)
+FUNCTION: void PQreset ( PGconn* conn )
+
+! request a cancel structure
+FUNCTION: PGcancel* PQgetCancel ( PGconn* conn )
+
+! free a cancel structure
+FUNCTION: void PQfreeCancel ( PGcancel* cancel )
+
+! issue a cancel request
+FUNCTION: int PQrequestCancel ( PGconn* conn )
+
+! Accessor functions for PGconn objects
+FUNCTION: c-string PQdb ( PGconn* conn )
+FUNCTION: c-string PQuser ( PGconn* conn )
+FUNCTION: c-string PQpass ( PGconn* conn )
+FUNCTION: c-string PQhost ( PGconn* conn )
+FUNCTION: c-string PQport ( PGconn* conn )
+FUNCTION: c-string PQtty ( PGconn* conn )
+FUNCTION: c-string PQoptions ( PGconn* conn )
+FUNCTION: ConnStatusType PQstatus ( PGconn* conn )
+FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn )
+FUNCTION: c-string PQparameterStatus ( PGconn* conn,
+ c-string paramName )
+FUNCTION: int PQprotocolVersion ( PGconn* conn )
+! FUNCTION: int PQServerVersion ( PGconn* conn )
+FUNCTION: c-string PQerrorMessage ( PGconn* conn )
+FUNCTION: int PQsocket ( PGconn* conn )
+FUNCTION: int PQbackendPID ( PGconn* conn )
+FUNCTION: int PQclientEncoding ( PGconn* conn )
+FUNCTION: int PQsetClientEncoding ( PGconn* conn, c-string encoding )
+
+! May not be compiled into libpq
+! Get the SSL structure associated with a connection
+FUNCTION: SSL* PQgetssl ( PGconn* conn )
+
+! Tell libpq whether it needs to initialize OpenSSL
+FUNCTION: void PQinitSSL ( int do_init )
+
+! Set verbosity for PQerrorMessage and PQresultErrorMessage
+FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
+ PGVerbosity verbosity )
+
+! Enable/disable tracing
+FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port )
+FUNCTION: void PQuntrace ( PGconn* conn )
+
+! BROKEN
+! Function types for notice-handling callbacks
+! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
+! typedef void (*PQnoticeProcessor) (void *arg, c-string message);
+! ALIAS: void* PQnoticeReceiver
+! ALIAS: void* PQnoticeProcessor
+
+! Override default notice handling routines
+! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
+ ! PQnoticeReceiver proc,
+ ! void* arg ) ;
+! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
+ ! PQnoticeProcessor proc,
+ ! void* arg ) ;
+! END BROKEN
+
+! === in fe-exec.c ===
+
+! Simple synchronous query
+FUNCTION: PGresult* PQexec ( PGconn* conn, c-string query )
+FUNCTION: PGresult* PQexecParams ( PGconn* conn,
+ c-string command,
+ int nParams,
+ Oid* paramTypes,
+ c-string* paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat )
+FUNCTION: PGresult* PQprepare ( PGconn* conn, c-string stmtName,
+ c-string query, int nParams,
+ Oid* paramTypes )
+FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
+ c-string stmtName,
+ int nParams,
+ c-string* paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat )
+
+! Interface for multiple-result or asynchronous queries
+FUNCTION: int PQsendQuery ( PGconn* conn, c-string query )
+FUNCTION: int PQsendQueryParams ( PGconn* conn,
+ c-string command,
+ int nParams,
+ Oid* paramTypes,
+ c-string* paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat )
+FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, c-string stmtName,
+ c-string query, int nParams,
+ Oid* paramTypes )
+FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
+ c-string stmtName,
+ int nParams,
+ c-string* paramValues,
+ int *paramLengths,
+ int *paramFormats,
+ int resultFormat )
+FUNCTION: PGresult* PQgetResult ( PGconn* conn )
+
+! Routines for managing an asynchronous query
+FUNCTION: int PQisBusy ( PGconn* conn )
+FUNCTION: int PQconsumeInput ( PGconn* conn )
+
+! LISTEN/NOTIFY support
+FUNCTION: PGnotify* PQnotifies ( PGconn* conn )
+
+! Routines for copy in/out
+FUNCTION: int PQputCopyData ( PGconn* conn, c-string buffer, int nbytes )
+FUNCTION: int PQputCopyEnd ( PGconn* conn, c-string errormsg )
+FUNCTION: int PQgetCopyData ( PGconn* conn, c-string* buffer, int async )
+
+! Deprecated routines for copy in/out
+FUNCTION: int PQgetline ( PGconn* conn, c-string string, int length )
+FUNCTION: int PQputline ( PGconn* conn, c-string string )
+FUNCTION: int PQgetlineAsync ( PGconn* conn, c-string buffer, int bufsize )
+FUNCTION: int PQputnbytes ( PGconn* conn, c-string buffer, int nbytes )
+FUNCTION: int PQendcopy ( PGconn* conn )
+
+! Set blocking/nonblocking connection to the backend
+FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg )
+FUNCTION: int PQisnonblocking ( PGconn* conn )
+
+! Force the write buffer to be written (or at least try)
+FUNCTION: int PQflush ( PGconn* conn )
+
+!
+! * "Fast path" interface --- not really recommended for application
+! * use
+!
+FUNCTION: PGresult* PQfn ( PGconn* conn,
+ int fnid,
+ int* result_buf,
+ int* result_len,
+ int result_is_int,
+ PQArgBlock* args,
+ int nargs )
+
+! Accessor functions for PGresult objects
+FUNCTION: ExecStatusType PQresultStatus ( PGresult* res )
+FUNCTION: c-string PQresStatus ( ExecStatusType status )
+FUNCTION: c-string PQresultErrorMessage ( PGresult* res )
+FUNCTION: c-string PQresultErrorField ( PGresult* res, int fieldcode )
+FUNCTION: int PQntuples ( PGresult* res )
+FUNCTION: int PQnfields ( PGresult* res )
+FUNCTION: int PQbinaryTuples ( PGresult* res )
+FUNCTION: c-string PQfname ( PGresult* res, int field_num )
+FUNCTION: int PQfnumber ( PGresult* res, c-string field_name )
+FUNCTION: Oid PQftable ( PGresult* res, int field_num )
+FUNCTION: int PQftablecol ( PGresult* res, int field_num )
+FUNCTION: int PQfformat ( PGresult* res, int field_num )
+FUNCTION: Oid PQftype ( PGresult* res, int field_num )
+FUNCTION: int PQfsize ( PGresult* res, int field_num )
+FUNCTION: int PQfmod ( PGresult* res, int field_num )
+FUNCTION: c-string PQcmdStatus ( PGresult* res )
+FUNCTION: c-string PQoidStatus ( PGresult* res )
+FUNCTION: Oid PQoidValue ( PGresult* res )
+FUNCTION: c-string PQcmdTuples ( PGresult* res )
+! FUNCTION: c-string PQgetvalue ( PGresult* res, int tup_num, int field_num )
+FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num )
+FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num )
+FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num )
+
+! Delete a PGresult
+FUNCTION: void PQclear ( PGresult* res )
+
+! For freeing other alloc'd results, such as PGnotify structs
+FUNCTION: void PQfreemem ( void* ptr )
+
+! Exists for backward compatibility.
+: PQfreeNotify ( ptr -- ) PQfreemem ;
+
+!
+! Make an empty PGresult with given status (some apps find this
+! useful). If conn is not NULL and status indicates an error, the
+! conn's errorMessage is copied.
+!
+FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status )
+
+! Quoting strings before inclusion in queries.
+FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
+ c-string to, c-string from, size_t length,
+ int* error )
+FUNCTION: c-string PQescapeByteaConn ( PGconn* conn,
+ c-string from, size_t length,
+ size_t* to_length )
+FUNCTION: void* PQunescapeBytea ( c-string strtext, size_t* retbuflen )
+! FUNCTION: c-string PQunescapeBytea ( c-string strtext, size_t* retbuflen )
+! These forms are deprecated!
+FUNCTION: size_t PQescapeString ( void* to, c-string from, size_t length )
+FUNCTION: c-string PQescapeBytea ( c-string bintext, size_t binlen,
+ size_t* bytealen )
+
+! === in fe-print.c ===
+
+FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps )
+
+! really old printing routines
+FUNCTION: void PQdisplayTuples ( PGresult* res,
+ FILE* fp,
+ int fillAlign,
+ c-string fieldSep,
+ int printHeader,
+ int quiet )
+
+FUNCTION: void PQprintTuples ( PGresult* res,
+ FILE* fout,
+ int printAttName,
+ int terseOutput,
+ int width )
+! === in fe-lobj.c ===
+
+! Large-object access routines
+FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode )
+FUNCTION: int lo_close ( PGconn* conn, int fd )
+FUNCTION: int lo_read ( PGconn* conn, int fd, c-string buf, size_t len )
+FUNCTION: int lo_write ( PGconn* conn, int fd, c-string buf, size_t len )
+FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence )
+FUNCTION: Oid lo_creat ( PGconn* conn, int mode )
+! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: int lo_tell ( PGconn* conn, int fd )
+FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId )
+FUNCTION: Oid lo_import ( PGconn* conn, c-string filename )
+FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, c-string filename )
+
+! === in fe-misc.c ===
+
+! Determine length of multibyte encoded char at *s
+FUNCTION: int PQmblen ( c-string s, int encoding )
+
+! Determine display length of multibyte encoded char at *s
+FUNCTION: int PQdsplen ( c-string s, int encoding )
+
+! Get encoding id from environment variable PGCLIENTENCODING
+FUNCTION: int PQenv2encoding ( )
+
+! From git, include/catalog/pg_type.h
+CONSTANT: BOOL-OID 16
+CONSTANT: BYTEA-OID 17
+CONSTANT: CHAR-OID 18
+CONSTANT: NAME-OID 19
+CONSTANT: INT8-OID 20
+CONSTANT: INT2-OID 21
+CONSTANT: INT4-OID 23
+CONSTANT: TEXT-OID 23
+CONSTANT: OID-OID 26
+CONSTANT: FLOAT4-OID 700
+CONSTANT: FLOAT8-OID 701
+CONSTANT: VARCHAR-OID 1043
+CONSTANT: DATE-OID 1082
+CONSTANT: TIME-OID 1083
+CONSTANT: TIMESTAMP-OID 1114
+CONSTANT: TIMESTAMPTZ-OID 1184
+CONSTANT: INTERVAL-OID 1186
+CONSTANT: NUMERIC-OID 1700
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.introspection db2.types kernel orm.persistent
+orm.tuples postgresql.db2.connections.private ;
+IN: postgresql.db2.introspection
+
+TUPLE: postgresql-object schemaname tablename tableowner tablespace
+hasindexes hasrules hastriggers ;
+
+PERSISTENT: { postgresql-object "pg_tables" }
+ { "schemaname" TEXT }
+ { "tablename" TEXT }
+ { "tableowner" TEXT }
+ { "tablespace" TEXT }
+ { "hasindexes" BOOLEAN }
+ { "hasrules" BOOLEAN }
+ { "hastriggers" BOOLEAN } ;
+
+TUPLE: information-schema-column
+ table_catalog
+ table_schema
+ table_name
+ column_name
+ ordinal_position
+ column_default
+ is_nullable
+ data_type
+ character_maximum_length
+ character_octet_length
+ numeric_precision
+ numeric_precision_radix
+ numeric_scale
+ datetime_precision
+ interval_type
+ interval_precision
+ character_set_catalog
+ character_set_schema
+ character_set_name
+ collation_catalog
+ collation_schema
+ collation_name
+ domain_catalog
+ domain_schema
+ domain_name
+ udt_catalog
+ udt_schema
+ udt_name
+ scope_catalog
+ scope_schema
+ scope_name
+ maximum_cardinality
+ dtd_identifier
+ is_self_referencing
+ is_identity
+ identity_generation
+ identity_start
+ identity_increment
+ identity_maximum
+ identity_minimum
+ identity_cycle
+ is_generated
+ generation_expression
+ is_updatable ;
+
+PERSISTENT: { information-schema-column "information_schema" "columns" }
+ { "table_catalog" VARCHAR }
+ { "table_schema" VARCHAR }
+ { "table_name" VARCHAR }
+ { "column_name" VARCHAR }
+ { "ordinal_position" INTEGER }
+ { "column_default" CHARACTER }
+ { "is_nullable" CHARACTER }
+ { "data_type" CHARACTER }
+ { "character_maximum_length" INTEGER }
+ { "character_octet_length" INTEGER }
+ { "numeric_precision" INTEGER }
+ { "numeric_precision_radix" INTEGER }
+ { "numeric_scale" INTEGER }
+ { "datetime_precision" INTEGER }
+ { "interval_type" CHARACTER }
+ { "interval_precision" CHARACTER }
+ { "character_set_catalog" VARCHAR }
+ { "character_set_schema" VARCHAR }
+ { "character_set_name" VARCHAR }
+ { "collation_catalog" VARCHAR }
+ { "collation_schema" VARCHAR }
+ { "collation_name" VARCHAR }
+ { "domain_catalog" VARCHAR }
+ { "domain_schema" VARCHAR }
+ { "domain_name" VARCHAR }
+ { "udt_catalog" VARCHAR }
+ { "udt_schema" VARCHAR }
+ { "udt_name" VARCHAR }
+ { "scope_catalog" VARCHAR }
+ { "scope_schema" VARCHAR }
+ { "scope_name" VARCHAR }
+ { "maximum_cardinality" INTEGER }
+ { "dtd_identifier" VARCHAR }
+ { "is_self_referencing" CHARACTER }
+ { "is_identity" CHARACTER }
+ { "identity_generation" CHARACTER }
+ { "identity_start" CHARACTER }
+ { "identity_increment" CHARACTER }
+ { "identity_maximum" CHARACTER }
+ { "identity_minimum" CHARACTER }
+ { "identity_cycle" CHARACTER }
+ { "is_generated" CHARACTER }
+ { "generation_expression" CHARACTER }
+ { "is_updatable" CHARACTER } ;
+
+
+M: postgresql-db-connection all-tables
+ postgresql-object new select-tuples ;
+
+M: postgresql-db-connection table-columns
+ information-schema-column new
+ swap >>table_name
+ select-tuples ;
+
+! M: postgresql-db-connection all-db-objects
+
+! M: postgresql-db-connection all-indices
+
+! M: postgresql-db-connection temporary-db-objects
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays continuations db2 io kernel math namespaces
+quotations sequences postgresql.db2.ffi alien alien.c-types
+alien.data db2.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 db2.utils db2.connections ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
+IN: postgresql.db2.lib
+
+: 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 ;
+
+: pq-get-boolean ( handle row column -- ? )
+ pq-get-string dup [ "t" = ] when ;
+
+: postgresql-result-error-message ( res -- str/f )
+ dup 0 = [ 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) 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 ;
+
+: default-param-value ( obj -- alien n )
+ ?number>string dup [ utf8 malloc-string &free ] when 0 ;
+
+
+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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays db2 db2.connections db2.queries
+db2.statements kernel namespaces postgresql.db2
+postgresql.db2.connections.private ;
+IN: postgresql.db2.queries
+
+M: postgresql-db-connection current-db-name
+ db-connection get db>> database>> ;
+
+TUPLE: postgresql-object < sql-object
+ table-catalog
+ table-schema
+ table-name
+ table-type
+ self-referencing-column-name
+ reference-generation
+ user-defined-type-catalog
+ user-defined-type-schema
+ user-defined-type-name
+ is-insertable-into
+ is-typed
+ commit-action ;
+
+TUPLE: postgresql-column < sql-column
+ table_catalog table_schema table_name column_name ordinal_position column_default is_nullable data_type character_maximum_length character_octet_length numeric_precision numeric_precision_radix numeric_scale datetime_precision interval_type interval_precision character_set_catalog character_set_schema character_set_name collation_catalog collation_schema collation_name domain_catalog domain_schema domain_name udt_catalog udt_schema udt_name scope_catalog scope_schema scope_name maximum_cardinality dtd_identifier is_self_referencing is_identity identity_generation identity_start identity_increment identity_maximum identity_minimum identity_cycle is_generated generation_expression is_updatable ;
+
+M: postgresql-db-connection sql-object-class postgresql-object ;
+M: postgresql-db-connection sql-column-class postgresql-column ;
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays
+calendar.format combinators db2.binders db2.connections db2.errors
+db2.result-sets db2.statements db2.types db2.utils destructors
+io.encodings.utf8 kernel libc math namespaces
+postgresql.db2.connections postgresql.db2.connections.private
+postgresql.db2.ffi postgresql.db2.lib postgresql.db2.statements
+postgresql.db2.types present sequences serialize
+specialized-arrays urls strings orm.binders ;
+IN: postgresql.db2.result-sets
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
+
+TUPLE: postgresql-result-set < result-set ;
+
+M: postgresql-result-set dispose
+ [ handle>> PQclear ] [ f >>handle drop ] bi ;
+
+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 ; inline
+
+M: postgresql-result-set advance-row ( result-set -- )
+ [ 1 + ] change-n drop ;
+
+M: postgresql-result-set more-rows? ( result-set -- ? )
+ [ n>> ] [ max>> ] bi < ;
+
+: 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>> [ type>oid ] uint-array{ } map-as ;
+
+: default-param-value ( obj -- alien n )
+ ?number>string dup [ utf8 malloc-string &free ] when 0 ;
+
+ERROR: postgresql-obj-error obj ;
+: obj>value/type ( obj -- value type )
+ {
+ { [ dup string? ] [ VARCHAR ] }
+ { [ dup array? ] [ first2 ] }
+ { [ dup in-binder-low? ] [ [ value>> ] [ type>> ] bi ] }
+ { [ dup column-binder-in? ] [ [ value>> ] [ column>> type>> ] bi ] }
+ [ postgresql-obj-error ]
+ } cond ;
+
+: param-values ( statement -- seq seq2 )
+ in>>
+ [
+ obj>value/type
+ {
+ { FACTOR-BLOB [
+ dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
+ ] }
+ { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
+ { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
+ { TIME [ dup [ timestamp>hms ] when default-param-value ] }
+ { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ { URL [ dup [ present ] when default-param-value ] }
+ [ drop default-param-value ]
+ } case 2array
+ ] map flip [
+ f f
+ ] [
+ first2 [ void*-array{ } like ] [ uint-array{ } like ] bi*
+ ] if-empty ;
+
+: param-formats ( statement -- seq )
+ in>> [ type>param-format ] uint-array{ } map-as ;
+
+M: postgresql-db-connection statement>result-set ( statement -- result-set )
+ dup
+ [
+ [ db-connection get handle>> ] dip
+ {
+ [ sql>> ]
+ [ in>> length ]
+ [ param-types ]
+ [ param-values ]
+ [ param-formats ]
+ } cleave
+ 0 PQexecParams dup postgresql-result-ok? [
+ [
+ postgresql-result-error-message parse-sql-error
+ ] [ PQclear ] bi throw
+ ] unless
+ ] with-destructors
+ \ postgresql-result-set new-result-set
+ init-result-set ;
+
+M: postgresql-result-set column
+ [ [ handle>> ] [ n>> ] bi ] 2dip
+ dup array? [ first ] when
+ {
+ { +db-assigned-key+ [ pq-get-number ] }
+ { +random-key+ [ pq-get-number ] }
+ { INTEGER [ pq-get-number ] }
+ { BIG-INTEGER [ pq-get-number ] }
+ { DOUBLE [ pq-get-number ] }
+ { TEXT [ pq-get-string ] }
+ { VARCHAR [ pq-get-string ] }
+ { CHARACTER [ pq-get-string ] }
+ { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
+ { TIME [ pq-get-string dup [ hms>duration ] when ] }
+ { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ pq-get-blob ] }
+ { BOOLEAN [ pq-get-boolean ] }
+ { URL [ pq-get-string dup [ >url ] when ] }
+ { FACTOR-BLOB [
+ pq-get-blob
+ dup [ bytes>object ] when ] }
+ [ no-sql-type ]
+ } case ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections
+postgresql.db2.connections.private postgresql.db2.ffi
+postgresql.db2.lib db2.statements destructors kernel namespaces
+sequences math.parser ;
+IN: postgresql.db2.statements
+
+M: postgresql-db-connection prepare-statement*
+ dup
+ [ db-connection get handle>> "statementname-can'tbef?" ] dip
+ [ sql>> ] [ in>> ] bi length f
+ PQprepare postgresql-error >>handle ;
+
+M: postgresql-db-connection dispose-statement
+ dup handle>> PQclear
+ f >>handle drop ;
+
+M: postgresql-db-connection bind-sequence drop ;
+
+SYMBOL: postgresql-bind-counter
+
+M: postgresql-db-connection init-bind-index ( -- )
+ 1 postgresql-bind-counter set ;
+
+M: postgresql-db-connection next-bind-index ( -- string )
+ postgresql-bind-counter
+ [ get number>string ] [ inc ] bi "$" prepend ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2 db2.statements db2.statements.tests db2.debug
+tools.test ;
+IN: postgresql.db2.tests
+
+: test-sql-bound-commands ( -- )
+ create-computer-table
+
+ [ ] [
+ <statement>
+ "insert into computer (name, os, version) values($1, $2, $3);" >>sql
+ { "clubber" "windows" "7" } >>in
+ sql-command
+ ] unit-test
+
+ [ { { "windows" } } ] [
+ <statement>
+ "select os from computer where name = $1;" >>sql
+ { "clubber" } >>in
+ sql-query
+ ] unit-test ;
+
+[ test-sql-bound-commands ] test-postgresql
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings arrays
+calendar.format combinators postgresql.db2.connections
+postgresql.db2.connections.private
+postgresql.db2.ffi postgresql.db2.lib db2.types destructors
+io.encodings.utf8 kernel math math.parser multiline sequences
+serialize strings urls ;
+IN: postgresql.db2.types
+
+M: postgresql-db-connection sql-type>string
+ dup array? [ first ] when
+ {
+ { INTEGER [ "INTEGER" ] }
+ { BIG-INTEGER [ "INTEGER " ] }
+ { SIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { UNSIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { DOUBLE [ "DOUBLE" ] }
+ { REAL [ "DOUBLE" ] }
+ { BOOLEAN [ "BOOLEAN" ] }
+ { TEXT [ "TEXT" ] }
+ { VARCHAR [ "TEXT" ] }
+ { CHARACTER [ "TEXT" ] }
+ { DATE [ "DATE" ] }
+ { TIME [ "TIME" ] }
+ { DATETIME [ "TIMESTAMP" ] }
+ { TIMESTAMP [ "TIMESTAMP" ] }
+ { BLOB [ "BYTEA" ] }
+ { FACTOR-BLOB [ "BYTEA" ] }
+ { URL [ "TEXT" ] }
+ { +db-assigned-key+ [ "INTEGER" ] }
+ { +random-key+ [ "BIGINT" ] }
+ [ no-sql-type ]
+ } case ;
+
+M: postgresql-db-connection sql-create-type>string
+ dup array? [ first ] when
+ {
+ { INTEGER [ "INTEGER" ] }
+ { BIG-INTEGER [ "INTEGER " ] }
+ { SIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { UNSIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { DOUBLE [ "DOUBLE" ] }
+ { REAL [ "DOUBLE" ] }
+ { BOOLEAN [ "BOOLEAN" ] }
+ { TEXT [ "TEXT" ] }
+ { VARCHAR [ "TEXT" ] }
+ { CHARACTER [ "TEXT" ] }
+ { DATE [ "DATE" ] }
+ { TIME [ "TIME" ] }
+ { DATETIME [ "TIMESTAMP" ] }
+ { TIMESTAMP [ "TIMESTAMP" ] }
+ { BLOB [ "BYTEA" ] }
+ { FACTOR-BLOB [ "BYTEA" ] }
+ { URL [ "TEXT" ] }
+ { +db-assigned-key+ [ "SERIAL" ] }
+ { +random-key+ [ "BIGINT" ] }
+ [ no-sql-type ]
+ } case ;
+
+/*
+: postgresql-column-typed ( handle row column type -- obj )
+ dup array? [ first ] when
+ {
+ { +db-assigned-key+ [ pq-get-number ] }
+ { +random-key+ [ pq-get-number ] }
+ { INTEGER [ pq-get-number ] }
+ { BIG-INTEGER [ pq-get-number ] }
+ { DOUBLE [ pq-get-number ] }
+ { TEXT [ pq-get-string ] }
+ { VARCHAR [ pq-get-string ] }
+ { CHARACTER [ pq-get-string ] }
+ { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
+ { TIME [ pq-get-string dup [ hms>duration ] 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 ;
+*/
+
+: postgresql-modifier>string ( symbol -- string )
+ {
+ { NULL [ "NULL" ] }
+ { NOT-NULL [ "NOT NULL" ] }
+ { SERIAL [ "SERIAL" ] }
+ { AUTOINCREMENT [ "AUTOINCREMENT" ] }
+ { +primary-key+ [ "" ] }
+ [ no-sql-modifier ]
+ } case ;
+
+M: postgresql-db-connection sql-modifiers>string
+ [ postgresql-modifier>string ] map " " join ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences vocabs.loader vocabs ;
+IN: postgresql.orm
+
+{
+ "postgresql.orm.queries"
+} [ require ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators combinators.smart db2
+db2.binders db2.statements db2.types db2.utils kernel make math
+math.intervals math.parser multiline namespaces orm.persistent
+orm.queries postgresql.db2.connections.private ranges sequences ;
+IN: postgresql.orm.queries
+
+! TODOOOOOO
+SYMBOL: postgresql-counter
+
+: next-bind ( -- string )
+ postgresql-counter [ inc ] [ get ] bi
+ number>string "$" prepend ;
+
+M: postgresql-db-connection n>bind-sequence ( n -- sequence )
+ [1..b] [ number>string "$" prepend ] map ;
+
+M:: postgresql-db-connection continue-bind-sequence ( previous n -- sequence )
+ previous 1 +
+ dup n +
+ [a..b] [ number>string "$" prepend ] map ;
+
+ERROR: db-assigned-keys-not-empty assoc ;
+: check-db-assigned-assoc ( assoc -- assoc )
+ dup [ first column-primary-key? ] filter
+ [ db-assigned-keys-not-empty ] unless-empty ;
+
+M: postgresql-db-connection insert-db-assigned-key-sql
+ [ <statement> ] dip
+ [ >persistent ] [ ] bi {
+ [ drop [ "select " "add_" ] dip table-name>> trim-double-quotes 3append quote-sql-name add-sql "(" add-sql ]
+ [
+
+ filter-tuple-values check-db-assigned-assoc
+ [ length n>bind-string add-sql ");" add-sql ]
+ [ [ [ second ] [ first type>> ] bi <in-binder-low> ] map >>in ] bi
+ { INTEGER } >>out
+ ]
+ } 2cleave ;
+
+M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
+ sql-query first first set-primary-key drop ;
+
+M: postgresql-db-connection insert-user-assigned-key-sql
+ [ <statement> ] dip
+ [ >persistent ] [ ] bi {
+ [ drop table-name>> quote-sql-name "INSERT INTO " "(" surround add-sql ]
+ [
+ filter-tuple-values
+ [
+ keys
+ [ [ column-name>> quote-sql-name ] map ", " join ]
+ [
+ length n>bind-string
+ ") values(" ");" surround
+ ] bi append add-sql
+ ]
+ [ [ [ second ] [ first type>> ] bi <in-binder-low> ] map >>in ] bi
+ ]
+ } 2cleave ;
+
+/*
+M: postgresql-db-connection insert-user-assigned-key-sql
+ [ <statement> ] dip >persistent {
+ [ table-name>> quote-sql-name "INSERT INTO " prepend add-sql "(" add-sql ]
+ [
+ [
+ columns>>
+ [
+ [
+ [ ", " % ] [ column-name>> quote-sql-name % ] interleave
+ ")" %
+ ] "" make add-sql
+ ] [
+ " values(" %
+ [ ", " % ] [
+ dup type>> +random-key+ = [
+ [
+ bind-name%
+ slot-name>>
+ f
+ random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
+ ");" 0%
+ ] bi
+ ]
+ } cleave ;
+*/
+
+
+: postgresql-create-table ( tuple-class -- string )
+ >persistent dup table-name>> quote-sql-name
+ [
+ [
+ [ columns>> ] dip
+ "CREATE TABLE " % %
+ "(" % [ ", " % ] [
+ [ column-name>> quote-sql-name % " " % ]
+ [ type>> sql-create-type>string % ]
+ [ drop ] tri
+ ! [ modifiers % ] bi
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " %
+ "PRIMARY KEY(" %
+ [ "," % ] [ column-name>> quote-sql-name % ] interleave
+ ")" %
+ ] unless-empty
+ ");" %
+ ] 2bi
+ ] "" make ;
+
+:: postgresql-create-function ( tuple-class -- string )
+ tuple-class >persistent :> persistent
+ persistent table-name>> :> table-name
+ table-name trim-double-quotes :> table-name-unquoted
+ persistent columns>> :> columns
+ columns remove-primary-key :> columns-minus-key
+
+ [
+ "CREATE FUNCTION " "add_" table-name-unquoted append quote-sql-name "("
+
+ columns-minus-key [ type>> sql-type>string ] map ", " join
+
+ ") returns bigint as 'insert into "
+
+ table-name quote-sql-name "(" columns-minus-key [ column-name>> quote-sql-name ] map ", " join
+ ") values("
+ 1 columns-minus-key length [a,b]
+ [ number>string "$" prepend ] map ", " join
+
+ "); select currval(''" table-name-unquoted "_"
+ persistent find-primary-key first column-name>>
+ "_seq'');' language sql;"
+ ] "" append-outputs-as ;
+
+M: postgresql-db-connection create-table-sql ( tuple-class -- seq )
+ [ postgresql-create-table ]
+ [ dup db-assigned-key? [ postgresql-create-function 2array ] [ drop ] if ] bi ;
+
+:: postgresql-drop-table ( tuple-class -- string )
+ tuple-class >persistent table-name>> :> table-name
+ [
+ "drop table " table-name quote-sql-name ";"
+ ] "" append-outputs-as ;
+
+:: postgresql-drop-function ( tuple-class -- string )
+ tuple-class >persistent :> persistent
+ persistent table-name>> :> table-name
+ table-name trim-double-quotes :> table-name-unquoted
+ persistent columns>> :> columns
+ columns remove-primary-key :> columns-minus-key
+ [
+ "drop function " "add_" table-name-unquoted append quote-sql-name
+ "("
+ columns-minus-key [ type>> sql-type>string ] map ", " join
+ ");"
+ ] "" append-outputs-as ;
+
+M: postgresql-db-connection drop-table-sql ( tuple-class -- seq )
+ [ postgresql-drop-table ]
+ [ dup db-assigned-key? [ postgresql-drop-function 2array ] [ drop ] if ] bi ;
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences vocabs vocabs.loader ;
+IN: postgresql
+
+{
+ "postgresql.db2"
+ "postgresql.orm"
+} [ require ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry grouping hashtables kernel make
+math multiline sequences splitting.monotonic ;
+IN: reconstructors
+
+
+TUPLE: reconstructor row-spec combiner-spec ;
+
+
+
+/*
+ERROR: no-setter ;
+
+: out-binder>setter ( toc -- word )
+ [ class>> >persistent columns>> ]
+ [ toc>> column-name>> ] bi '[ column-name>> _ = ] find
+ nip [ no-setter ] unless* setter>> ;
+
+MACRO: query-object>reconstructor ( tuple -- quot )
+ out>> [ [ class>> ] bi@ = ] monotonic-split
+ [ [ first class>> ] [ [ out-binder>setter ] map ] bi ] { } map>assoc
+ [
+ [
+ first2
+ [ , \ new , ]
+ [ reverse [ \ swap , , (( obj obj -- obj )) , \ call-effect , ] each ] bi*
+ ] each
+ ] [ ] make '[ [ _ input<sequence ] ] ;
+*/
+
+
+/*
+
+
+
+TUPLE: bag id beans ;
+TUPLE: bean id bag-id color ;
+
+{
+ { 0 0 0 "blue" } { 0 1 0 "red" } { 0 2 0 "yellow" }
+ { 1 3 1 "black" } { 1 4 1 "white" }
+ { 2 5 2 "black" } { 2 6 2 "white" }
+}
+{ { bag >>id } { bean >>id >>bag-id >>color } } rows>tuples
+
+[ [ second bag-id>> ] bi@ = ] monotonic-split
+[ [ first first ] [ [ second ] map ] bi >>beans ] map
+
+
+
+T{ reconstructor
+ { row-spec
+ { { bag >>id } { bean >>id >>color } }
+ }
+ { combiner-spec
+ { bag >>beans { bean bag-id>> } }
+ }
+}
+
+TUPLE: foo-1 a b ;
+
+{ { 1 "Asdf" } }
+{ { foo-1 >>a >>b } }
+
+T{ foo-1 { a 1 } { b "Asdf" } }
+
+
+{
+ { big-container >>id >>a }
+ { medium-container >>id >>big-container-id >>b }
+ { small-container >>id >>medium-container-id >>c }
+} rows>tuples
+
+
+{
+ { third medium-container-id>> <=> }
+ { second big-container-id>> <=> }
+} sort-by
+
+
+
+T{ reconstructor
+ { row-spec
+ {
+ { big-container >>id >>a }
+ { medium-container >>id >>big-container-id >>b }
+ { small-container >>id >>medium-container-id >>c }
+ }
+ }
+ { combiner-spec
+ {
+ T{ nested-reconstructor f
+ small-container medium-container-id>>
+ medium-container >>small-containers
+ }
+
+ T{ nested-reconstructor f
+ medium-container big-container-id>>
+ big-container >>medium-containers
+ }
+ }
+ }
+}
+
+
+TUPLE: big-container id a medium-containers ;
+
+TUPLE: medium-container id big-container-id b small-containers ;
+
+TUPLE: small-container id medium-container-id c ;
+
+
+TUPLE: nested-reconstructor
+ from-class from-accessor
+ to-class to-accessor ;
+
+
+{
+ { 0 "a" 0 0 "b" 0 0 "c" }
+ { 0 "a" 0 0 "b" 1 0 "c" }
+ { 0 "a" 1 0 "b" 2 1 "c" }
+ { 1 "a" 2 1 "b" 3 2 "c" }
+ { 1 "a" 2 1 "b" 4 2 "c" }
+ { 1 "a" 2 1 "b" 5 2 "c" }
+ { 1 "a" 3 1 "b" 6 3 "c" }
+ { 2 "a" 4 2 "b" 7 4 "c" }
+ { 2 "a" 4 2 "b" 8 4 "c" }
+ { 2 "a" 5 2 "b" 9 5 "c" }
+ { 2 "a" 5 2 "b" 10 5 "c" }
+ { 2 "a" 5 2 "b" 11 5 "c" }
+ { 2 "a" 6 2 "b" 12 6 "c" }
+}
+
+{
+ { big-container >>id >>a }
+ { medium-container >>id >>big-container-id >>b }
+ { small-container >>id >>medium-container-id >>c }
+} rows>tuples
+
+
+[ [ 2 swap nth medium-container-id>> ] bi@ = ] monotonic-split
+[
+ [ [ third ] map ] [ first second small-containers<< ] [ ] tri
+ first but-last
+] map
+
+[ [ 1 swap nth big-container-id>> ] bi@ = ] monotonic-split
+[
+ [ [ second ] map ] [ first first medium-containers<< ] [ ] tri
+ first but-last
+] map
+
+[ first ] map
+
+{
+ T{ nested-reconstructor f
+ small-container medium-container-id>>
+ medium-container >>small-containers
+ }
+
+ T{ nested-reconstructor f
+ medium-container big-container-id>>
+ big-container >>medium-containers
+ }
+}
+
+
+
+
+
+*/
+
+ERROR: not-found key ;
+
+: at- ( class hashtable -- n )
+ ?at [ not-found ] unless ;
+
+: nth-tuple, ( n hashtable -- )
+ at- , \ swap , \ nth , ;
+
+: splitter-quot ( combiner-spec lookup-table -- quot )
+ '[
+ _ [ _ nth-tuple, ] each
+ ] [ ] make
+ '[ [ _ bi@ = ] monotonic-split ] ;
+
+: reconstructor>tuple-lookup-table ( reconstructor -- hashtable )
+ row-spec>> [ [ first ] map ] [ length <iota> ] bi zip >hashtable ;
+
+: split-by-length ( seq lengths -- seq' )
+ 0 [ + ] accumulate swap suffix 2 <clumps>
+ [ first2 rot subseq ] with map ;
+
+: fill-new-tuple ( seq spec -- tuple )
+ unclip new [
+ '[ [ _ ] 2dip execute( a obj -- obj ) drop ] 2each
+ ] keep ;
+
+: row>tuples ( seq spec -- seq' )
+ [ [ length 1 - ] map split-by-length ] keep
+ [ fill-new-tuple ] 2map ;
+
+: rows>tuples ( seq spec -- seq' )
+ '[ _ row>tuples ] map ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sqlite.db2 db2.debug tools.test ;
+IN: sqlite.db2.connections.tests
+
+[ ] [
+ [ ] test-sqlite
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections sqlite.db2
+sqlite.db2.errors sqlite.db2.lib kernel db2.errors io.backend
+destructors ;
+IN: sqlite.db2.connections
+
+TUPLE: sqlite-db-connection < db-connection ;
+
+: <sqlite-db-connection> ( handle -- db-connection )
+ sqlite-db-connection new-db-connection ;
+
+M: sqlite-db db>db-connection-generic ( db -- db-connection )
+ path>> normalize-path sqlite-open <sqlite-db-connection> ;
+
+M: sqlite-db-connection dispose* ( db-connection -- )
+ [ handle>> sqlite-close ] [ f >>handle drop ] bi ;
+
+M: sqlite-db-connection parse-sql-error ( error -- error' )
+ dup n>> {
+ { 1 [ string>> parse-sqlite-sql-error ] }
+ [ drop ]
+ } case ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors db2.connections kernel sequences vocabs
+vocabs.loader ;
+IN: sqlite.db2
+
+TUPLE: sqlite-db path ;
+
+CONSTRUCTOR: <sqlite-db> sqlite-db ( path -- db ) ;
+
+{
+ "sqlite.db2.connections"
+ "sqlite.db2.errors"
+ "sqlite.db2.ffi"
+ "sqlite.db2.lib"
+ "sqlite.db2.result-sets"
+ "sqlite.db2.statements"
+ "sqlite.db2.types"
+ "sqlite.db2.queries"
+ ! "sqlite.db2.introspection"
+
+ "sqlite.orm"
+} [ require ] each
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.errors
+sqlite.db2.ffi kernel locals namespaces peg.ebnf sequences
+strings ;
+IN: sqlite.db2.errors
+
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
+
+: sqlite-statement-error ( -- * )
+ SQLITE_ERROR
+ db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
+
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
+
+EBNF: parse-sqlite-sql-error [=[
+
+TableMessage = " already exists"
+SyntaxError = ": syntax error"
+
+SqliteError =
+ "table " (!(TableMessage).)+:table TableMessage:message
+ => [[ table >string <sql-table-exists> ]]
+ | "near " (!(SyntaxError).)+:syntax SyntaxError:message
+ => [[ syntax >string <sql-syntax-error> ]]
+ | "no such table: " .+:table
+ => [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
+]=]
+
+: throw-sqlite-error ( n -- * )
+ dup sqlite-error-messages nth sqlite-error ;
--- /dev/null
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! Not all functions have been wrapped.
+USING: alien alien.c-types alien.libraries alien.syntax
+combinators system ;
+IN: sqlite.db2.ffi
+
+<< "sqlite" {
+ { [ os windows? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
+ } cond cdecl add-library >>
+
+LIBRARY: sqlite
+
+! Return values from sqlite functions
+CONSTANT: SQLITE_OK 0 ! Successful result
+CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
+CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
+CONSTANT: SQLITE_PERM 3 ! Access permission denied
+CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
+CONSTANT: SQLITE_BUSY 5 ! The database file is locked
+CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
+CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
+CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
+CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
+CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
+CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
+CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
+CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
+CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
+CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
+CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
+CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
+CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
+CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
+CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
+CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
+CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
+CONSTANT: SQLITE_AUTH 23 ! Authorization denied
+CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
+CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
+CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
+
+CONSTANT: sqlite-error-messages
+{
+ "Successful result"
+ "SQL error or missing database"
+ "An internal logic error in SQLite"
+ "Access permission denied"
+ "Callback routine requested an abort"
+ "The database file is locked"
+ "A table in the database is locked"
+ "A malloc() failed"
+ "Attempt to write a readonly database"
+ "Operation terminated by sqlite_interrupt()"
+ "Some kind of disk I/O error occurred"
+ "The database disk image is malformed"
+ "(Internal Only) Table or record not found"
+ "Insertion failed because database is full"
+ "Unable to open the database file"
+ "Database lock protocol error"
+ "(Internal Only) Database table is empty"
+ "The database schema changed"
+ "Too much data for one row of a table"
+ "Abort due to contraint violation"
+ "Data type mismatch"
+ "Library used incorrectly"
+ "Uses OS features not supported on host"
+ "Authorization denied"
+ "Auxiliary database format error"
+ "2nd parameter to sqlite3_bind out of range"
+ "File opened that is not a database file"
+}
+
+! Return values from sqlite3_step
+CONSTANT: SQLITE_ROW 100
+CONSTANT: SQLITE_DONE 101
+
+! Return values from the sqlite3_column_type function
+CONSTANT: SQLITE_INTEGER 1
+CONSTANT: SQLITE_FLOAT 2
+CONSTANT: SQLITE_TEXT 3
+CONSTANT: SQLITE_BLOB 4
+CONSTANT: SQLITE_NULL 5
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+CONSTANT: SQLITE_STATIC 0
+CONSTANT: SQLITE_TRANSIENT -1
+
+CONSTANT: SQLITE_OPEN_READONLY 0x00000001
+CONSTANT: SQLITE_OPEN_READWRITE 0x00000002
+CONSTANT: SQLITE_OPEN_CREATE 0x00000004
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE 0x00000008
+CONSTANT: SQLITE_OPEN_EXCLUSIVE 0x00000010
+CONSTANT: SQLITE_OPEN_MAIN_DB 0x00000100
+CONSTANT: SQLITE_OPEN_TEMP_DB 0x00000200
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB 0x00000400
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL 0x00000800
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL 0x00001000
+CONSTANT: SQLITE_OPEN_SUBJOURNAL 0x00002000
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL 0x00004000
+
+C-TYPE: sqlite3
+C-TYPE: sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( c-string filename, void* ppDb )
+FUNCTION: int sqlite3_close ( sqlite3* pDb )
+FUNCTION: c-string sqlite3_errmsg ( sqlite3* pDb )
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, c-string zSql, int nBytes, void* ppStmt, void* pzTail )
+FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, c-string zSql, int nBytes, void* ppStmt, void* pzTail )
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt )
+FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt )
+FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt )
+FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt )
+FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor )
+FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x )
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n )
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n )
+! Bind the same function as above, but for unsigned 64bit integers
+FUNCTION-ALIAS: sqlite3-bind-uint64
+ int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_uint64 in64 )
+FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n )
+FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, c-string text, int len, int destructor )
+FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, c-string name )
+FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt )
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt )
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col )
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col )
+FUNCTION: c-string sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col )
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col )
+FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col )
+! Bind the same function as above, but for unsigned 64bit integers
+FUNCTION-ALIAS: sqlite3-column-uint64
+ sqlite3_uint64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col )
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col )
+FUNCTION: c-string sqlite3_column_name ( sqlite3_stmt* pStmt, int col )
+FUNCTION: c-string sqlite3_column_text ( sqlite3_stmt* pStmt, int col )
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col )
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.introspection db2.types kernel orm.persistent
+orm.tuples sqlite.db2.connections accessors sequences ;
+IN: sqlite.db2.introspection
+
+TUPLE: sqlite-object type name tbl-name rootpage sql ;
+TUPLE: temporary-sqlite-object < sqlite-object ;
+
+PERSISTENT: { sqlite-object "sqlite_master" }
+ { "type" TEXT }
+ { "name" TEXT }
+ { "tbl-name" TEXT }
+ { "rootpage" INTEGER }
+ { "sql" TEXT } ;
+
+PERSISTENT: { temporary-sqlite-object "sqlite_temp_master" } ;
+
+M: sqlite-db-connection all-db-objects
+ sqlite-object new select-tuples ;
+
+M: sqlite-db-connection all-tables
+ all-db-objects [ type>> "table" = ] filter ;
+
+M: sqlite-db-connection all-indices
+ all-db-objects [ type>> "index" = ] filter ;
+
+M: sqlite-db-connection temporary-db-objects
+ temporary-sqlite-object new select-tuples ;
+
--- /dev/null
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays assocs
+byte-arrays calendar.format combinators continuations db2
+db2.connections db2.errors sqlite.db2.errors sqlite.db2.ffi
+db2.types io io.backend io.encodings.binary io.encodings.string
+io.encodings.utf8 io.streams.byte-array kernel math math.parser
+namespaces present sequences serialize shuffle urls ;
+IN: sqlite.db2.lib
+
+: sqlite-check-result ( n -- )
+ {
+ { SQLITE_OK [ ] }
+ { SQLITE_ERROR [ sqlite-statement-error ] }
+ [ throw-sqlite-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-boolean ( handle name obj -- )
+ >boolean 1 0 ? sqlite-bind-int ;
+
+: sqlite-bind-double ( handle i x -- )
+ sqlite3_bind_double sqlite-check-result ;
+
+: sqlite-bind-null ( handle i -- )
+ sqlite3_bind_null sqlite-check-result ;
+
+: sqlite-bind-blob ( handle i byte-array -- )
+ dup length SQLITE_TRANSIENT
+ sqlite3_bind_blob sqlite-check-result ;
+
+: sqlite-bind-text-by-name ( handle name text -- )
+ parameter-index sqlite-bind-text ;
+
+: sqlite-bind-int-by-name ( handle name int -- )
+ parameter-index sqlite-bind-int ;
+
+: sqlite-bind-int64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-int64 ;
+
+: sqlite-bind-uint64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-uint64 ;
+
+: sqlite-bind-boolean-by-name ( handle name obj -- )
+ >boolean 1 0 ? parameter-index sqlite-bind-int ;
+
+: sqlite-bind-double-by-name ( handle name double -- )
+ parameter-index sqlite-bind-double ;
+
+: sqlite-bind-blob-by-name ( handle name blob -- )
+ parameter-index sqlite-bind-blob ;
+
+: sqlite-bind-null-by-name ( handle name obj -- )
+ parameter-index drop sqlite-bind-null ;
+
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-clear-bindings ( handle -- )
+ sqlite3_clear_bindings sqlite-check-result ;
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
+
+: sqlite-column-blob ( handle index -- byte-array/f )
+ [ sqlite3_column_bytes ] 2keep
+ pick zero? [
+ 3drop f
+ ] [
+ sqlite3_column_blob swap memory>byte-array
+ ] if ;
+
+: sqlite-step-has-more-rows? ( prepared -- ? )
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
+
+: sqlite-next ( prepared -- ? )
+ sqlite3_step sqlite-step-has-more-rows? ;
+
+ERROR: sqlite-last-id-fail ;
+
+: last-insert-id ( -- id )
+ db-connection get handle>> sqlite3_last_insert_rowid
+ dup zero? [ sqlite-last-id-fail ] when ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays db2.connections db2.queries db2.statements
+db2.types kernel math namespaces sequences sqlite.db2.connections ;
+IN: sqlite.db2.queries
+
+TUPLE: sqlite-object < sql-object table-type internal-name table-name rootpage sql ;
+TUPLE: sqlite-column < sql-column cid name type notnull dflt_value pk ;
+
+M: sqlite-db-connection current-db-name
+ db-connection get db>> path>> ;
+
+: sqlite-table-info-statement ( string -- statement )
+ [ <statement> ] dip
+ sanitize-string
+ "pragma table_info('" "');" surround >>sql ;
+
+M: sqlite-db-connection sql-object-class sqlite-object ;
+M: sqlite-db-connection sql-column-class sqlite-column ;
+M: sqlite-db-connection databases-statement { } ;
+
+M: sqlite-db-connection database-table-columns-statement
+ nip
+ sqlite-table-info-statement
+ { INTEGER VARCHAR VARCHAR INTEGER VARCHAR INTEGER } >>out ;
+
+M: sqlite-db-connection database-tables-statement
+ drop
+ <statement>
+ "SELECT * FROM sqlite_master" >>sql ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.result-sets db2.statements destructors
+kernel sqlite.db2.connections sqlite.db2.lib sqlite.db2.types
+strings ;
+IN: sqlite.db2.result-sets
+
+TUPLE: sqlite-result-set < result-set has-more? ;
+
+M: sqlite-result-set dispose
+ f >>handle drop ;
+
+M: sqlite-db-connection statement>result-set
+ dup handle>>
+ sqlite-result-set new-result-set dup advance-row ;
+
+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-result-set #columns ( result-set -- n )
+ handle>> sqlite-#columns ;
+
+M: sqlite-result-set column ( result-set n type -- obj )
+ [ handle>> ] 2dip sqlite-type ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections sqlite.db2.connections
+sqlite.db2.ffi sqlite.db2.lib db2.statements destructors kernel
+namespaces ;
+IN: sqlite.db2.statements
+
+M: sqlite-db-connection prepare-statement* ( statement -- statement )
+ db-connection get handle>> over sql>> sqlite-prepare
+ >>handle ;
+
+M: sqlite-db-connection reset-statement
+ [ handle>> sqlite3_reset drop ] keep ;
+
+M: sqlite-db-connection dispose-statement
+ handle>>
+ [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ;
+
+M: sqlite-db-connection next-bind-index "?" ;
+
+M: sqlite-db-connection init-bind-index ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2 db2.statements db2.statements.tests db2.debug
+tools.test ;
+IN: sqlite.db2.tests
+
+: test-sql-bound-commands ( -- )
+ create-computer-table
+
+ [ ] [
+ <statement>
+ "insert into computer (name, os, version) values(?, ?, ?);" >>sql
+ { "clubber" "windows" "7" } >>in
+ sql-command
+ ] unit-test
+
+ [ { { "windows" } } ] [
+ <statement>
+ "select os from computer where name = ?;" >>sql
+ { "clubber" } >>in
+ sql-query
+ ] unit-test ;
+
+[ test-sql-bound-commands ] test-sqlite
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar.format calendar.parser
+combinators db2.binders db2.statements db2.types db2.utils
+kernel math present sequences serialize sqlite.db2.connections
+sqlite.db2.ffi sqlite.db2.lib strings unicode urls ;
+IN: sqlite.db2.types
+
+: (bind-next-sqlite-type) ( handle key value type -- )
+ {
+ { INTEGER [ sqlite-bind-int ] }
+ { BIG-INTEGER [ sqlite-bind-int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64 ] }
+ { BOOLEAN [ sqlite-bind-boolean ] }
+ { TEXT [ sqlite-bind-text ] }
+ { VARCHAR [ sqlite-bind-text ] }
+ { DOUBLE [ sqlite-bind-double ] }
+ { REAL [ sqlite-bind-double ] }
+ { DATE [ timestamp>ymd sqlite-bind-text ] }
+ { TIME [ timestamp>hms sqlite-bind-text ] }
+ { DATETIME [ timestamp>ymdhms sqlite-bind-text ] }
+ { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text ] }
+ { BLOB [ sqlite-bind-blob ] }
+ { FACTOR-BLOB [ object>bytes sqlite-bind-blob ] }
+ { URL [ present sqlite-bind-text ] }
+ { +db-assigned-key+ [ sqlite-bind-int ] }
+ { +random-key+ [ sqlite-bind-int64 ] }
+ { NULL [ drop sqlite-bind-null ] }
+ [ no-sql-type ]
+ } case ;
+
+: bind-next-sqlite-type ( handle key value type -- )
+ dup array? [ first ] when
+ over [
+ (bind-next-sqlite-type)
+ ] [
+ 2drop sqlite-bind-null
+ ] if ;
+
+: (bind-sqlite-type) ( handle key value type -- )
+ dup array? [ first ] when
+ {
+ { INTEGER [ sqlite-bind-int-by-name ] }
+ { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
+ { BOOLEAN [ sqlite-bind-boolean-by-name ] }
+ { TEXT [ sqlite-bind-text-by-name ] }
+ { VARCHAR [ sqlite-bind-text-by-name ] }
+ { DOUBLE [ sqlite-bind-double-by-name ] }
+ { REAL [ 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-key+ [ sqlite-bind-int-by-name ] }
+ { +random-key+ [ sqlite-bind-uint64-by-name ] }
+ { NULL [ sqlite-bind-null-by-name ] }
+ [ no-sql-type ]
+ } case ;
+
+: bind-sqlite-type ( handle key value type -- )
+ ! null and empty values need to be set by sqlite-bind-null-by-name
+ over [
+ NULL = [ 2drop NULL NULL ] when
+ ] [
+ drop NULL
+ ] if* (bind-sqlite-type) ;
+
+: sql-type-unsafe ( handle index type -- obj )
+ {
+ { +db-assigned-key+ [ sqlite3_column_int64 ] }
+ { +random-key+ [ 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 ] }
+ { REAL [ sqlite3_column_double ] }
+ { TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
+ { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] }
+ { TIME [ sqlite3_column_text [ hms>duration ] ?when ] }
+ { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { URL [ sqlite3_column_text [ >url ] ?when ] }
+ { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] }
+ [ no-sql-type ]
+ } case ;
+
+ERROR: sqlite-type-error handle index type n ;
+
+: sqlite-type ( handle index type -- obj )
+ dup array? [ first ] when
+ 2over sqlite-column-type {
+ { SQLITE_INTEGER [ sql-type-unsafe ] }
+ { SQLITE_FLOAT [ sql-type-unsafe ] }
+ { SQLITE_TEXT [ sql-type-unsafe ] }
+ { SQLITE_BLOB [ sql-type-unsafe ] }
+ { SQLITE_NULL [ 3drop f ] }
+ [ sqlite-type-error ]
+ } case ;
+
+GENERIC: sqlite-bind ( handle index obj -- )
+
+M: string sqlite-bind sqlite-bind-text ;
+M: in-binder-low sqlite-bind
+ [ value>> ] [ type>> ] bi bind-next-sqlite-type ;
+
+M: sqlite-db-connection bind-sequence ( statement -- )
+ [ in>> ] [ handle>> ] bi '[
+ [ _ ] 2dip 1 + swap sqlite-bind
+ ] each-index ;
+
+ERROR: no-fql-type type ;
+
+M: sqlite-db-connection db-type>fql-type ( string -- type )
+ >lower {
+ { "varchar" [ VARCHAR ] }
+ { "integer" [ INTEGER ] }
+ { "text" [ TEXT ] }
+ [ no-fql-type ]
+ } case ;
+
+M: sqlite-db-connection sql-type>string
+ dup array? [ first ] when
+ {
+ { INTEGER [ "INTEGER" ] }
+ { BIG-INTEGER [ "INTEGER " ] }
+ { SIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { UNSIGNED-BIG-INTEGER [ "BIGINT" ] }
+ { DOUBLE [ "DOUBLE" ] }
+ { REAL [ "DOUBLE" ] }
+ { BOOLEAN [ "BOOLEAN" ] }
+ { TEXT [ "TEXT" ] }
+ { VARCHAR [ "TEXT" ] }
+ { DATE [ "DATE" ] }
+ { TIME [ "TIME" ] }
+ { DATETIME [ "DATETIME" ] }
+ { TIMESTAMP [ "TIMESTAMP" ] }
+ { BLOB [ "BLOB" ] }
+ { FACTOR-BLOB [ "BLOB" ] }
+ { URL [ "TEXT" ] }
+ { +db-assigned-key+ [ "INTEGER" ] }
+ { +random-key+ [ "INTEGER unique" ] }
+ [ no-sql-type ]
+ } case ;
+
+M: sqlite-db-connection sql-create-type>string sql-type>string ;
+
+: sqlite-modifier>string ( symbol -- string )
+ {
+ { NULL [ "NULL" ] }
+ { NOT-NULL [ "NOT NULL" ] }
+ { +not-null+ [ "NOT NULL" ] }
+ { SERIAL [ "SERIAL" ] }
+ { AUTOINCREMENT [ "AUTOINCREMENT" ] }
+ { +primary-key+ [ "" ] }
+ { +user-assigned-key+ [ "" ] }
+ { +db-assigned-key+ [ "" ] }
+ { +system-random-generator+ [ "" ] }
+ [ no-sql-modifier ]
+ } case ;
+
+M: sqlite-db-connection sql-modifiers>string
+ [ sqlite-modifier>string ] map " " join ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences vocabs vocabs.loader ;
+IN: sqlite.orm
+
+[
+ "sqlite.orm.queries"
+ "sqlite.orm.types"
+] [ require ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators db2 db2.binders
+db2.query-objects db2.statements db2.types db2.utils fry kernel
+make namespaces orm.persistent orm.queries multiline
+sequences sqlite.db2.connections sqlite.db2.lib orm.binders ;
+IN: sqlite.orm.queries
+
+/*
+M: sqlite-db-connection reset-bind-index
+ 0 \ bind-index set ;
+
+M: sqlite-db-connection next-bind-index
+ \ bind-index [ get ] [ inc ] bi number>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
+ ] with-string-writer ;
+
+: 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
+ ] with-string-writer ;
+
+: 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
+ ] with-string-writer ;
+
+: 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
+ ] with-string-writer ;
+
+: 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
+ ] with-string-writer ;
+*/
+
+! : 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, ;
+
+: sqlite-create-table ( tuple-class -- string )
+ >persistent dup table-name>>
+ [
+ [
+ [ columns>> ] dip
+ "CREATE TABLE " % %
+ "(" % [ ", " % ] [
+ [ column-name>> % " " % ]
+ [ type>> sql-create-type>string % ]
+ [
+ modifiers>> sql-modifiers>string
+ [ " " % % ] unless-empty
+ ] tri
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " %
+ "PRIMARY KEY(" %
+ [ "," % ] [ column-name>> % ] interleave
+ ")" %
+ ] unless-empty
+ ");" %
+ ] 2bi
+ ] "" make ;
+
+
+/*
+: 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 ;
+*/
+
+M: sqlite-db-connection create-table-sql ( tuple-class -- seq )
+ ! [ sqlite-create-table ] [ drop create-db-triggers ] 2bi 2array ;
+ sqlite-create-table ;
+
+M: sqlite-db-connection ensure-table-sql ( tuple-class -- seq )
+ sqlite-create-table ;
+
+M: sqlite-db-connection insert-user-assigned-key-sql ( tuple -- object )
+ [ <statement> ] dip
+ [ >persistent ] [ ] bi {
+ [ drop table-name>> "INSERT INTO " "(" surround add-sql ]
+ [
+ filter-tuple-values
+ [
+ keys
+ [ [ column-name>> ] map ", " join ]
+ [
+ length "?" <array> ", " join
+ ") values(" ");" surround
+ ] bi append add-sql
+ ]
+ [ [ [ second ] [ first type>> ] bi <in-binder-low> ] map >>in ] bi
+ ]
+ } 2cleave ;
+
+M: sqlite-db-connection insert-db-assigned-key-sql
+ insert-user-assigned-key-sql ;
+
+M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
+ sql-command last-insert-id set-primary-key drop ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.result-sets kernel orm.binders
+sqlite.db2.types ;
+IN: sqlite.orm.types
+
+M: column-binder-in sqlite-bind
+ [ value>> ] [ column>> type>> ] bi bind-next-sqlite-type ;
+
+M: column-binder-out get-type
+ column>> type>> ;
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences vocabs vocabs.loader ;
+IN: sqlite
+
+[
+ "sqlite.db2"
+ "sqlite.orm"
+] [ require ] each
projects / factor.git / commitdiff