db: remove old library.
Doug Coleman
parent
01d384ac76
commit
45a060d362
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,314 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes kernel help.markup help.syntax sequences
|
||||
alien assocs strings math quotations db.private ;
|
||||
IN: db
|
||||
|
||||
HELP: db-connection
|
||||
{ $description "The " { $snippet "db-connection" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries. Stores the current database object as a dynamic variable." } ;
|
||||
|
||||
HELP: new-db-connection
|
||||
{ $values { "class" class } { "obj" db-connection } }
|
||||
{ $description "Creates a new database object from a given class with caches for prepared statements. Does not actually connect to the database until " { $link db-open } " or " { $link with-db } " is called." }
|
||||
{ $notes "User-defined databases must call this constructor word instead of " { $link new } "." } ;
|
||||
|
||||
HELP: db-open
|
||||
{ $values { "db" "a database configuration object" } { "db-connection" db-connection } }
|
||||
{ $description "Opens a database using the configuration data stored in a " { $snippet "database configuration object" } "tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
|
||||
|
||||
HELP: db-close
|
||||
{ $values { "handle" alien } }
|
||||
{ $description "Closes a database using the handle provided. Use of the " { $link with-db } " combinator is preferred over manually opening and closing databases so that resources are not leaked." } ;
|
||||
|
||||
{ db-open db-close with-db } related-words
|
||||
|
||||
HELP: dispose-statements
|
||||
{ $values { "assoc" assoc } }
|
||||
{ $description "Disposes an associative list of statements." } ;
|
||||
|
||||
HELP: statement
|
||||
{ $description "A " { $snippet "statement" } " stores the information about a statement, such as the SQL statement text, the in/out parameters, and type information." } ;
|
||||
|
||||
HELP: result-set
|
||||
{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
|
||||
{ $subsections
|
||||
"db-random-access-result-set"
|
||||
"db-sequential-result-set"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: new-result-set
|
||||
{ $values
|
||||
{ "query" "a query" } { "handle" alien } { "class" class }
|
||||
{ "result-set" result-set } }
|
||||
{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
|
||||
|
||||
HELP: new-statement
|
||||
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
|
||||
{ $description "Makes a new statement object from the given parameters." } ;
|
||||
|
||||
HELP: bind-statement
|
||||
{ $values
|
||||
{ "obj" object } { "statement" statement } }
|
||||
{ $description "Sets the statement's " { $slot "bind-params" } " and calls " { $link bind-statement* } " to do the database-specific bind. Sets " { $slot "bound?" } " to true if binding succeeds." } ;
|
||||
|
||||
HELP: bind-statement*
|
||||
{ $values
|
||||
{ "statement" statement } }
|
||||
{ $description "Does a low-level bind of the SQL statement's tuple parameters if the database requires. Some databases should treat this as a no-op and bind instead when the actual statement is run." } ;
|
||||
|
||||
HELP: <simple-statement>
|
||||
{ $values { "string" string } { "in" sequence } { "out" sequence }
|
||||
{ "statement" statement } }
|
||||
{ $description "Makes a new simple statement object from the given parameters.." }
|
||||
{ $warning "Using a simple statement can lead to SQL injection attacks in PostgreSQL. The Factor database implementation for SQLite only uses " { $link <prepared-statement> } " as the sole kind of statement; simple statements alias to prepared ones." } ;
|
||||
|
||||
HELP: <prepared-statement>
|
||||
{ $values { "string" string } { "in" sequence } { "out" sequence }
|
||||
{ "statement" statement } }
|
||||
{ $description "Makes a new prepared statement object from the given parameters. A prepared statement's parameters will be escaped by the database backend to avoid SQL injection attacks. Prepared statements should be preferred over simple statements." } ;
|
||||
|
||||
HELP: prepare-statement
|
||||
{ $values { "statement" statement } }
|
||||
{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ;
|
||||
|
||||
HELP: low-level-bind
|
||||
{ $values
|
||||
{ "statement" statement } }
|
||||
{ $description "For use with prepared statements, methods on this word should bind the datatype in the SQL spec to its identifier in the SQL string. To name bound variables, SQLite uses identifiers in the form of " { $snippet ":name" } ", while PostgreSQL uses increasing numbers beginning with a dollar sign, e.g. " { $snippet "$1" } "." } ;
|
||||
|
||||
HELP: query-results
|
||||
{ $values { "query" object }
|
||||
{ "result-set" result-set }
|
||||
}
|
||||
{ $description "Returns a " { $link result-set } " object representing the results of a SQL query. See " { $link "db-result-sets" } "." } ;
|
||||
|
||||
HELP: #rows
|
||||
{ $values { "result-set" result-set } { "n" integer } }
|
||||
{ $description "Returns the number of rows in a result set." } ;
|
||||
|
||||
HELP: #columns
|
||||
{ $values { "result-set" result-set } { "n" integer } }
|
||||
{ $description "Returns the number of columns in a result set." } ;
|
||||
|
||||
HELP: row-column
|
||||
{ $values { "result-set" result-set } { "column" integer }
|
||||
{ "obj" object }
|
||||
}
|
||||
{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
|
||||
|
||||
HELP: row-column-typed
|
||||
{ $values { "result-set" result-set } { "column" integer }
|
||||
{ "sql" "sql" } }
|
||||
{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ;
|
||||
|
||||
HELP: advance-row
|
||||
{ $values { "result-set" result-set } }
|
||||
{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ;
|
||||
|
||||
HELP: more-rows?
|
||||
{ $values { "result-set" result-set } { "?" boolean } }
|
||||
{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
|
||||
|
||||
|
||||
|
||||
HELP: begin-transaction
|
||||
{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
|
||||
|
||||
HELP: commit-transaction
|
||||
{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
|
||||
|
||||
HELP: in-transaction
|
||||
{ $description "A variable that is set true when a transaction is in progress." } ;
|
||||
|
||||
HELP: in-transaction?
|
||||
{ $values
|
||||
{ "?" boolean } }
|
||||
{ $description "Returns true if there is currently a transaction in progress in this scope." } ;
|
||||
|
||||
HELP: query-each
|
||||
{ $values
|
||||
{ "statement" statement } { "quot" quotation } }
|
||||
{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
|
||||
|
||||
HELP: query-map
|
||||
{ $values
|
||||
{ "statement" statement } { "quot" quotation }
|
||||
{ "seq" sequence } }
|
||||
{ $description "A combinator that maps a sequence of SQL statements to their results query results." } ;
|
||||
|
||||
HELP: rollback-transaction
|
||||
{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
|
||||
|
||||
HELP: sql-command
|
||||
{ $values
|
||||
{ "sql" string } }
|
||||
{ $description "Executes a SQL string using the database in the " { $link db-connection } " symbol." } ;
|
||||
|
||||
HELP: sql-query
|
||||
{ $values
|
||||
{ "sql" string }
|
||||
{ "rows" "an array of arrays of strings" } }
|
||||
{ $description "Runs a SQL query of raw text in the database in the " { $link db-connection } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
|
||||
|
||||
{ sql-command sql-query } related-words
|
||||
|
||||
HELP: sql-row
|
||||
{ $values
|
||||
{ "result-set" result-set }
|
||||
{ "seq" sequence } }
|
||||
{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ;
|
||||
|
||||
HELP: sql-row-typed
|
||||
{ $values
|
||||
{ "result-set" result-set }
|
||||
{ "seq" sequence } }
|
||||
{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ;
|
||||
|
||||
{ sql-row sql-row-typed } related-words
|
||||
|
||||
HELP: with-db
|
||||
{ $values
|
||||
{ "db" "a database configuration object" } { "quot" quotation } }
|
||||
{ $description "Calls the quotation with a database bound to the " { $link db-connection } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
|
||||
|
||||
HELP: with-transaction
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
|
||||
|
||||
ARTICLE: "db" "Database library"
|
||||
"Accessing a database:"
|
||||
{ $subsections "db-custom-database-combinators" }
|
||||
"Higher-level database help:"
|
||||
{ $vocab-subsection "Database types" "db.types" }
|
||||
{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
|
||||
"Low-level database help:"
|
||||
{ $subsections
|
||||
"db-protocol"
|
||||
"db-result-sets"
|
||||
"db-lowlevel-tutorial"
|
||||
}
|
||||
"Supported database backends:"
|
||||
{ $vocab-subsection "SQLite" "db.sqlite" }
|
||||
{ $vocab-subsection "PostgreSQL" "db.postgresql" } ;
|
||||
|
||||
ARTICLE: "db-random-access-result-set" "Random access result sets"
|
||||
"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
|
||||
$nl
|
||||
"Databases which work in this way must provide methods for the following traversal words:"
|
||||
{ $subsections
|
||||
#rows
|
||||
#columns
|
||||
row-column
|
||||
row-column-typed
|
||||
} ;
|
||||
|
||||
ARTICLE: "db-sequential-result-set" "Sequential result sets"
|
||||
"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
|
||||
$nl
|
||||
"Databases which work in this way must provide methods for the following traversal words:"
|
||||
{ $subsections
|
||||
more-rows?
|
||||
advance-row
|
||||
row-column
|
||||
row-column-typed
|
||||
} ;
|
||||
|
||||
ARTICLE: "db-result-sets" "Result sets"
|
||||
"Result sets are the encapsulated, database-specific results from a SQL query."
|
||||
$nl
|
||||
"Two possible protocols for iterating over result sets exist:"
|
||||
{ $subsections
|
||||
"db-random-access-result-set"
|
||||
"db-sequential-result-set"
|
||||
}
|
||||
"Query the number of rows or columns:"
|
||||
{ $subsections
|
||||
#rows
|
||||
#columns
|
||||
}
|
||||
"Traversing a result set:"
|
||||
{ $subsections
|
||||
advance-row
|
||||
more-rows?
|
||||
}
|
||||
"Pulling out a single row of results:"
|
||||
{ $subsections
|
||||
row-column
|
||||
row-column-typed
|
||||
} ;
|
||||
|
||||
ARTICLE: "db-protocol" "Low-level database protocol"
|
||||
"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." $nl
|
||||
"Opening a database:"
|
||||
{ $subsections db-open }
|
||||
"Closing a database:"
|
||||
{ $subsections db-close }
|
||||
"Creating statements:"
|
||||
{ $subsections
|
||||
<simple-statement>
|
||||
<prepared-statement>
|
||||
}
|
||||
"Using statements with the database:"
|
||||
{ $subsections
|
||||
prepare-statement
|
||||
bind-statement*
|
||||
low-level-bind
|
||||
}
|
||||
"Performing a query:"
|
||||
{ $subsections query-results }
|
||||
"Handling query results:"
|
||||
{ $subsections "db-result-sets" }
|
||||
;
|
||||
! { $subsection bind-tuple }
|
||||
|
||||
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
|
||||
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
|
||||
"Executing a SQL command:"
|
||||
{ $subsections sql-command }
|
||||
"Executing a query directly:"
|
||||
{ $subsections sql-query }
|
||||
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
|
||||
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
|
||||
{ $code "USING: db.sqlite db io.files io.files.temp ;
|
||||
: with-book-db ( quot -- )
|
||||
\"book.db\" temp-file <sqlite-db> swap with-db ; inline" }
|
||||
"Now let's create the table manually:"
|
||||
{ $code "\"create table books
|
||||
(id integer primary key, title text, author text, date_published timestamp,
|
||||
edition integer, cover_price double, condition text)\"
|
||||
[ sql-command ] with-book-db" }
|
||||
"Time to insert some books:"
|
||||
{ $code "\"insert into books
|
||||
(title, author, date_published, edition, cover_price, condition)
|
||||
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')\"
|
||||
[ sql-command ] with-book-db" }
|
||||
"Now let's select the book:"
|
||||
{ $code "\"select id, title, cover_price from books;\" [ sql-query ] with-book-db" }
|
||||
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
|
||||
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
|
||||
|
||||
ARTICLE: "db-custom-database-combinators" "Custom database combinators"
|
||||
"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specific port." $nl
|
||||
|
||||
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
|
||||
|
||||
"SQLite example combinator:"
|
||||
{ $code "USING: db.sqlite db io.files io.files.temp ;
|
||||
: with-sqlite-db ( quot -- )
|
||||
\"my-database.db\" temp-file <sqlite-db> swap with-db ; inline" }
|
||||
|
||||
"PostgreSQL example combinator:"
|
||||
{ $code "USING: db.postgresql db ;
|
||||
: with-postgresql-db ( quot -- )
|
||||
<postgresql-db>
|
||||
\"localhost\" >>host
|
||||
5432 >>port
|
||||
\"erg\" >>username
|
||||
\"secrets?\" >>password
|
||||
\"factor-test\" >>database
|
||||
swap with-db ; inline"
|
||||
} ;
|
||||
|
||||
ABOUT: "db"
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
USING: tools.test db kernel ;
|
||||
IN: db.tests
|
||||
|
||||
{ 1 0 } [ [ drop ] query-each ] must-infer-as
|
||||
{ 1 1 } [ [ ] query-map ] must-infer-as
|
||||
{ 1 0 } [ [ ] with-db ] must-infer-as
|
||||
|
|
@ -1,156 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations destructors kernel math
|
||||
namespaces sequences classes.tuple words strings
|
||||
tools.walker accessors combinators fry db.errors ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db-connection
|
||||
handle
|
||||
insert-statements
|
||||
update-statements
|
||||
delete-statements ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: new-db-connection ( class -- obj )
|
||||
new
|
||||
H{ } clone >>insert-statements
|
||||
H{ } clone >>update-statements
|
||||
H{ } clone >>delete-statements ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: db-open ( db -- db-connection )
|
||||
HOOK: db-close db-connection ( handle -- )
|
||||
HOOK: parse-db-error db-connection ( error -- error' )
|
||||
|
||||
: dispose-statements ( assoc -- ) values dispose-each ;
|
||||
|
||||
M: db-connection dispose ( db-connection -- )
|
||||
dup db-connection [
|
||||
[ dispose-statements H{ } clone ] change-insert-statements
|
||||
[ dispose-statements H{ } clone ] change-update-statements
|
||||
[ dispose-statements H{ } clone ] change-delete-statements
|
||||
[ db-close f ] change-handle
|
||||
drop
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: result-set sql in-params out-params handle n max ;
|
||||
|
||||
GENERIC: query-results ( query -- result-set )
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set column -- obj )
|
||||
GENERIC# row-column-typed 1 ( result-set column -- sql )
|
||||
GENERIC: advance-row ( result-set -- )
|
||||
GENERIC: more-rows? ( result-set -- ? )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows >>max
|
||||
0 >>n drop ;
|
||||
|
||||
: new-result-set ( query handle class -- result-set )
|
||||
new
|
||||
swap >>handle
|
||||
[ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
|
||||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql ;
|
||||
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
|
||||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
||||
: new-statement ( sql in out class -- statement )
|
||||
new
|
||||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql ;
|
||||
|
||||
HOOK: <simple-statement> db-connection ( string in out -- statement )
|
||||
HOOK: <prepared-statement> db-connection ( string in out -- statement )
|
||||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( statement -- )
|
||||
GENERIC: low-level-bind ( statement -- )
|
||||
GENERIC: bind-tuple ( tuple statement -- )
|
||||
|
||||
GENERIC: execute-statement* ( statement type -- )
|
||||
|
||||
M: object execute-statement* ( statement type -- )
|
||||
'[
|
||||
_ _ drop query-results dispose
|
||||
] [
|
||||
parse-db-error rethrow
|
||||
] recover ;
|
||||
|
||||
: execute-one-statement ( statement -- )
|
||||
dup type>> execute-statement* ;
|
||||
|
||||
: execute-statement ( statement -- )
|
||||
dup sequence? [
|
||||
[ execute-one-statement ] each
|
||||
] [
|
||||
execute-one-statement
|
||||
] if ;
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
swap >>bind-params
|
||||
[ bind-statement* ] keep
|
||||
t >>bound? drop ;
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with { } map-integers ;
|
||||
|
||||
: sql-row-typed ( result-set -- seq )
|
||||
dup #columns [ row-column-typed ] with { } map-integers ;
|
||||
|
||||
: query-each ( statement quot: ( statement -- ) -- )
|
||||
over more-rows? [
|
||||
[ call ] 2keep over advance-row query-each
|
||||
] [
|
||||
2drop
|
||||
] if ; inline recursive
|
||||
|
||||
: query-map ( statement quot -- seq )
|
||||
collector [ query-each ] dip { } like ; inline
|
||||
|
||||
: with-db ( db quot -- )
|
||||
[ db-open db-connection ] dip
|
||||
'[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
|
||||
|
||||
! Words for working with raw SQL statements
|
||||
: default-query ( query -- result-set )
|
||||
query-results [ [ sql-row ] query-map ] with-disposal ;
|
||||
|
||||
: sql-query ( sql -- rows )
|
||||
f f <simple-statement> [ default-query ] with-disposal ;
|
||||
|
||||
: (sql-command) ( string -- )
|
||||
f f <simple-statement> [ execute-statement ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
|
||||
|
||||
! Transactions
|
||||
SYMBOL: in-transaction
|
||||
|
||||
HOOK: begin-transaction db-connection ( -- )
|
||||
HOOK: commit-transaction db-connection ( -- )
|
||||
HOOK: rollback-transaction db-connection ( -- )
|
||||
|
||||
M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||
M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
|
||||
M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
|
||||
|
||||
: in-transaction? ( -- ? ) in-transaction get ;
|
||||
|
||||
: with-transaction ( quot -- )
|
||||
in-transaction? [
|
||||
call
|
||||
] [
|
||||
t in-transaction [
|
||||
begin-transaction
|
||||
[ ] [ rollback-transaction ] cleanup commit-transaction
|
||||
] with-variable
|
||||
] if ; inline
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel continuations fry words ;
|
||||
IN: db.errors
|
||||
|
||||
ERROR: db-error ;
|
||||
TUPLE: sql-error location ;
|
||||
|
||||
ERROR: bad-schema ;
|
||||
|
||||
TUPLE: sql-unknown-error < sql-error message ;
|
||||
: <sql-unknown-error> ( message -- error )
|
||||
\ sql-unknown-error new
|
||||
swap >>message ;
|
||||
|
||||
TUPLE: sql-table-exists < sql-error table ;
|
||||
: <sql-table-exists> ( table -- error )
|
||||
\ sql-table-exists new
|
||||
swap >>table ;
|
||||
|
||||
TUPLE: sql-table-missing < sql-error table ;
|
||||
: <sql-table-missing> ( table -- error )
|
||||
\ sql-table-missing new
|
||||
swap >>table ;
|
||||
|
||||
TUPLE: sql-syntax-error < sql-error message ;
|
||||
: <sql-syntax-error> ( message -- error )
|
||||
\ sql-syntax-error new
|
||||
swap >>message ;
|
||||
|
||||
TUPLE: sql-function-exists < sql-error message ;
|
||||
: <sql-function-exists> ( message -- error )
|
||||
\ sql-function-exists new
|
||||
swap >>message ;
|
||||
|
||||
TUPLE: sql-function-missing < sql-error message ;
|
||||
: <sql-function-missing> ( message -- error )
|
||||
\ sql-function-missing new
|
||||
swap >>message ;
|
||||
|
||||
TUPLE: sql-database-exists < sql-error message ;
|
||||
: <sql-database-exists> ( message -- error )
|
||||
\ sql-database-exists new
|
||||
swap >>message ;
|
||||
|
||||
: ignore-error ( quot word -- )
|
||||
'[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
|
||||
|
||||
: ignore-table-exists ( quot -- )
|
||||
\ sql-table-exists? ignore-error ; inline
|
||||
|
||||
: ignore-table-missing ( quot -- )
|
||||
\ sql-table-missing? ignore-error ; inline
|
||||
|
||||
: ignore-function-exists ( quot -- )
|
||||
\ sql-function-exists? ignore-error ; inline
|
||||
|
||||
: ignore-function-missing ( quot -- )
|
||||
\ sql-function-missing? ignore-error ; inline
|
||||
|
||||
: ignore-database-exists ( quot -- )
|
||||
\ sql-database-exists? ignore-error ; inline
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.postgresql db.postgresql io.files.unique kernel namespaces
|
||||
tools.test db.tester continuations ;
|
||||
IN: db.errors.postgresql.tests
|
||||
|
||||
[
|
||||
|
||||
[ "drop table foo;" sql-command ] ignore-errors
|
||||
[ "drop table ship;" sql-command ] ignore-errors
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table ship(id integer);" sql-command
|
||||
"create table ship(id integer);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id) lol;" sql-command
|
||||
] [
|
||||
sql-syntax-error?
|
||||
] must-fail-with
|
||||
|
||||
] test-postgresql
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel db.errors peg.ebnf strings sequences math
|
||||
combinators.short-circuit accessors math.parser quoting
|
||||
locals ;
|
||||
IN: db.errors.postgresql
|
||||
|
||||
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> ]]
|
||||
|
||||
DatabaseError =
|
||||
Error ("database")(!(" already exists").)+:database " already exists"
|
||||
=> [[ database >string <sql-database-exists> ]]
|
||||
|
||||
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 | DatabaseError | FunctionError | SyntaxError | UnknownError)
|
||||
|
||||
;EBNF
|
||||
|
||||
|
||||
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> ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
:: 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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.sqlite db.sqlite io.files.unique kernel namespaces
|
||||
tools.test ;
|
||||
IN: db.errors.sqlite.tests
|
||||
|
||||
: sqlite-error-test-db-path ( -- path )
|
||||
"sqlite" "error-test" make-unique-file ;
|
||||
|
||||
sqlite-error-test-db-path <sqlite-db> [
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id);" sql-command
|
||||
"create table foo(id);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
] with-db
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators db kernel sequences peg.ebnf
|
||||
strings db.errors ;
|
||||
IN: db.errors.sqlite
|
||||
|
||||
TUPLE: unparsed-sqlite-error error ;
|
||||
C: <unparsed-sqlite-error> unparsed-sqlite-error
|
||||
|
||||
SINGLETONS: table-exists table-missing ;
|
||||
|
||||
: sqlite-table-error ( table message -- error )
|
||||
{
|
||||
{ table-exists [ <sql-table-exists> ] }
|
||||
} case ;
|
||||
|
||||
EBNF: parse-sqlite-sql-error
|
||||
|
||||
TableMessage = " already exists" => [[ table-exists ]]
|
||||
|
||||
SqliteError =
|
||||
"table " (!(TableMessage).)+:table TableMessage:message
|
||||
=> [[ table >string message sqlite-table-error ]]
|
||||
| "no such table: " .+:table
|
||||
=> [[ table >string <sql-table-missing> ]]
|
||||
| .*:error
|
||||
=> [[ error >string <unparsed-sqlite-error> ]]
|
||||
;EBNF
|
||||
|
|
@ -1 +0,0 @@
|
|||
Errors thrown by database library
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
IN: db.pools.tests
|
||||
USING: db.pools tools.test continuations io.files io.files.temp
|
||||
io.directories namespaces accessors kernel math destructors ;
|
||||
|
||||
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
||||
|
||||
! Test behavior after image save/load
|
||||
USE: db.sqlite
|
||||
|
||||
[ "pool-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
{ } [ "pool-test.db" temp-file <sqlite-db> <db-pool> "pool" set ] unit-test
|
||||
|
||||
{ } [ "pool" get expired>> t >>expired drop ] unit-test
|
||||
|
||||
{ } [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
|
||||
|
||||
{ } [ "pool" get dispose ] unit-test
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
io.pools db fry db.private ;
|
||||
IN: db.pools
|
||||
|
||||
TUPLE: db-pool < pool db ;
|
||||
|
||||
: <db-pool> ( db -- pool )
|
||||
db-pool <pool>
|
||||
swap >>db ;
|
||||
|
||||
: with-db-pool ( db quot -- )
|
||||
[ <db-pool> ] dip with-pool ; inline
|
||||
|
||||
M: db-pool make-connection ( pool -- conn )
|
||||
db>> db-open ;
|
||||
|
||||
: with-pooled-db ( pool quot -- )
|
||||
'[ db-connection _ with-variable ] with-pooled-connection ; inline
|
||||
|
|
@ -1 +0,0 @@
|
|||
Database connection pooling
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,368 +0,0 @@
|
|||
! 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.libraries alien.syntax
|
||||
combinators system ;
|
||||
IN: db.postgresql.ffi
|
||||
|
||||
<< "postgresql" {
|
||||
{ [ os windows? ] [ "libpq.dll" ] }
|
||||
{ [ os macosx? ] [ "libpq.dylib" ] }
|
||||
{ [ os unix? ] [ "libpq.so" ] }
|
||||
} cond cdecl add-library >>
|
||||
|
||||
! ConnSatusType
|
||||
CONSTANT: CONNECTION_OK 0x0
|
||||
CONSTANT: CONNECTION_BAD 0x1
|
||||
CONSTANT: CONNECTION_STARTED 0x2
|
||||
CONSTANT: CONNECTION_MADE 0x3
|
||||
CONSTANT: CONNECTION_AWAITING_RESPONSE 0x4
|
||||
CONSTANT: CONNECTION_AUTH_OK 0x5
|
||||
CONSTANT: CONNECTION_SETENV 0x6
|
||||
CONSTANT: CONNECTION_SSL_STARTUP 0x7
|
||||
CONSTANT: CONNECTION_NEEDED 0x8
|
||||
|
||||
! PostgresPollingStatusType
|
||||
CONSTANT: PGRES_POLLING_FAILED 0x0
|
||||
CONSTANT: PGRES_POLLING_READING 0x1
|
||||
CONSTANT: PGRES_POLLING_WRITING 0x2
|
||||
CONSTANT: PGRES_POLLING_OK 0x3
|
||||
CONSTANT: PGRES_POLLING_ACTIVE 0x4
|
||||
|
||||
! ExecStatusType;
|
||||
CONSTANT: PGRES_EMPTY_QUERY 0x0
|
||||
CONSTANT: PGRES_COMMAND_OK 0x1
|
||||
CONSTANT: PGRES_TUPLES_OK 0x2
|
||||
CONSTANT: PGRES_COPY_OUT 0x3
|
||||
CONSTANT: PGRES_COPY_IN 0x4
|
||||
CONSTANT: PGRES_BAD_RESPONSE 0x5
|
||||
CONSTANT: PGRES_NONFATAL_ERROR 0x6
|
||||
CONSTANT: PGRES_FATAL_ERROR 0x7
|
||||
|
||||
! PGTransactionStatusType;
|
||||
CONSTANT: PQTRANS_IDLE 0x0
|
||||
CONSTANT: PQTRANS_ACTIVE 0x1
|
||||
CONSTANT: PQTRANS_INTRANS 0x2
|
||||
CONSTANT: PQTRANS_INERROR 0x3
|
||||
CONSTANT: PQTRANS_UNKNOWN 0x4
|
||||
|
||||
! PGVerbosity;
|
||||
CONSTANT: PQERRORS_TERSE 0x0
|
||||
CONSTANT: PQERRORS_DEFAULT 0x1
|
||||
CONSTANT: PQERRORS_VERBOSE 0x2
|
||||
|
||||
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
|
||||
|
|
@ -1,176 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||
alien.data db.types tools.walker ascii splitting math.parser
|
||||
combinators libc calendar.format byte-arrays destructors
|
||||
prettyprint accessors strings serialize io.encodings.binary
|
||||
io.encodings.utf8 alien.strings io.streams.byte-array summary
|
||||
present urls specialized-arrays db.private ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
SPECIALIZED-ARRAY: void*
|
||||
IN: db.postgresql.lib
|
||||
|
||||
: postgresql-result-error-message ( res -- str/f )
|
||||
dup zero? [
|
||||
drop f
|
||||
] [
|
||||
PQresultErrorMessage [ blank? ] trim
|
||||
] if ;
|
||||
|
||||
: postgres-result-error ( res -- )
|
||||
postgresql-result-error-message [ throw ] when* ;
|
||||
|
||||
: (postgresql-error-message) ( handle -- str )
|
||||
PQerrorMessage
|
||||
"\n" split [ [ blank? ] trim ] map "\n" join ;
|
||||
|
||||
: postgresql-error-message ( -- str )
|
||||
db-connection get handle>> (postgresql-error-message) ;
|
||||
|
||||
: postgresql-error ( res -- res )
|
||||
dup [ postgresql-error-message throw ] unless ;
|
||||
|
||||
ERROR: postgresql-result-null ;
|
||||
|
||||
M: postgresql-result-null summary ( obj -- str )
|
||||
drop "PQexec returned f." ;
|
||||
|
||||
: postgresql-result-ok? ( res -- ? )
|
||||
[ postgresql-result-null ] unless*
|
||||
PQresultStatus
|
||||
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
|
||||
|
||||
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
|
||||
PQsetdbLogin dup PQstatus zero? [
|
||||
[ (postgresql-error-message) ] [ PQfinish ] bi throw
|
||||
] unless ;
|
||||
|
||||
: do-postgresql-statement ( statement -- res )
|
||||
db-connection get handle>> swap sql>> PQexec dup postgresql-result-ok? [
|
||||
[ postgresql-result-error-message ] [ PQclear ] bi throw
|
||||
] unless ;
|
||||
|
||||
: type>oid ( symbol -- n )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ BLOB [ BYTEA-OID ] }
|
||||
{ FACTOR-BLOB [ BYTEA-OID ] }
|
||||
[ drop 0 ]
|
||||
} case ;
|
||||
|
||||
: type>param-format ( symbol -- n )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ BLOB [ 1 ] }
|
||||
{ FACTOR-BLOB [ 1 ] }
|
||||
[ drop 0 ]
|
||||
} case ;
|
||||
|
||||
: param-types ( statement -- seq )
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as ;
|
||||
|
||||
: malloc-byte-array/length ( byte-array -- alien length )
|
||||
[ malloc-byte-array &free ] [ length ] bi ;
|
||||
|
||||
: default-param-value ( obj -- alien n )
|
||||
number>string* dup [ utf8 malloc-string &free ] when 0 ;
|
||||
|
||||
: param-values ( statement -- seq seq2 )
|
||||
[ bind-params>> ] [ in-params>> ] bi
|
||||
[
|
||||
[ value>> ] [ type>> ] bi* {
|
||||
{ FACTOR-BLOB [
|
||||
dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
|
||||
] }
|
||||
{ BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
|
||||
{ DATE [ dup [ timestamp>ymd ] when default-param-value ] }
|
||||
{ TIME [ dup [ timestamp>hms ] when default-param-value ] }
|
||||
{ DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
|
||||
{ TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
|
||||
{ URL [ dup [ present ] when default-param-value ] }
|
||||
[ drop default-param-value ]
|
||||
} case 2array
|
||||
] 2map flip [
|
||||
f f
|
||||
] [
|
||||
first2 [ void* >c-array ] [ uint >c-array ] bi*
|
||||
] if-empty ;
|
||||
|
||||
: param-formats ( statement -- seq )
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
|
||||
|
||||
: do-postgresql-bound-statement ( statement -- res )
|
||||
[
|
||||
[ db-connection get handle>> ] dip
|
||||
{
|
||||
[ sql>> ]
|
||||
[ bind-params>> length ]
|
||||
[ param-types ]
|
||||
[ param-values ]
|
||||
[ param-formats ]
|
||||
} cleave
|
||||
0 PQexecParams dup postgresql-result-ok? [
|
||||
[ postgresql-result-error-message ] [ PQclear ] bi throw
|
||||
] unless
|
||||
] with-destructors ;
|
||||
|
||||
: pq-get-is-null ( handle row column -- ? )
|
||||
PQgetisnull 1 = ;
|
||||
|
||||
: pq-get-string ( handle row column -- obj )
|
||||
3dup PQgetvalue utf8 alien>string
|
||||
dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
|
||||
|
||||
: pq-get-number ( handle row column -- obj )
|
||||
pq-get-string dup [ string>number ] when ;
|
||||
|
||||
TUPLE: postgresql-malloc-destructor alien ;
|
||||
C: <postgresql-malloc-destructor> postgresql-malloc-destructor
|
||||
|
||||
M: postgresql-malloc-destructor dispose ( obj -- )
|
||||
alien>> PQfreemem ;
|
||||
|
||||
: &postgresql-free ( alien -- alien )
|
||||
dup <postgresql-malloc-destructor> &dispose drop ; inline
|
||||
|
||||
: pq-get-blob ( handle row column -- obj/f )
|
||||
[ PQgetvalue ] 3keep 3dup PQgetlength
|
||||
dup 0 > [
|
||||
[ 3drop ] dip
|
||||
[
|
||||
memory>byte-array >string
|
||||
{ uint }
|
||||
[
|
||||
PQunescapeBytea dup zero? [
|
||||
postgresql-result-error-message throw
|
||||
] [
|
||||
&postgresql-free
|
||||
] if
|
||||
] with-out-parameters memory>byte-array
|
||||
] with-destructors
|
||||
] [
|
||||
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
|
||||
] if ;
|
||||
|
||||
: postgresql-column-typed ( handle row column type -- obj )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ +db-assigned-id+ [ pq-get-number ] }
|
||||
{ +random-id+ [ pq-get-number ] }
|
||||
{ INTEGER [ pq-get-number ] }
|
||||
{ BIG-INTEGER [ pq-get-number ] }
|
||||
{ DOUBLE [ pq-get-number ] }
|
||||
{ TEXT [ pq-get-string ] }
|
||||
{ VARCHAR [ pq-get-string ] }
|
||||
{ DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
|
||||
{ TIME [ pq-get-string dup [ hms>timestamp ] when ] }
|
||||
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
|
||||
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
|
||||
{ BLOB [ pq-get-blob ] }
|
||||
{ URL [ pq-get-string dup [ >url ] when ] }
|
||||
{ FACTOR-BLOB [
|
||||
pq-get-blob
|
||||
dup [ bytes>object ] when ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
USING: accessors alien continuations db db.errors db.queries db.postgresql
|
||||
db.private db.tester db.tuples db.types io classes kernel math namespaces
|
||||
prettyprint sequences system tools.test unicode.case ;
|
||||
IN: db.postgresql.tests
|
||||
|
||||
: nonexistant-db ( -- db )
|
||||
<postgresql-db>
|
||||
"localhost" >>host
|
||||
"fake-user" >>username
|
||||
"no-pass" >>password
|
||||
"dont-exist" >>database ;
|
||||
|
||||
! Don't leak connections
|
||||
{ } [
|
||||
2000 [ [ nonexistant-db [ ] with-db ] ignore-errors ] times
|
||||
] unit-test
|
||||
|
||||
! Ensure the test database exists
|
||||
postgresql-template1-db [
|
||||
postgresql-test-db-name ensure-database
|
||||
] with-db
|
||||
|
||||
! Triggers a two line error message (ERROR + DETAIL) because two
|
||||
! connections can't simultaneously use the template1 database.
|
||||
! [
|
||||
! postgresql-template1-db [
|
||||
! postgresql-template1-db [
|
||||
! "will_never_exist" ensure-database
|
||||
! ] with-db
|
||||
! ] with-db
|
||||
! ] [ sql-unknown-error? ] must-fail-with
|
||||
|
||||
{ } [
|
||||
postgresql-test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
||||
"insert into person values('John', 'America');" sql-command
|
||||
"insert into person values('Jane', 'New Zealand');" sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
} [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
} [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
{
|
||||
} [
|
||||
postgresql-test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
} [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] must-fail
|
||||
|
||||
{ 3 } [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{
|
||||
} [
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
@ -1,293 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs alien alien.syntax continuations io
|
||||
kernel math math.parser namespaces make prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators classes classes.tuple locals words tools.walker
|
||||
db.private nmake accessors random db.queries destructors
|
||||
db.tuples.private db.postgresql db.errors.postgresql splitting ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty database username password ;
|
||||
|
||||
: <postgresql-db> ( -- postgresql-db )
|
||||
postgresql-db new ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: postgresql-db-connection < db-connection ;
|
||||
: <postgresql-db-connection> ( handle -- db-connection )
|
||||
postgresql-db-connection new-db-connection
|
||||
swap >>handle ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: postgresql-statement < statement ;
|
||||
|
||||
TUPLE: postgresql-result-set < result-set ;
|
||||
|
||||
M: postgresql-db db-open ( db -- db-connection )
|
||||
{
|
||||
[ host>> ]
|
||||
[ port>> ]
|
||||
[ pgopts>> ]
|
||||
[ pgtty>> ]
|
||||
[ database>> ]
|
||||
[ username>> ]
|
||||
[ password>> ]
|
||||
} cleave connect-postgres <postgresql-db-connection> ;
|
||||
|
||||
M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
|
||||
|
||||
M: postgresql-statement bind-statement* ( statement -- ) drop ;
|
||||
|
||||
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
|
||||
|
||||
M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
|
||||
slot-name>> swap get-slot-named <low-level-binding> ;
|
||||
|
||||
M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
|
||||
nip value>> <low-level-binding> ;
|
||||
|
||||
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
|
||||
dup generator-singleton>> eval-generator
|
||||
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
|
||||
|
||||
M: postgresql-statement bind-tuple ( tuple statement -- )
|
||||
[ nip ] [
|
||||
in-params>>
|
||||
[ postgresql-bind-conversion ] with map
|
||||
] 2bi
|
||||
>>bind-params drop ;
|
||||
|
||||
M: postgresql-result-set #rows ( result-set -- n )
|
||||
handle>> PQntuples ;
|
||||
|
||||
M: postgresql-result-set #columns ( result-set -- n )
|
||||
handle>> PQnfields ;
|
||||
|
||||
: result-handle-n ( result-set -- handle n )
|
||||
[ handle>> ] [ n>> ] bi ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set column -- object )
|
||||
[ result-handle-n ] dip pq-get-string ;
|
||||
|
||||
M: postgresql-result-set row-column-typed ( result-set column -- object )
|
||||
dup pick out-params>> nth type>>
|
||||
[ result-handle-n ] 2dip postgresql-column-typed ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup bind-params>> [
|
||||
over [ bind-statement ] keep
|
||||
do-postgresql-bound-statement
|
||||
] [
|
||||
dup do-postgresql-statement
|
||||
] if*
|
||||
postgresql-result-set new-result-set
|
||||
dup init-result-set ;
|
||||
|
||||
M: postgresql-result-set advance-row ( result-set -- )
|
||||
[ 1 + ] change-n drop ;
|
||||
|
||||
M: postgresql-result-set more-rows? ( result-set -- ? )
|
||||
[ n>> ] [ max>> ] bi < ;
|
||||
|
||||
M: postgresql-statement dispose ( query -- )
|
||||
dup handle>> PQclear
|
||||
f >>handle drop ;
|
||||
|
||||
M: postgresql-result-set dispose ( result-set -- )
|
||||
[ handle>> PQclear ]
|
||||
[
|
||||
0 >>n
|
||||
0 >>max
|
||||
f >>handle drop
|
||||
] bi ;
|
||||
|
||||
M: postgresql-statement prepare-statement ( statement -- )
|
||||
dup
|
||||
[ db-connection get handle>> f ] dip
|
||||
[ sql>> ] [ in-params>> ] bi
|
||||
length f PQprepare postgresql-error
|
||||
>>handle drop ;
|
||||
|
||||
M: postgresql-db-connection <simple-statement> ( sql in out -- statement )
|
||||
postgresql-statement new-statement ;
|
||||
|
||||
M: postgresql-db-connection <prepared-statement> ( sql in out -- statement )
|
||||
<simple-statement> dup prepare-statement ;
|
||||
|
||||
: bind-name% ( -- )
|
||||
CHAR: $ 0,
|
||||
sql-counter [ inc ] [ get 0# ] bi ;
|
||||
|
||||
M: postgresql-db-connection bind% ( spec -- )
|
||||
bind-name% 1, ;
|
||||
|
||||
M: postgresql-db-connection bind# ( spec object -- )
|
||||
[ bind-name% f swap type>> ] dip
|
||||
<literal-bind> 1, ;
|
||||
|
||||
: create-table-sql ( class -- statement )
|
||||
[
|
||||
dupd
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup column-name>> 0%
|
||||
" " 0%
|
||||
dup type>> lookup-create-type 0%
|
||||
modifiers 0%
|
||||
] interleave
|
||||
|
||||
", " 0%
|
||||
find-primary-key
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
"));" 0%
|
||||
] query-make ;
|
||||
|
||||
: create-function-sql ( class -- statement )
|
||||
[
|
||||
[ dup remove-id ] dip
|
||||
"create function add_" 0% dup 0%
|
||||
"(" 0%
|
||||
over [ "," 0% ]
|
||||
[
|
||||
type>> lookup-type 0%
|
||||
] interleave
|
||||
")" 0%
|
||||
" returns bigint as '" 0%
|
||||
|
||||
"insert into " 0%
|
||||
dup 0%
|
||||
"(" 0%
|
||||
over [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
") values(" 0%
|
||||
swap [ ", " 0% ] [ drop bind-name% ] interleave
|
||||
"); " 0%
|
||||
"select currval(''" 0% 0% "_" 0%
|
||||
find-primary-key first column-name>> 0%
|
||||
"_seq'');' language sql;" 0%
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db-connection create-sql-statement ( class -- seq )
|
||||
[
|
||||
[ create-table-sql , ] keep
|
||||
dup db-assigned? [ create-function-sql , ] [ drop ] if
|
||||
] { } make ;
|
||||
|
||||
: drop-function-sql ( class -- statement )
|
||||
[
|
||||
"drop function add_" 0% 0%
|
||||
"(" 0%
|
||||
remove-id
|
||||
[ ", " 0% ] [ type>> lookup-type 0% ] interleave
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
: drop-table-sql ( table -- statement )
|
||||
[
|
||||
"drop table " 0% 0% drop
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db-connection drop-sql-statement ( class -- seq )
|
||||
[
|
||||
[ drop-table-sql , ] keep
|
||||
dup db-assigned? [ drop-function-sql , ] [ drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement )
|
||||
[
|
||||
"select add_" 0% 0%
|
||||
"(" 0%
|
||||
dup find-primary-key first 2,
|
||||
remove-id
|
||||
[ ", " 0% ] [ bind% ] interleave
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
")" 0%
|
||||
|
||||
" values(" 0%
|
||||
[ ", " 0% ] [
|
||||
dup type>> +random-id+ = [
|
||||
[
|
||||
bind-name%
|
||||
slot-name>>
|
||||
f
|
||||
random-id-generator
|
||||
] [ type>> ] bi <generator-bind> 1,
|
||||
] [
|
||||
bind%
|
||||
] if
|
||||
] interleave
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
|
||||
query-modify-tuple ;
|
||||
|
||||
M: postgresql-db-connection persistent-table ( -- hashtable )
|
||||
H{
|
||||
{ +db-assigned-id+ { "integer" "serial" f } }
|
||||
{ +user-assigned-id+ { f f f } }
|
||||
{ +random-id+ { "bigint" "bigint" f } }
|
||||
|
||||
{ +foreign-id+ { f f "references" } }
|
||||
|
||||
{ +on-update+ { f f "on update" } }
|
||||
{ +on-delete+ { f f "on delete" } }
|
||||
{ +restrict+ { f f "restrict" } }
|
||||
{ +cascade+ { f f "cascade" } }
|
||||
{ +set-null+ { f f "set null" } }
|
||||
{ +set-default+ { f f "set default" } }
|
||||
|
||||
{ TEXT { "text" "text" f } }
|
||||
{ VARCHAR { "varchar" "varchar" f } }
|
||||
{ INTEGER { "integer" "integer" f } }
|
||||
{ BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ DOUBLE { "real" "real" f } }
|
||||
{ DATE { "date" "date" f } }
|
||||
{ TIME { "time" "time" f } }
|
||||
{ DATETIME { "timestamp" "timestamp" f } }
|
||||
{ TIMESTAMP { "timestamp" "timestamp" f } }
|
||||
{ BLOB { "bytea" "bytea" f } }
|
||||
{ FACTOR-BLOB { "bytea" "bytea" f } }
|
||||
{ URL { "varchar" "varchar" f } }
|
||||
{ +autoincrement+ { f f "autoincrement" } }
|
||||
{ +unique+ { f f "unique" } }
|
||||
{ +default+ { f f "default" } }
|
||||
{ +null+ { f f "null" } }
|
||||
{ +not-null+ { f f "not null" } }
|
||||
{ system-random-generator { f f f } }
|
||||
{ secure-random-generator { f f f } }
|
||||
{ random-generator { f f f } }
|
||||
} ;
|
||||
|
||||
ERROR: no-compound-found string object ;
|
||||
M: postgresql-db-connection compound ( string object -- string' )
|
||||
over {
|
||||
{ "default" [ first number>string " " glue ] }
|
||||
{ "varchar" [ first number>string "(" ")" surround append ] }
|
||||
{ "references" [ >reference-string ] }
|
||||
[ drop no-compound-found ]
|
||||
} case ;
|
||||
|
||||
M: postgresql-db-connection parse-db-error
|
||||
"\n" split dup length {
|
||||
{ 1 [ first parse-postgresql-sql-error ] }
|
||||
{ 2 [ concat parse-postgresql-sql-error ] }
|
||||
{ 3 [
|
||||
first3
|
||||
[ parse-postgresql-sql-error ] 2dip
|
||||
postgresql-location >>location
|
||||
] }
|
||||
} case ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
PostgreSQL database connector
|
||||
|
|
@ -1,216 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays classes classes.tuple
|
||||
combinators continuations db db.errors db.private db.tuples
|
||||
db.tuples.private db.types destructors kernel make math
|
||||
math.bitwise math.intervals math.parser namespaces nmake
|
||||
prettyprint random sequences shuffle strings words fry ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
||||
SINGLETON: retryable
|
||||
: make-retryable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-retryable ] map
|
||||
] [
|
||||
retryable >>type
|
||||
10 >>retries
|
||||
] if ;
|
||||
|
||||
: maybe-make-retryable ( statement -- statement )
|
||||
dup in-params>> [ generator-bind? ] any?
|
||||
[ make-retryable ] when ;
|
||||
|
||||
: regenerate-params ( statement -- statement )
|
||||
dup
|
||||
[ bind-params>> ] [ in-params>> ] bi
|
||||
[
|
||||
dup generator-bind? [
|
||||
generator-singleton>> eval-generator >>value
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] 2map >>bind-params ;
|
||||
|
||||
M: retryable execute-statement* ( statement type -- )
|
||||
drop [ retries>> iota ] [
|
||||
[
|
||||
nip
|
||||
[ query-results dispose t ]
|
||||
[ ]
|
||||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry
|
||||
] bi attempt-all drop ;
|
||||
|
||||
: sql-props ( class -- columns table )
|
||||
[ db-columns ] [ db-table-name ] bi ;
|
||||
|
||||
: query-make ( class quot -- statements )
|
||||
! query, input, outputs, secondary queries
|
||||
over db-table-name "table-name" set
|
||||
[ sql-props ] dip
|
||||
[ 0 sql-counter rot with-variable ] curry
|
||||
{ "" { } { } { } } nmake
|
||||
[ <simple-statement> maybe-make-retryable ] dip
|
||||
[ [ 1array ] dip append ] unless-empty ; inline
|
||||
|
||||
: where-primary-key% ( specs -- )
|
||||
" where " 0%
|
||||
find-primary-key [
|
||||
" and " 0%
|
||||
] [
|
||||
dup column-name>> 0% " = " 0% bind%
|
||||
] interleave ;
|
||||
|
||||
M: db-connection <update-tuple-statement> ( class -- statement )
|
||||
[
|
||||
"update " 0% 0%
|
||||
" set " 0%
|
||||
dup remove-id
|
||||
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
|
||||
where-primary-key%
|
||||
] query-make ;
|
||||
|
||||
M: random-id-generator eval-generator ( singleton -- obj )
|
||||
drop
|
||||
system-random-generator get [
|
||||
63 [ random-bits ] keep 1 - set-bit
|
||||
] with-random ;
|
||||
|
||||
: interval-comparison ( ? str -- str )
|
||||
"from" = " >" " <" ? swap [ "= " append ] when ;
|
||||
|
||||
: (infinite-interval?) ( interval -- ?1 ?2 )
|
||||
[ from>> ] [ to>> ] bi
|
||||
[ first fp-infinity? ] bi@ ;
|
||||
|
||||
: double-infinite-interval? ( obj -- ? )
|
||||
dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
|
||||
|
||||
: infinite-interval? ( obj -- ? )
|
||||
dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
|
||||
|
||||
: where-interval ( spec obj from/to -- )
|
||||
over first fp-infinity? [
|
||||
3drop
|
||||
] [
|
||||
pick column-name>> 0%
|
||||
[ first2 ] dip interval-comparison 0%
|
||||
bind#
|
||||
] if ;
|
||||
|
||||
: in-parens ( quot -- )
|
||||
"(" 0% call ")" 0% ; inline
|
||||
|
||||
M: interval where ( spec obj -- )
|
||||
[
|
||||
[ from>> "from" where-interval ] [
|
||||
nip infinite-interval? [ " and " 0% ] unless
|
||||
] [ to>> "to" where-interval ] 2tri
|
||||
] in-parens ;
|
||||
|
||||
M: sequence where ( spec obj -- )
|
||||
[
|
||||
[ " or " 0% ] [ dupd where ] interleave drop
|
||||
] in-parens ;
|
||||
|
||||
M: byte-array where ( spec obj -- )
|
||||
over column-name>> 0% " = " 0% bind# ;
|
||||
|
||||
M: NULL where ( spec obj -- )
|
||||
drop column-name>> 0% " is NULL" 0% ;
|
||||
|
||||
: object-where ( spec obj -- )
|
||||
over column-name>> 0% " = " 0% bind# ;
|
||||
|
||||
M: object where ( spec obj -- ) object-where ;
|
||||
|
||||
M: integer where ( spec obj -- ) object-where ;
|
||||
|
||||
M: string where ( spec obj -- ) object-where ;
|
||||
|
||||
: filter-slots ( tuple specs -- specs' )
|
||||
[
|
||||
slot-name>> swap get-slot-named
|
||||
dup double-infinite-interval? [ drop f ] when
|
||||
] with filter ;
|
||||
|
||||
: many-where ( tuple seq -- )
|
||||
" where " 0% [
|
||||
" and " 0%
|
||||
] [
|
||||
2dup slot-name>> swap get-slot-named where
|
||||
] interleave drop ;
|
||||
|
||||
: where-clause ( tuple specs -- )
|
||||
dupd filter-slots [ drop ] [ many-where ] if-empty ;
|
||||
|
||||
M: db-connection <delete-tuples-statement> ( tuple table -- sql )
|
||||
[
|
||||
"delete from " 0% 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
||||
ERROR: all-slots-ignored class ;
|
||||
|
||||
M: db-connection <select-by-slots-statement> ( tuple class -- statement )
|
||||
[
|
||||
"select " 0%
|
||||
[ dupd filter-ignores ] dip
|
||||
over empty? [ all-slots-ignored ] when
|
||||
over
|
||||
[ ", " 0% ]
|
||||
[ dup column-name>> 0% 2, ] interleave
|
||||
" from " 0% 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
||||
: do-group ( tuple groups -- )
|
||||
dup string? [ 1array ] when
|
||||
[ ", " join " group by " glue ] curry change-sql drop ;
|
||||
|
||||
: do-order ( tuple order -- )
|
||||
dup string? [ 1array ] when
|
||||
[ ", " join " order by " glue ] curry change-sql drop ;
|
||||
|
||||
: do-offset ( tuple n -- )
|
||||
[ number>string " offset " glue ] curry change-sql drop ;
|
||||
|
||||
: do-limit ( tuple n -- )
|
||||
[ number>string " limit " glue ] curry change-sql drop ;
|
||||
|
||||
: make-query* ( tuple query -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ drop ] [ do-group ] if-empty ]
|
||||
[ order>> [ drop ] [ do-order ] if-empty ]
|
||||
[ limit>> [ do-limit ] [ drop ] if* ]
|
||||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db-connection query>statement ( query -- tuple )
|
||||
[ tuple>> dup class-of ] keep
|
||||
[ <select-by-slots-statement> ] dip make-query* ;
|
||||
|
||||
! select ID, NAME, SCORE from EXAM limit 1 offset 3
|
||||
|
||||
M: db-connection <count-statement> ( query -- statement )
|
||||
[ tuple>> dup class-of ] keep
|
||||
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
|
||||
dip make-query* ;
|
||||
|
||||
: create-index ( index-name table-name columns -- )
|
||||
[
|
||||
[ [ "create index " % % ] dip " on " % % ] dip "(" %
|
||||
"," join % ")" %
|
||||
] "" make sql-command ;
|
||||
|
||||
: drop-index ( index-name -- )
|
||||
[ "drop index " % % ] "" make sql-command ;
|
||||
|
||||
: create-database ( string -- )
|
||||
"create database " ";" surround sql-command ;
|
||||
|
||||
: ensure-database ( string -- )
|
||||
'[ _ create-database ] ignore-database-exists ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Database queries
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
Chris Double
|
||||
Doug Coleman
|
||||
|
|
@ -1,140 +0,0 @@
|
|||
! Copyright (C) 2005 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! An interface to the sqlite database. Tested against sqlite v3.1.3.
|
||||
! Not all functions have been wrapped.
|
||||
USING: alien alien.c-types alien.libraries alien.syntax
|
||||
combinators system ;
|
||||
IN: db.sqlite.ffi
|
||||
|
||||
<< "sqlite" {
|
||||
{ [ os windows? ] [ "sqlite3.dll" ] }
|
||||
{ [ os macosx? ] [ "libsqlite3.dylib" ] }
|
||||
{ [ os unix? ] [ "libsqlite3.so" ] }
|
||||
} cond cdecl add-library >>
|
||||
|
||||
! 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
|
||||
|
||||
: sqlite-error-messages ( -- seq ) {
|
||||
"Successful result"
|
||||
"SQL error or missing database"
|
||||
"An internal logic error in SQLite"
|
||||
"Access permission denied"
|
||||
"Callback routine requested an abort"
|
||||
"The database file is locked"
|
||||
"A table in the database is locked"
|
||||
"A malloc() failed"
|
||||
"Attempt to write a readonly database"
|
||||
"Operation terminated by sqlite_interrupt()"
|
||||
"Some kind of disk I/O error occurred"
|
||||
"The database disk image is malformed"
|
||||
"(Internal Only) Table or record not found"
|
||||
"Insertion failed because database is full"
|
||||
"Unable to open the database file"
|
||||
"Database lock protocol error"
|
||||
"(Internal Only) Database table is empty"
|
||||
"The database schema changed"
|
||||
"Too much data for one row of a table"
|
||||
"Abort due to contraint violation"
|
||||
"Data type mismatch"
|
||||
"Library used incorrectly"
|
||||
"Uses OS features not supported on host"
|
||||
"Authorization denied"
|
||||
"Auxiliary database format error"
|
||||
"2nd parameter to sqlite3_bind out of range"
|
||||
"File opened that is not a database file"
|
||||
} ;
|
||||
|
||||
! Return values from sqlite3_step
|
||||
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 )
|
||||
|
|
@ -1,178 +0,0 @@
|
|||
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.data arrays assocs kernel math math.parser
|
||||
namespaces sequences db.sqlite.ffi db combinators
|
||||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
io.backend db.errors present urls io.encodings.utf8
|
||||
io.encodings.string accessors shuffle io db.private ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
ERROR: sqlite-error < db-error n string ;
|
||||
ERROR: sqlite-sql-error < sql-error n string ;
|
||||
|
||||
: sqlite-other-error ( n -- * )
|
||||
dup sqlite-error-messages nth sqlite-error ;
|
||||
|
||||
: sqlite-statement-error ( -- * )
|
||||
SQLITE_ERROR
|
||||
db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
|
||||
|
||||
: sqlite-check-result ( n -- )
|
||||
{
|
||||
{ SQLITE_OK [ ] }
|
||||
{ SQLITE_ERROR [ sqlite-statement-error ] }
|
||||
[ sqlite-other-error ]
|
||||
} case ;
|
||||
|
||||
: sqlite-open ( path -- db )
|
||||
normalize-path
|
||||
{ void* } [ sqlite3_open sqlite-check-result ]
|
||||
with-out-parameters ;
|
||||
|
||||
: sqlite-close ( db -- )
|
||||
sqlite3_close sqlite-check-result ;
|
||||
|
||||
: sqlite-prepare ( db sql -- handle )
|
||||
utf8 encode dup length
|
||||
{ void* void* }
|
||||
[ sqlite3_prepare_v2 sqlite-check-result ]
|
||||
with-out-parameters drop ;
|
||||
|
||||
: sqlite-bind-parameter-index ( handle name -- index )
|
||||
sqlite3_bind_parameter_index ;
|
||||
|
||||
: parameter-index ( handle name text -- handle name text )
|
||||
[ dupd sqlite-bind-parameter-index ] dip ;
|
||||
|
||||
: sqlite-bind-text ( handle index text -- )
|
||||
utf8 encode dup length SQLITE_TRANSIENT
|
||||
sqlite3_bind_text sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-int ( handle i n -- )
|
||||
sqlite3_bind_int sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-int64 ( handle i n -- )
|
||||
sqlite3_bind_int64 sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-uint64 ( handle i n -- )
|
||||
sqlite3-bind-uint64 sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-double ( handle i x -- )
|
||||
sqlite3_bind_double sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-null ( handle i -- )
|
||||
sqlite3_bind_null sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-blob ( handle i byte-array -- )
|
||||
dup length SQLITE_TRANSIENT
|
||||
sqlite3_bind_blob sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-text-by-name ( handle name text -- )
|
||||
parameter-index sqlite-bind-text ;
|
||||
|
||||
: sqlite-bind-int-by-name ( handle name int -- )
|
||||
parameter-index sqlite-bind-int ;
|
||||
|
||||
: sqlite-bind-int64-by-name ( handle name int64 -- )
|
||||
parameter-index sqlite-bind-int64 ;
|
||||
|
||||
: sqlite-bind-uint64-by-name ( handle name int64 -- )
|
||||
parameter-index sqlite-bind-uint64 ;
|
||||
|
||||
: sqlite-bind-boolean-by-name ( handle name obj -- )
|
||||
>boolean 1 0 ? parameter-index sqlite-bind-int ;
|
||||
|
||||
: sqlite-bind-double-by-name ( handle name double -- )
|
||||
parameter-index sqlite-bind-double ;
|
||||
|
||||
: sqlite-bind-blob-by-name ( handle name blob -- )
|
||||
parameter-index sqlite-bind-blob ;
|
||||
|
||||
: sqlite-bind-null-by-name ( handle name obj -- )
|
||||
parameter-index drop sqlite-bind-null ;
|
||||
|
||||
: (sqlite-bind-type) ( handle key value type -- )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ INTEGER [ sqlite-bind-int-by-name ] }
|
||||
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
|
||||
{ SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
|
||||
{ UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
|
||||
{ BOOLEAN [ sqlite-bind-boolean-by-name ] }
|
||||
{ TEXT [ sqlite-bind-text-by-name ] }
|
||||
{ VARCHAR [ sqlite-bind-text-by-name ] }
|
||||
{ DOUBLE [ sqlite-bind-double-by-name ] }
|
||||
{ DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
|
||||
{ TIME [ timestamp>hms sqlite-bind-text-by-name ] }
|
||||
{ DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
|
||||
{ TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
|
||||
{ BLOB [ sqlite-bind-blob-by-name ] }
|
||||
{ FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] }
|
||||
{ URL [ present sqlite-bind-text-by-name ] }
|
||||
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
|
||||
{ +random-id+ [ sqlite-bind-int64-by-name ] }
|
||||
{ NULL [ sqlite-bind-null-by-name ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
|
||||
: sqlite-bind-type ( handle key value type -- )
|
||||
! null and empty values need to be set by sqlite-bind-null-by-name
|
||||
over [
|
||||
NULL = [ 2drop NULL NULL ] when
|
||||
] [
|
||||
drop NULL
|
||||
] if* (sqlite-bind-type) ;
|
||||
|
||||
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
|
||||
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-clear-bindings ( handle -- )
|
||||
sqlite3_clear_bindings sqlite-check-result ;
|
||||
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
|
||||
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
|
||||
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
|
||||
: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
|
||||
|
||||
: sqlite-column-blob ( handle index -- byte-array/f )
|
||||
[ sqlite3_column_bytes ] 2keep
|
||||
pick zero? [
|
||||
3drop f
|
||||
] [
|
||||
sqlite3_column_blob swap memory>byte-array
|
||||
] if ;
|
||||
|
||||
: sqlite-column-typed ( handle index type -- obj )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ +db-assigned-id+ [ sqlite3_column_int64 ] }
|
||||
{ +random-id+ [ sqlite3-column-uint64 ] }
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
|
||||
{ BOOLEAN [ sqlite3_column_int 1 = ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
{ TEXT [ sqlite3_column_text ] }
|
||||
{ VARCHAR [ sqlite3_column_text ] }
|
||||
{ DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
|
||||
{ TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
|
||||
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
|
||||
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
|
||||
{ BLOB [ sqlite-column-blob ] }
|
||||
{ URL [ sqlite3_column_text dup [ >url ] when ] }
|
||||
{ FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
|
||||
: sqlite-row ( handle -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with { } map-integers ;
|
||||
|
||||
: sqlite-step-has-more-rows? ( prepared -- ? )
|
||||
{
|
||||
{ SQLITE_ROW [ t ] }
|
||||
{ SQLITE_DONE [ f ] }
|
||||
[ sqlite-check-result f ]
|
||||
} case ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step sqlite-step-has-more-rows? ;
|
||||
|
|
@ -1,174 +0,0 @@
|
|||
USING: io io.files io.files.temp io.directories io.launcher
|
||||
kernel namespaces prettyprint tools.test db.sqlite db sequences
|
||||
continuations db.types db.tuples unicode.case accessors arrays
|
||||
sorting layouts math.parser ;
|
||||
IN: db.sqlite.tests
|
||||
|
||||
: db-path ( -- path ) "test-" cell number>string ".db" 3append temp-file ;
|
||||
: test.db ( -- sqlite-db ) db-path <sqlite-db> ;
|
||||
|
||||
{ } [ [ db-path delete-file ] ignore-errors ] unit-test
|
||||
|
||||
{ } [
|
||||
test.db [
|
||||
"create table person (name varchar(30), country varchar(30))" sql-command
|
||||
"insert into person values('John', 'America')" sql-command
|
||||
"insert into person values('Jane', 'New Zealand')" sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
|
||||
{ { { "John" "America" } { "Jane" "New Zealand" } } } [
|
||||
test.db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } }
|
||||
[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
{ } [
|
||||
test.db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
{ "3" "Jimmy" "Canada" }
|
||||
}
|
||||
} [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] must-fail
|
||||
|
||||
{ 3 } [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ \ swap ensure-table ] must-fail
|
||||
|
||||
! You don't need a primary key
|
||||
TUPLE: things one two ;
|
||||
|
||||
things "THINGS" {
|
||||
{ "one" "ONE" INTEGER +not-null+ }
|
||||
{ "two" "TWO" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
{ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } } [
|
||||
test.db [
|
||||
things create-table
|
||||
0 0 things boa insert-tuple
|
||||
0 1 things boa insert-tuple
|
||||
1 1 things boa insert-tuple
|
||||
1 0 things boa insert-tuple
|
||||
f f things boa select-tuples
|
||||
[ [ one>> ] [ two>> ] bi 2array ] map natural-sort
|
||||
things drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
! Tables can have different names than the name of the tuple
|
||||
TUPLE: foo slot ;
|
||||
C: <foo> foo
|
||||
foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
|
||||
|
||||
TUPLE: hi bye try ;
|
||||
C: <hi> hi
|
||||
hi "HELLO" {
|
||||
{ "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
{ "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
} define-persistent
|
||||
|
||||
{ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } } [
|
||||
test.db [
|
||||
foo create-table
|
||||
hi create-table
|
||||
1 <foo> insert-tuple
|
||||
f <foo> select-tuple
|
||||
1 1 <hi> insert-tuple
|
||||
f f <hi> select-tuple
|
||||
hi drop-table
|
||||
foo drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
|
||||
! Test SQLite triggers
|
||||
|
||||
TUPLE: show id ;
|
||||
TUPLE: user username data ;
|
||||
TUPLE: watch show user ;
|
||||
|
||||
user "USER" {
|
||||
{ "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
|
||||
{ "data" "DATA" TEXT }
|
||||
} define-persistent
|
||||
|
||||
show "SHOW" {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
} define-persistent
|
||||
|
||||
watch "WATCH" {
|
||||
{ "user" "USER" TEXT +not-null+ +user-assigned-id+
|
||||
{ +foreign-id+ user "USERNAME" } }
|
||||
{ "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
|
||||
{ +foreign-id+ show "ID" } }
|
||||
} define-persistent
|
||||
|
||||
{ T{ user { username "littledan" } { data "foo" } } } [
|
||||
test.db [
|
||||
user create-table
|
||||
show create-table
|
||||
watch create-table
|
||||
"littledan" "foo" user boa insert-tuple
|
||||
"mark" "bar" user boa insert-tuple
|
||||
show new insert-tuple
|
||||
show new select-tuple
|
||||
"littledan" f user boa select-tuple
|
||||
[ id>> ] [ username>> ] bi*
|
||||
watch boa insert-tuple
|
||||
watch new select-tuple
|
||||
user>> f user boa select-tuple
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
test.db [ [
|
||||
user ensure-table [
|
||||
"mew" "foo" user boa insert-tuple
|
||||
"denny" "kitty" user boa insert-tuple
|
||||
] with-transaction
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
@ -1,343 +0,0 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db hashtables
|
||||
io.files kernel math math.parser namespaces prettyprint fry
|
||||
sequences strings classes.tuple alien.c-types continuations
|
||||
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
|
||||
math.intervals io locals nmake accessors vectors math.ranges random
|
||||
math.bitwise db.queries destructors db.tuples.private interpolate
|
||||
io.streams.string make db.private sequences.deep
|
||||
db.errors.sqlite ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
||||
: <sqlite-db> ( path -- sqlite-db )
|
||||
sqlite-db new
|
||||
swap >>path ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: sqlite-db-connection < db-connection ;
|
||||
|
||||
: <sqlite-db-connection> ( handle -- db-connection )
|
||||
sqlite-db-connection new-db-connection
|
||||
swap >>handle ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: sqlite-db db-open ( db -- db-connection )
|
||||
path>> sqlite-open <sqlite-db-connection> ;
|
||||
|
||||
M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
|
||||
|
||||
TUPLE: sqlite-statement < statement ;
|
||||
|
||||
TUPLE: sqlite-result-set < result-set has-more? ;
|
||||
|
||||
M: sqlite-db-connection <simple-statement> ( str in out -- obj )
|
||||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
|
||||
sqlite-statement new-statement ;
|
||||
|
||||
: sqlite-maybe-prepare ( statement -- statement )
|
||||
dup handle>> [
|
||||
db-connection get handle>> over sql>> sqlite-prepare
|
||||
>>handle
|
||||
] unless ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
handle>>
|
||||
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
f >>handle drop ;
|
||||
|
||||
: reset-bindings ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
|
||||
|
||||
M: sqlite-statement low-level-bind ( statement -- )
|
||||
[ handle>> ] [ bind-params>> ] bi
|
||||
[ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
dup bound?>> [ dup reset-bindings ] when
|
||||
low-level-bind ;
|
||||
|
||||
GENERIC: sqlite-bind-conversion ( tuple obj -- array )
|
||||
|
||||
TUPLE: sqlite-low-level-binding < low-level-binding key type ;
|
||||
: <sqlite-low-level-binding> ( key value type -- obj )
|
||||
sqlite-low-level-binding new
|
||||
swap >>type
|
||||
swap >>value
|
||||
swap >>key ;
|
||||
|
||||
M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
|
||||
[ column-name>> ":" prepend ]
|
||||
[ slot-name>> rot get-slot-named ]
|
||||
[ type>> ] tri <sqlite-low-level-binding> ;
|
||||
|
||||
M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
|
||||
nip [ key>> ] [ value>> ] [ type>> ] tri
|
||||
<sqlite-low-level-binding> ;
|
||||
|
||||
M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
|
||||
generate-bind generator-singleton>> eval-generator :> obj
|
||||
generate-bind slot-name>> :> name
|
||||
obj name tuple set-slot-named
|
||||
generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
|
||||
|
||||
M: sqlite-statement bind-tuple ( tuple statement -- )
|
||||
[
|
||||
in-params>> [ sqlite-bind-conversion ] with map
|
||||
] keep bind-statement ;
|
||||
|
||||
ERROR: sqlite-last-id-fail ;
|
||||
|
||||
: last-insert-id ( -- id )
|
||||
db-connection get handle>> sqlite3_last_insert_rowid
|
||||
dup zero? [ sqlite-last-id-fail ] when ;
|
||||
|
||||
M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
|
||||
execute-statement last-insert-id swap set-primary-key ;
|
||||
|
||||
M: sqlite-result-set #columns ( result-set -- n )
|
||||
handle>> sqlite-#columns ;
|
||||
|
||||
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||
[ handle>> ] [ sqlite-column ] bi* ;
|
||||
|
||||
M: sqlite-result-set row-column-typed ( result-set n -- obj )
|
||||
dup pick out-params>> nth type>>
|
||||
[ handle>> ] 2dip sqlite-column-typed ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- )
|
||||
dup handle>> sqlite-next >>has-more? drop ;
|
||||
|
||||
M: sqlite-result-set more-rows? ( result-set -- ? )
|
||||
has-more?>> ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
sqlite-maybe-prepare
|
||||
dup handle>> sqlite-result-set new-result-set
|
||||
dup advance-row ;
|
||||
|
||||
M: sqlite-db-connection <insert-db-assigned-statement> ( class -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
remove-db-assigned-id
|
||||
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
") values(" 0%
|
||||
[ ", " 0% ] [
|
||||
dup type>> +random-id+ = [
|
||||
[ slot-name>> ]
|
||||
[
|
||||
column-name>> ":" prepend dup 0%
|
||||
random-id-generator
|
||||
] [ type>> ] tri <generator-bind> 1,
|
||||
] [
|
||||
bind%
|
||||
] if
|
||||
] interleave
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection <insert-user-assigned-statement> ( class -- statement )
|
||||
<insert-db-assigned-statement> ;
|
||||
|
||||
M: sqlite-db-connection bind# ( spec obj -- )
|
||||
[
|
||||
[ column-name>> ":" next-sql-counter surround dup 0% ]
|
||||
[ type>> ] bi
|
||||
] dip <literal-bind> 1, ;
|
||||
|
||||
M: sqlite-db-connection bind% ( spec -- )
|
||||
dup 1, column-name>> ":" prepend 0% ;
|
||||
|
||||
M: sqlite-db-connection persistent-table ( -- assoc )
|
||||
H{
|
||||
{ +db-assigned-id+ { "integer" "integer" f } }
|
||||
{ +user-assigned-id+ { f f f } }
|
||||
{ +random-id+ { "integer" "integer" f } }
|
||||
{ +foreign-id+ { "integer" "integer" "references" } }
|
||||
|
||||
{ +on-update+ { f f "on update" } }
|
||||
{ +on-delete+ { f f "on delete" } }
|
||||
{ +restrict+ { f f "restrict" } }
|
||||
{ +cascade+ { f f "cascade" } }
|
||||
{ +set-null+ { f f "set null" } }
|
||||
{ +set-default+ { f f "set default" } }
|
||||
|
||||
{ BOOLEAN { "boolean" "boolean" f } }
|
||||
{ INTEGER { "integer" "integer" f } }
|
||||
{ BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
|
||||
{ TEXT { "text" "text" f } }
|
||||
{ VARCHAR { "text" "text" f } }
|
||||
{ DATE { "date" "date" f } }
|
||||
{ TIME { "time" "time" f } }
|
||||
{ DATETIME { "datetime" "datetime" f } }
|
||||
{ TIMESTAMP { "timestamp" "timestamp" f } }
|
||||
{ DOUBLE { "real" "real" f } }
|
||||
{ BLOB { "blob" "blob" f } }
|
||||
{ FACTOR-BLOB { "blob" "blob" f } }
|
||||
{ URL { "text" "text" f } }
|
||||
{ +autoincrement+ { f f "autoincrement" } }
|
||||
{ +unique+ { f f "unique" } }
|
||||
{ +default+ { f f "default" } }
|
||||
{ +null+ { f f "null" } }
|
||||
{ +not-null+ { f f "not null" } }
|
||||
{ system-random-generator { f f f } }
|
||||
{ secure-random-generator { f f f } }
|
||||
{ random-generator { f f f } }
|
||||
} ;
|
||||
|
||||
: insert-trigger ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: insert-trigger-not-null ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
|
||||
WHERE NEW.${table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: update-trigger ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: update-trigger-not-null ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
|
||||
WHERE NEW.${table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: delete-trigger-restrict ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'delete on table \"${foreign-table-name}\" violates foreign key constraint \"fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: delete-trigger-cascade ( -- string )
|
||||
"
|
||||
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
END;
|
||||
" interpolate>string ;
|
||||
|
||||
: can-be-null? ( -- ? )
|
||||
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
|
||||
|
||||
: delete-cascade? ( -- ? )
|
||||
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
|
||||
|
||||
: sqlite-trigger, ( string -- )
|
||||
{ } { } <simple-statement> 3, ;
|
||||
|
||||
: create-sqlite-triggers ( -- )
|
||||
can-be-null? [
|
||||
insert-trigger sqlite-trigger,
|
||||
update-trigger sqlite-trigger,
|
||||
] [
|
||||
insert-trigger-not-null sqlite-trigger,
|
||||
update-trigger-not-null sqlite-trigger,
|
||||
] if
|
||||
delete-cascade? [
|
||||
delete-trigger-cascade sqlite-trigger,
|
||||
] [
|
||||
delete-trigger-restrict sqlite-trigger,
|
||||
] if ;
|
||||
|
||||
: create-db-triggers ( sql-specs -- )
|
||||
[ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
|
||||
[
|
||||
[ class>> db-table-name "db-table" set ]
|
||||
[
|
||||
[ "sql-spec" set ]
|
||||
[ column-name>> "table-id" set ]
|
||||
[ ] tri
|
||||
modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
|
||||
[
|
||||
[ second db-table-name "foreign-table-name" set ]
|
||||
[ third "foreign-table-id" set ] bi
|
||||
create-sqlite-triggers
|
||||
] each
|
||||
] bi
|
||||
] each ;
|
||||
|
||||
: sqlite-create-table ( sql-specs class-name -- )
|
||||
[
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup "sql-spec" set
|
||||
dup column-name>> [ "table-id" set ] [ 0% ] bi
|
||||
" " 0%
|
||||
dup type>> lookup-create-type 0%
|
||||
modifiers 0%
|
||||
] interleave
|
||||
] [
|
||||
drop
|
||||
find-primary-key [
|
||||
", " 0%
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
")" 0%
|
||||
] unless-empty
|
||||
");" 0%
|
||||
] 2bi ;
|
||||
|
||||
M: sqlite-db-connection create-sql-statement ( class -- statement )
|
||||
[
|
||||
[ sqlite-create-table ]
|
||||
[ drop create-db-triggers ] 2bi
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection drop-sql-statement ( class -- statements )
|
||||
[ nip "drop table " 0% 0% ";" 0% ] query-make ;
|
||||
|
||||
M: sqlite-db-connection compound ( string seq -- new-string )
|
||||
over {
|
||||
{ "default" [ first number>string " " glue ] }
|
||||
{ "references" [ >reference-string ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
M: sqlite-db-connection parse-db-error
|
||||
dup n>> {
|
||||
{ 1 [ string>> parse-sqlite-sql-error ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
SQLite database connector
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
create table person (name varchar(30), country varchar(30));
|
||||
insert into person values('John', 'America');
|
||||
insert into person values('Jane', 'New Zealand');
|
||||
|
|
@ -1 +0,0 @@
|
|||
Relational database abstraction layer
|
||||
|
|
@ -1 +0,0 @@
|
|||
enterprise
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test db.tester ;
|
||||
IN: db.tester.tests
|
||||
|
||||
{ } [ sqlite-test-db db-tester ] unit-test
|
||||
{ } [ sqlite-test-db db-tester2 ] unit-test
|
||||
|
|
@ -1,103 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.combinators db db.pools db.sqlite db.tuples
|
||||
db.types destructors kernel math random threads tools.test sequences
|
||||
io io.pools prettyprint db.postgresql accessors io.files.temp
|
||||
namespaces fry system math.parser db.queries assocs ;
|
||||
IN: db.tester
|
||||
|
||||
: postgresql-test-db-name ( -- string )
|
||||
cpu name>> "-" "factor-test" 3append
|
||||
H{ { CHAR: - CHAR: _ } { CHAR: . CHAR: _ } } substitute ;
|
||||
|
||||
: postgresql-test-db ( -- postgresql-db )
|
||||
\ postgresql-db get-global clone postgresql-test-db-name >>database ;
|
||||
|
||||
: postgresql-template1-db ( -- postgresql-db )
|
||||
\ postgresql-db get-global clone "template1" >>database ;
|
||||
|
||||
: sqlite-test-db ( -- sqlite-db )
|
||||
cpu name>> "tuples-test." ".db" surround
|
||||
temp-file <sqlite-db> ;
|
||||
|
||||
! These words leak resources, but are useful for interactive testing
|
||||
: set-sqlite-db ( -- )
|
||||
sqlite-db db-open db-connection set ;
|
||||
|
||||
: set-postgresql-db ( -- )
|
||||
postgresql-db db-open db-connection set ;
|
||||
|
||||
|
||||
: test-sqlite ( quot -- )
|
||||
'[
|
||||
[ ] [ sqlite-test-db _ with-db ] unit-test
|
||||
] call ; inline
|
||||
|
||||
: test-postgresql ( quot -- )
|
||||
|
||||
'[
|
||||
os windows? cpu x86.64? and [
|
||||
postgresql-template1-db [
|
||||
postgresql-test-db-name ensure-database
|
||||
] with-db
|
||||
[ ] [ postgresql-test-db _ with-db ] unit-test
|
||||
] unless
|
||||
] call ; inline
|
||||
|
||||
|
||||
TUPLE: test-1 id a b c ;
|
||||
|
||||
test-1 "TEST1" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "a" "A" { VARCHAR 256 } +not-null+ }
|
||||
{ "b" "B" { VARCHAR 256 } +not-null+ }
|
||||
{ "c" "C" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: test-2 id x y z ;
|
||||
|
||||
test-2 "TEST2" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "x" "X" { VARCHAR 256 } +not-null+ }
|
||||
{ "y" "Y" { VARCHAR 256 } +not-null+ }
|
||||
{ "z" "Z" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: test-1-tuple ( -- tuple )
|
||||
f 100 random 100 random 100 random [ number>string ] tri@
|
||||
test-1 boa ;
|
||||
|
||||
: db-tester ( test-db -- )
|
||||
[
|
||||
[
|
||||
test-1 ensure-table
|
||||
test-2 ensure-table
|
||||
] with-db
|
||||
] [
|
||||
10 iota [
|
||||
drop
|
||||
10 [
|
||||
dup [
|
||||
test-1-tuple insert-tuple yield
|
||||
] with-db
|
||||
] times
|
||||
] with parallel-each
|
||||
] bi ;
|
||||
|
||||
: db-tester2 ( test-db -- )
|
||||
[
|
||||
[
|
||||
test-1 ensure-table
|
||||
test-2 ensure-table
|
||||
] with-db
|
||||
] [
|
||||
<db-pool> [
|
||||
[
|
||||
10 iota [
|
||||
10 [
|
||||
test-1-tuple insert-tuple yield
|
||||
] times
|
||||
] parallel-each
|
||||
] with-pooled-db
|
||||
] with-disposal
|
||||
] bi ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
O/R mapper
|
||||
|
|
@ -1,272 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes help.markup help.syntax io.streams.string kernel
|
||||
quotations sequences strings math db.types db.tuples.private db ;
|
||||
IN: db.tuples
|
||||
|
||||
HELP: random-id-generator
|
||||
{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
|
||||
|
||||
HELP: create-sql-statement
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "Generates the SQL code for creating a table for a given class." } ;
|
||||
|
||||
HELP: drop-sql-statement
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "Generates the SQL code for dropping a table for a given class." } ;
|
||||
|
||||
HELP: insert-tuple-set-key
|
||||
{ $values
|
||||
{ "tuple" tuple } { "statement" statement } }
|
||||
{ $description "Inserts a tuple and sets its primary key in one word. This is necessary for some databases." } ;
|
||||
|
||||
HELP: <count-statement>
|
||||
{ $values
|
||||
{ "query" query }
|
||||
{ "statement" statement } }
|
||||
{ $description "A database-specific hook for generating the SQL for a count statement." } ;
|
||||
|
||||
HELP: <delete-tuples-statement>
|
||||
{ $values
|
||||
{ "tuple" tuple } { "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "A database-specific hook for generating the SQL for an delete statement." } ;
|
||||
|
||||
HELP: <insert-db-assigned-statement>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "A database-specific hook for generating the SQL for an insert statement with a database-assigned primary key." } ;
|
||||
|
||||
HELP: <insert-user-assigned-statement>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "A database-specific hook for generating the SQL for an insert statement with a user-assigned primary key." } ;
|
||||
|
||||
HELP: <select-by-slots-statement>
|
||||
{ $values
|
||||
{ "tuple" tuple } { "class" class }
|
||||
{ "statement" tuple } }
|
||||
{ $description "A database-specific hook for generating the SQL for a select statement." } ;
|
||||
|
||||
HELP: <update-tuple-statement>
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "object" object } }
|
||||
{ $description "A database-specific hook for generating the SQL for an update statement." } ;
|
||||
|
||||
|
||||
HELP: define-persistent
|
||||
{ $values
|
||||
{ "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
|
||||
{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to a SQL database table name. The format for the slot specifiers is as follows:"
|
||||
{ $list
|
||||
{ "a slot name from the " { $snippet "tuple class" } }
|
||||
{ "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" }
|
||||
} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
|
||||
{ $examples
|
||||
{ $code "USING: db.tuples db.types ;"
|
||||
"TUPLE: boat id year name ;"
|
||||
"boat \"BOAT\" {"
|
||||
" { \"id\" \"ID\" +db-assigned-id+ }"
|
||||
" { \"year\" \"YEAR\" INTEGER }"
|
||||
" { \"name\" \"NAME\" TEXT }"
|
||||
"} define-persistent"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: create-table
|
||||
{ $values
|
||||
{ "class" class } }
|
||||
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
|
||||
|
||||
HELP: ensure-table
|
||||
{ $values
|
||||
{ "class" class } }
|
||||
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
|
||||
|
||||
HELP: ensure-tables
|
||||
{ $values
|
||||
{ "classes" "a sequence of classes" } }
|
||||
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
|
||||
|
||||
HELP: recreate-table
|
||||
{ $values
|
||||
{ "class" class } }
|
||||
{ $description "Drops an existing table and re-creates it from a mapping defined by " { $link define-persistent } ". If the table does not exist the error is silently ignored." }
|
||||
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } $nl
|
||||
" Use " { $link ensure-table } " unless you want to delete the data in this table." } ;
|
||||
|
||||
{ create-table ensure-table ensure-tables recreate-table } related-words
|
||||
|
||||
HELP: drop-table
|
||||
{ $values
|
||||
{ "class" class } }
|
||||
{ $description "Drops an existing table which deletes all of the data. The database will probably throw an error if the table does not exist." }
|
||||
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } } ;
|
||||
|
||||
HELP: insert-tuple
|
||||
{ $values
|
||||
{ "tuple" tuple } }
|
||||
{ $description "Inserts a tuple into a database if a relation has been defined with " { $link define-persistent } ". If a mapping states that the database assigns a primary key to the tuple, this value will be set after this word runs." }
|
||||
{ $notes "Objects should only be inserted into a database once per object. To store the object after the initial insert, call " { $link update-tuple } "." } ;
|
||||
|
||||
HELP: update-tuple
|
||||
{ $values
|
||||
{ "tuple" tuple } }
|
||||
{ $description "Updates a tuple that has already been inserted into a database. The tuple must have a primary key that has been set by " { $link insert-tuple } " or that is user-defined." } ;
|
||||
|
||||
HELP: delete-tuples
|
||||
{ $values
|
||||
{ "tuple" tuple } }
|
||||
{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate a SQL statement that deletes tuples." }
|
||||
{ $warning "This word will delete your data." } ;
|
||||
|
||||
{ insert-tuple update-tuple delete-tuples } related-words
|
||||
|
||||
HELP: select-tuple
|
||||
{ $values
|
||||
{ "query/tuple" tuple }
|
||||
{ "tuple/f" { $maybe tuple } } }
|
||||
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
|
||||
|
||||
HELP: select-tuples
|
||||
{ $values
|
||||
{ "query/tuple" tuple }
|
||||
{ "tuples" "an array of tuples" } }
|
||||
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns an array of multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
|
||||
|
||||
HELP: count-tuples
|
||||
{ $values
|
||||
{ "query/tuple" tuple }
|
||||
{ "n" integer } }
|
||||
{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
|
||||
|
||||
{ select-tuple select-tuples count-tuples } related-words
|
||||
|
||||
|
||||
|
||||
ARTICLE: "db-tuples" "High-level tuple/database integration"
|
||||
"Start with a tutorial:"
|
||||
{ $subsections "db-tuples-tutorial" }
|
||||
"Database types supported:"
|
||||
{ $subsections "db.types" }
|
||||
"Useful words:"
|
||||
{ $subsections "db-tuples-words" }
|
||||
"For porting " { $vocab-link "db.tuples" } " to other databases:"
|
||||
{ $subsections "db-tuples-protocol" }
|
||||
;
|
||||
|
||||
ARTICLE: "db-tuples-words" "High-level tuple/database words"
|
||||
"Making tuples work with a database:"
|
||||
{ $subsections define-persistent }
|
||||
"Creating tables:"
|
||||
{ $subsections
|
||||
create-table
|
||||
ensure-table
|
||||
ensure-tables
|
||||
recreate-table
|
||||
}
|
||||
"Dropping tables:"
|
||||
{ $subsections drop-table }
|
||||
"Inserting a tuple:"
|
||||
{ $subsections insert-tuple }
|
||||
"Updating a tuple:"
|
||||
{ $subsections update-tuple }
|
||||
"Deleting tuples:"
|
||||
{ $subsections delete-tuples }
|
||||
"Querying tuples:"
|
||||
{ $subsections
|
||||
select-tuple
|
||||
select-tuples
|
||||
count-tuples
|
||||
} ;
|
||||
|
||||
ARTICLE: "db-tuples-protocol" "Tuple database protocol"
|
||||
"Creating a table:"
|
||||
{ $subsections create-sql-statement }
|
||||
"Dropping a table:"
|
||||
{ $subsections drop-sql-statement }
|
||||
"Inserting a tuple:"
|
||||
{ $subsections
|
||||
<insert-db-assigned-statement>
|
||||
<insert-user-assigned-statement>
|
||||
}
|
||||
"Updating a tuple:"
|
||||
{ $subsections <update-tuple-statement> }
|
||||
"Deleting tuples:"
|
||||
{ $subsections <delete-tuples-statement> }
|
||||
"Selecting tuples:"
|
||||
{ $subsections <select-by-slots-statement> }
|
||||
"Counting tuples:"
|
||||
{ $subsections <count-statement> } ;
|
||||
|
||||
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
|
||||
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
|
||||
"We're going to store books in this tutorial."
|
||||
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
|
||||
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
|
||||
"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
|
||||
{ $code
|
||||
"USING: db.tuples db.types ;
|
||||
book \"BOOK\"
|
||||
{
|
||||
{ \"id\" \"ID\" +db-assigned-id+ }
|
||||
{ \"title\" \"TITLE\" VARCHAR }
|
||||
{ \"author\" \"AUTHOR\" VARCHAR }
|
||||
{ \"date-published\" \"DATE_PUBLISHED\" TIMESTAMP }
|
||||
{ \"edition\" \"EDITION\" INTEGER }
|
||||
{ \"cover-price\" \"COVER_PRICE\" DOUBLE }
|
||||
{ \"condition\" \"CONDITION\" VARCHAR }
|
||||
} define-persistent" }
|
||||
"That's all we'll have to do with the database for this tutorial. Now let's make a book."
|
||||
{ $code "USING: calendar namespaces ;
|
||||
T{ book
|
||||
{ title \"Factor for Sheeple\" }
|
||||
{ author \"Mister Stacky Pants\" }
|
||||
{ date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } }
|
||||
{ edition 1 }
|
||||
{ cover-price 13.37 }
|
||||
} book set" }
|
||||
"Now we've created a book. Let's save it to the database."
|
||||
{ $code "USING: db db.sqlite fry io.files.temp ;
|
||||
: with-book-tutorial ( quot -- )
|
||||
'[ \"book-tutorial.db\" temp-file <sqlite-db> _ with-db ] call ; inline
|
||||
|
||||
[
|
||||
book recreate-table
|
||||
book get insert-tuple
|
||||
] with-book-tutorial" }
|
||||
"Is it really there?"
|
||||
{ $code "[
|
||||
T{ book { title \"Factor for Sheeple\" } } select-tuples .
|
||||
] with-book-tutorial" }
|
||||
"Oops, we spilled some orange juice on the book cover."
|
||||
{ $code "book get \"Small orange juice stain on cover\" >>condition" }
|
||||
"Now let's save the modified book."
|
||||
{ $code "[
|
||||
book get update-tuple
|
||||
] with-book-tutorial" }
|
||||
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
|
||||
{ $code "[
|
||||
T{ book { title \"Factor for Sheeple\" } } select-tuples
|
||||
] with-book-tutorial" }
|
||||
"Let's drop the table because we're done."
|
||||
{ $code "[
|
||||
book drop-table
|
||||
] with-book-tutorial" }
|
||||
"To summarize, the steps for using Factor's tuple database are:"
|
||||
{ $list
|
||||
"Make a new tuple to represent your data"
|
||||
{ "Map the Factor types to the database types with " { $link define-persistent } }
|
||||
{ "Make a custom database combinator (see " { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
|
||||
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
|
||||
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
|
||||
} ;
|
||||
|
||||
ABOUT: "db-tuples"
|
||||
|
|
@ -1,645 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.files.temp kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitwise system
|
||||
math.ranges strings urls fry db.tuples.private db.private
|
||||
db.tester ;
|
||||
FROM: math.ranges => [a,b] ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
ts date time blob factor-blob url ;
|
||||
|
||||
: <person> ( name age real ts date time blob factor-blob url -- person )
|
||||
person new
|
||||
swap >>url
|
||||
swap >>factor-blob
|
||||
swap >>blob
|
||||
swap >>time
|
||||
swap >>date
|
||||
swap >>ts
|
||||
swap >>the-real
|
||||
swap >>the-number
|
||||
swap >>the-name ;
|
||||
|
||||
: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
|
||||
<person>
|
||||
swap >>the-id ;
|
||||
|
||||
SYMBOL: person1
|
||||
SYMBOL: person2
|
||||
SYMBOL: person3
|
||||
SYMBOL: person4
|
||||
|
||||
: test-tuples ( -- )
|
||||
[ ] [ person recreate-table ] unit-test
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person drop-table ] unit-test
|
||||
[ ] [ person create-table ] unit-test
|
||||
[ person create-table ] must-fail
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
|
||||
[ 1 ] [ person1 get the-id>> ] unit-test
|
||||
|
||||
[ ] [ person1 get 200 >>the-number drop ] unit-test
|
||||
|
||||
[ ] [ person1 get update-tuple ] unit-test
|
||||
|
||||
[ T{ person f 1 "billy" 200 3.14 } ]
|
||||
[ T{ person f 1 } select-tuple ] unit-test
|
||||
[ ] [ person2 get insert-tuple ] unit-test
|
||||
[
|
||||
{
|
||||
T{ person f 1 "billy" 200 3.14 }
|
||||
T{ person f 2 "johnny" 10 3.14 }
|
||||
}
|
||||
] [ T{ person f f f f 3.14 } select-tuples ] unit-test
|
||||
[
|
||||
{
|
||||
T{ person f 1 "billy" 200 3.14 }
|
||||
T{ person f 2 "johnny" 10 3.14 }
|
||||
}
|
||||
] [ T{ person f } select-tuples ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ person f 2 "johnny" 10 3.14 }
|
||||
}
|
||||
] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
|
||||
|
||||
|
||||
[ ] [ person1 get delete-tuples ] unit-test
|
||||
[ f ] [ T{ person f 1 } select-tuple ] unit-test
|
||||
|
||||
[ ] [ person3 get insert-tuple ] unit-test
|
||||
|
||||
[
|
||||
T{
|
||||
person
|
||||
f
|
||||
3
|
||||
"teddy"
|
||||
10
|
||||
3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
|
||||
}
|
||||
] [ T{ person f 3 } select-tuple ] unit-test
|
||||
|
||||
[ ] [ person4 get insert-tuple ] unit-test
|
||||
[
|
||||
T{
|
||||
person
|
||||
f
|
||||
4
|
||||
"eddie"
|
||||
10
|
||||
3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f
|
||||
H{ { 1 2 } { 3 4 } { 5 "lol" } }
|
||||
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
|
||||
}
|
||||
] [ T{ person f 4 } select-tuple ] unit-test
|
||||
|
||||
[ ] [ person drop-table ] unit-test ;
|
||||
|
||||
: db-assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" +db-assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
{ "ts" "TS" TIMESTAMP }
|
||||
{ "date" "D" DATE }
|
||||
{ "time" "T" TIME }
|
||||
{ "blob" "B" BLOB }
|
||||
{ "factor-blob" "FB" FACTOR-BLOB }
|
||||
{ "url" "U" URL }
|
||||
} define-persistent
|
||||
"billy" 10 3.14 f f f f f f <person> person1 set
|
||||
"johnny" 10 3.14 f f f f f f <person> person2 set
|
||||
"teddy" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
|
||||
"eddie" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
|
||||
|
||||
: user-assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" INTEGER +user-assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
{ "ts" "TS" TIMESTAMP }
|
||||
{ "date" "D" DATE }
|
||||
{ "time" "T" TIME }
|
||||
{ "blob" "B" BLOB }
|
||||
{ "factor-blob" "FB" FACTOR-BLOB }
|
||||
{ "url" "U" URL }
|
||||
} define-persistent
|
||||
1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
|
||||
2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
|
||||
3 "teddy" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
|
||||
f f <user-assigned-person> person3 set
|
||||
4 "eddie" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
|
||||
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "timestamp" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
|
||||
: annotation-schema-foreign-key ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-foreign-key-not-null ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-cascade ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
|
||||
+on-delete+ +cascade+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-restrict ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: test-paste-schema ( -- )
|
||||
[ ] [ paste ensure-table ] unit-test
|
||||
[ ] [ annotation ensure-table ] unit-test
|
||||
[ ] [ annotation drop-table ] unit-test
|
||||
[ ] [ paste drop-table ] unit-test
|
||||
[ ] [ paste create-table ] unit-test
|
||||
[ ] [ annotation create-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
paste new
|
||||
"summary1" >>summary
|
||||
"erg" >>author
|
||||
"#lol" >>channel
|
||||
"contents1" >>contents
|
||||
now >>timestamp
|
||||
insert-tuple
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
annotation new
|
||||
1 >>paste-id
|
||||
"annotation1" >>summary
|
||||
"erg" >>author
|
||||
"annotation contents" >>contents
|
||||
insert-tuple
|
||||
] unit-test ;
|
||||
|
||||
: test-foreign-key ( -- )
|
||||
[ ] [ annotation-schema-foreign-key ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
: test-foreign-key-not-null ( -- )
|
||||
[ ] [ annotation-schema-foreign-key-not-null ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
: test-cascade ( -- )
|
||||
[ ] [ annotation-schema-cascade ] unit-test
|
||||
test-paste-schema
|
||||
[ ] [ paste new 1 >>n delete-tuples ] unit-test
|
||||
[ 0 ] [ paste new select-tuples length ] unit-test ;
|
||||
|
||||
: test-restrict ( -- )
|
||||
[ ] [ annotation-schema-restrict ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
[ test-foreign-key ] test-sqlite
|
||||
[ test-foreign-key-not-null ] test-sqlite
|
||||
[ test-cascade ] test-sqlite
|
||||
[ test-restrict ] test-sqlite
|
||||
|
||||
[ test-foreign-key ] test-postgresql
|
||||
[ test-foreign-key-not-null ] test-postgresql
|
||||
[ test-cascade ] test-postgresql
|
||||
[ test-restrict ] test-postgresql
|
||||
|
||||
: test-repeated-insert ( -- )
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
[ person1 get insert-tuple ] must-fail ;
|
||||
|
||||
TUPLE: serialize-me id data ;
|
||||
|
||||
: test-serialize ( -- )
|
||||
serialize-me "SERIALIZED"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "data" "DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
[ serialize-me drop-table ] [ drop ] recover
|
||||
[ ] [ serialize-me create-table ] unit-test
|
||||
|
||||
[ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
|
||||
[
|
||||
{ T{ serialize-me f 1 H{ { 1 2 } } } }
|
||||
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
|
||||
|
||||
TUPLE: exam id name score ;
|
||||
|
||||
: random-exam ( -- exam )
|
||||
f
|
||||
6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
|
||||
100 random
|
||||
exam boa ;
|
||||
|
||||
: test-intervals ( -- )
|
||||
[
|
||||
exam "EXAM"
|
||||
{
|
||||
{ "idd" "ID" +db-assigned-id+ }
|
||||
{ "named" "NAME" TEXT }
|
||||
{ "score" "SCORE" INTEGER }
|
||||
} define-persistent
|
||||
] [
|
||||
seq>> { "idd" "named" } =
|
||||
] must-fail-with
|
||||
|
||||
exam "EXAM"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "score" "SCORE" INTEGER }
|
||||
} define-persistent
|
||||
[ exam drop-table ] [ drop ] recover
|
||||
[ ] [ exam create-table ] unit-test
|
||||
|
||||
[ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
|
||||
[ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
|
||||
[ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
|
||||
[ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
|
||||
|
||||
[ 4 ]
|
||||
[ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
|
||||
|
||||
[ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ }
|
||||
] [
|
||||
T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
|
||||
] unit-test
|
||||
[
|
||||
{
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
|
||||
] unit-test
|
||||
[
|
||||
{
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
|
||||
] unit-test
|
||||
[
|
||||
{
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
}
|
||||
] [
|
||||
T{ exam f f { "Stan" "Kyle" } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ range f 1 3 1 } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam } select-tuples
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ T{ exam } count-tuples ] unit-test
|
||||
|
||||
[ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
|
||||
|
||||
[ 10 ]
|
||||
[ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
|
||||
|
||||
TUPLE: bignum-test id m n o ;
|
||||
: <bignum-test> ( m n o -- obj )
|
||||
bignum-test new
|
||||
swap >>o
|
||||
swap >>n
|
||||
swap >>m ;
|
||||
|
||||
: test-bignum ( -- )
|
||||
bignum-test "BIGNUM_TEST"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "m" "M" BIG-INTEGER }
|
||||
{ "n" "N" UNSIGNED-BIG-INTEGER }
|
||||
{ "o" "O" SIGNED-BIG-INTEGER }
|
||||
} define-persistent
|
||||
[ bignum-test drop-table ] ignore-errors
|
||||
[ ] [ bignum-test ensure-table ] unit-test
|
||||
[ ] [ 63 2^ 1 - dup dup <bignum-test> insert-tuple ] unit-test ;
|
||||
|
||||
! sqlite only
|
||||
! [ T{ bignum-test f 1
|
||||
! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
|
||||
! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
|
||||
|
||||
TUPLE: secret n message ;
|
||||
C: <secret> secret
|
||||
|
||||
: test-random-id ( -- )
|
||||
secret "SECRET"
|
||||
{
|
||||
{ "n" "ID" +random-id+ system-random-generator }
|
||||
{ "message" "MESSAGE" TEXT }
|
||||
} define-persistent
|
||||
|
||||
[ ] [ secret recreate-table ] unit-test
|
||||
|
||||
[ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ secret } select-tuples
|
||||
first message>> "kilroy was here" head?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ secret } select-tuples length 3 =
|
||||
] unit-test ;
|
||||
|
||||
[ db-assigned-person-schema test-tuples ] test-sqlite
|
||||
[ user-assigned-person-schema test-tuples ] test-sqlite
|
||||
[ user-assigned-person-schema test-repeated-insert ] test-sqlite
|
||||
[ test-bignum ] test-sqlite
|
||||
[ test-serialize ] test-sqlite
|
||||
[ test-intervals ] test-sqlite
|
||||
[ test-random-id ] test-sqlite
|
||||
|
||||
[ db-assigned-person-schema test-tuples ] test-postgresql
|
||||
[ user-assigned-person-schema test-tuples ] test-postgresql
|
||||
[ user-assigned-person-schema test-repeated-insert ] test-postgresql
|
||||
[ test-bignum ] test-postgresql
|
||||
[ test-serialize ] test-postgresql
|
||||
[ test-intervals ] test-postgresql
|
||||
[ test-random-id ] test-postgresql
|
||||
|
||||
TUPLE: does-not-persist ;
|
||||
|
||||
[
|
||||
[ does-not-persist create-sql-statement ]
|
||||
[ class-of \ not-persistent = ] must-fail-with
|
||||
] test-sqlite
|
||||
|
||||
[
|
||||
[ does-not-persist create-sql-statement ]
|
||||
[ class-of \ not-persistent = ] must-fail-with
|
||||
] test-postgresql
|
||||
|
||||
|
||||
TUPLE: suparclass id a ;
|
||||
|
||||
suparclass f {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "a" "A" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: subbclass < suparclass b ;
|
||||
|
||||
subbclass "SUBCLASS" {
|
||||
{ "b" "B" TEXT }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: fubbclass < subbclass ;
|
||||
|
||||
fubbclass "FUBCLASS" { } define-persistent
|
||||
|
||||
: test-db-inheritance ( -- )
|
||||
[ ] [ subbclass ensure-table ] unit-test
|
||||
[ ] [ fubbclass ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
|
||||
] unit-test
|
||||
|
||||
[ t "hi" 5 ] [
|
||||
subbclass new "id" get >>id select-tuple
|
||||
[ subbclass? ] [ b>> ] [ a>> ] tri
|
||||
] unit-test
|
||||
|
||||
[ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
|
||||
|
||||
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
|
||||
|
||||
[ test-db-inheritance ] test-sqlite
|
||||
[ test-db-inheritance ] test-postgresql
|
||||
|
||||
|
||||
TUPLE: string-encoding-test id string ;
|
||||
|
||||
string-encoding-test "STRING_ENCODING_TEST" {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "string" "STRING" TEXT }
|
||||
} define-persistent
|
||||
|
||||
: test-string-encoding ( -- )
|
||||
[ ] [ string-encoding-test ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
string-encoding-test new
|
||||
"\u{copyright-sign}\u{bengali-letter-cha}" >>string
|
||||
[ insert-tuple ] [ id>> "id" set ] bi
|
||||
] unit-test
|
||||
|
||||
[ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
|
||||
string-encoding-test new "id" get >>id select-tuple string>>
|
||||
] unit-test ;
|
||||
|
||||
[ test-string-encoding ] test-sqlite
|
||||
[ test-string-encoding ] test-postgresql
|
||||
|
||||
: test-queries ( -- )
|
||||
[ ] [ exam ensure-table ] unit-test
|
||||
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
|
||||
[ 5 ] [
|
||||
<query>
|
||||
T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
|
||||
>>tuple
|
||||
5 >>limit select-tuples length
|
||||
] unit-test ;
|
||||
|
||||
TUPLE: compound-foo a b c ;
|
||||
|
||||
compound-foo "COMPOUND_FOO"
|
||||
{
|
||||
{ "a" "A" INTEGER +user-assigned-id+ }
|
||||
{ "b" "B" INTEGER +user-assigned-id+ }
|
||||
{ "c" "C" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
: test-compound-primary-key ( -- )
|
||||
[ ] [ compound-foo ensure-table ] unit-test
|
||||
[ ] [ compound-foo drop-table ] unit-test
|
||||
[ ] [ compound-foo create-table ] unit-test
|
||||
[ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
|
||||
[ 1 2 3 compound-foo boa insert-tuple ] must-fail
|
||||
[ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
|
||||
[ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
|
||||
[ compound-foo new 4 >>c select-tuple ] unit-test ;
|
||||
|
||||
[ test-compound-primary-key ] test-sqlite
|
||||
[ test-compound-primary-key ] test-postgresql
|
||||
|
||||
|
||||
TUPLE: example id data ;
|
||||
|
||||
example "EXAMPLE"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "data" "DATA" BLOB }
|
||||
} define-persistent
|
||||
|
||||
: test-blob-select ( -- )
|
||||
example ensure-table
|
||||
[ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
|
||||
[
|
||||
T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
|
||||
] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
|
||||
|
||||
[ test-blob-select ] test-sqlite
|
||||
[ test-blob-select ] test-postgresql
|
||||
|
|
@ -1,159 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint continuations
|
||||
destructors mirrors sets db.types db.private fry
|
||||
combinators.short-circuit db.errors ;
|
||||
IN: db.tuples
|
||||
|
||||
HOOK: create-sql-statement db-connection ( class -- object )
|
||||
HOOK: drop-sql-statement db-connection ( class -- object )
|
||||
|
||||
HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
|
||||
HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
|
||||
HOOK: <update-tuple-statement> db-connection ( class -- object )
|
||||
HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
|
||||
HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
|
||||
HOOK: <count-statement> db-connection ( query -- statement )
|
||||
HOOK: query>statement db-connection ( query -- statement )
|
||||
HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: sql-counter
|
||||
|
||||
: next-sql-counter ( -- str )
|
||||
sql-counter [ inc ] [ get ] bi number>string ;
|
||||
|
||||
GENERIC: eval-generator ( singleton -- object )
|
||||
|
||||
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
|
||||
rot class-of new [
|
||||
'[ slot-name>> _ set-slot-named ] 2each
|
||||
] keep ;
|
||||
|
||||
: query-tuples ( exemplar-tuple statement -- seq )
|
||||
[ out-params>> ] keep query-results [
|
||||
[ sql-row-typed swap resulting-tuple ] 2with query-map
|
||||
] with-disposal ;
|
||||
|
||||
: query-modify-tuple ( tuple statement -- )
|
||||
[ query-results [ sql-row-typed ] with-disposal ] keep
|
||||
out-params>> rot [
|
||||
[ slot-name>> ] dip set-slot-named
|
||||
] curry 2each ;
|
||||
|
||||
: with-disposals ( object quotation -- )
|
||||
over sequence? [
|
||||
[ with-disposal ] curry each
|
||||
] [
|
||||
with-disposal
|
||||
] if ; inline
|
||||
|
||||
: insert-db-assigned-statement ( tuple -- )
|
||||
dup class-of
|
||||
db-connection get insert-statements>>
|
||||
[ <insert-db-assigned-statement> ] cache
|
||||
[ bind-tuple ] 2keep insert-tuple-set-key ;
|
||||
|
||||
: insert-user-assigned-statement ( tuple -- )
|
||||
dup class-of
|
||||
db-connection get insert-statements>>
|
||||
[ <insert-user-assigned-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: do-select ( exemplar-tuple statement -- tuples )
|
||||
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
|
||||
|
||||
: do-count ( exemplar-tuple statement -- tuples )
|
||||
[ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! High level
|
||||
ERROR: no-slots-named class seq ;
|
||||
: check-columns ( class columns -- )
|
||||
[ nip ] [
|
||||
[ keys ]
|
||||
[ all-slots [ name>> ] map ] bi* diff
|
||||
] 2bi
|
||||
[ drop ] [ no-slots-named ] if-empty ;
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
pick dupd
|
||||
check-columns
|
||||
[ dupd "db-table" set-word-prop dup ] dip
|
||||
[ relation? ] partition swapd
|
||||
dupd [ spec>tuple ] with map
|
||||
"db-columns" set-word-prop
|
||||
"db-relations" set-word-prop ;
|
||||
|
||||
TUPLE: query tuple group order offset limit ;
|
||||
|
||||
: <query> ( -- query ) \ query new ;
|
||||
|
||||
GENERIC: >query ( object -- query )
|
||||
|
||||
M: query >query clone ;
|
||||
|
||||
M: tuple >query <query> swap >>tuple ;
|
||||
|
||||
ERROR: no-defined-persistent object ;
|
||||
|
||||
: ensure-defined-persistent ( object -- object )
|
||||
dup { [ class? ] [ "db-table" word-prop ] } 1&& [
|
||||
no-defined-persistent
|
||||
] unless ;
|
||||
|
||||
: create-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
create-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: drop-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: recreate-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
[
|
||||
'[
|
||||
[
|
||||
_ drop-sql-statement [ execute-statement ] with-disposals
|
||||
] ignore-table-missing
|
||||
] ignore-function-missing
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
'[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
|
||||
|
||||
: ensure-tables ( classes -- ) [ ensure-table ] each ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
dup class-of ensure-defined-persistent db-assigned?
|
||||
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
dup class-of ensure-defined-persistent
|
||||
db-connection get update-statements>> [ <update-tuple-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: delete-tuples ( tuple -- )
|
||||
dup
|
||||
dup class-of ensure-defined-persistent
|
||||
<delete-tuples-statement> [
|
||||
[ bind-tuple ] keep execute-statement
|
||||
] with-disposal ;
|
||||
|
||||
: select-tuples ( query/tuple -- tuples )
|
||||
>query [ tuple>> ] [ query>statement ] bi do-select ;
|
||||
|
||||
: select-tuple ( query/tuple -- tuple/f )
|
||||
>query 1 >>limit [ tuple>> ] [ query>statement ] bi
|
||||
do-select ?first ;
|
||||
|
||||
: count-tuples ( query/tuple -- n )
|
||||
>query [ tuple>> ] [ <count-statement> ] bi do-count
|
||||
dup length 1 =
|
||||
[ first first string>number ] [ [ first string>number ] map ] if ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
SQL data type support
|
||||
|
|
@ -1,185 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel strings ;
|
||||
IN: db.types
|
||||
|
||||
HELP: +db-assigned-id+
|
||||
{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
|
||||
|
||||
HELP: +default+
|
||||
{ $description "Allows a default value for a column to be provided." } ;
|
||||
|
||||
HELP: +not-null+
|
||||
{ $description "Ensures that a column is not null." } ;
|
||||
|
||||
HELP: +null+
|
||||
{ $description "Allows a column to be null." } ;
|
||||
|
||||
HELP: +primary-key+
|
||||
{ $description "Makes a column a primary key. Only one column may be a primary key." } ;
|
||||
|
||||
HELP: +random-id+
|
||||
{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
|
||||
|
||||
HELP: +user-assigned-id+
|
||||
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
|
||||
|
||||
HELP: <generator-bind>
|
||||
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
|
||||
{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
|
||||
|
||||
HELP: <literal-bind>
|
||||
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
|
||||
{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
|
||||
|
||||
HELP: BIG-INTEGER
|
||||
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
|
||||
|
||||
HELP: BLOB
|
||||
{ $description "A byte array." } ;
|
||||
|
||||
HELP: BOOLEAN
|
||||
{ $description "Either true or false." } ;
|
||||
|
||||
HELP: DATE
|
||||
{ $description "A date without a time component." } ;
|
||||
|
||||
HELP: DATETIME
|
||||
{ $description "A date and a time." } ;
|
||||
|
||||
HELP: DOUBLE
|
||||
{ $description "Corresponds to Factor's 64-bit floating-point numbers." } ;
|
||||
|
||||
HELP: FACTOR-BLOB
|
||||
{ $description "A serialized Factor object." } ;
|
||||
|
||||
HELP: INTEGER
|
||||
{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ;
|
||||
|
||||
HELP: NULL
|
||||
{ $description "The SQL null type." } ;
|
||||
|
||||
HELP: REAL
|
||||
{ $description "A real number of unlimited precision. May not be supported on all databases." } ;
|
||||
|
||||
HELP: SIGNED-BIG-INTEGER
|
||||
{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
|
||||
|
||||
HELP: TEXT
|
||||
{ $description "Stores a string that is longer than a " { $link VARCHAR } ". SQLite uses this type for strings; it does not handle " { $link VARCHAR } " strings." } ;
|
||||
|
||||
HELP: TIME
|
||||
{ $description "A timestamp without a date component." } ;
|
||||
|
||||
HELP: TIMESTAMP
|
||||
{ $description "A Factor timestamp." } ;
|
||||
|
||||
HELP: UNSIGNED-BIG-INTEGER
|
||||
{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
|
||||
|
||||
{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
|
||||
|
||||
HELP: URL
|
||||
{ $description "A Factor " { $link "urls" } " object." } ;
|
||||
|
||||
HELP: VARCHAR
|
||||
{ $description "The SQL varchar type. This type can take an integer as an argument." }
|
||||
{ $examples { $unchecked-example "{ VARCHAR 256 }" "" } } ;
|
||||
|
||||
HELP: user-assigned-id-spec?
|
||||
{ $values
|
||||
{ "specs" "a sequence of SQL specs" }
|
||||
{ "?" boolean } }
|
||||
{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
|
||||
|
||||
HELP: bind#
|
||||
{ $values
|
||||
{ "spec" "a SQL spec" } { "obj" object } }
|
||||
{ $description "A generic word that lets a database construct a literal binding." } ;
|
||||
|
||||
HELP: bind%
|
||||
{ $values
|
||||
{ "spec" "a SQL spec" } }
|
||||
{ $description "A generic word that lets a database output a binding." } ;
|
||||
|
||||
HELP: db-assigned-id-spec?
|
||||
{ $values
|
||||
{ "specs" "a sequence of SQL specs" }
|
||||
{ "?" boolean } }
|
||||
{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
|
||||
|
||||
HELP: find-primary-key
|
||||
{ $values
|
||||
{ "specs" "a sequence of SQL specs" }
|
||||
{ "seq" "a sequence of SQL specs" } }
|
||||
{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
|
||||
{ $notes "This is a low-level word." } ;
|
||||
|
||||
HELP: no-sql-type
|
||||
{ $values
|
||||
{ "type" "a SQL type" } }
|
||||
{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
|
||||
|
||||
HELP: normalize-spec
|
||||
{ $values
|
||||
{ "spec" "a SQL spec" } }
|
||||
{ $description "Normalizes a SQL spec." } ;
|
||||
|
||||
HELP: primary-key?
|
||||
{ $values
|
||||
{ "spec" "a SQL spec" }
|
||||
{ "?" boolean } }
|
||||
{ $description "Returns true if a SQL spec is a primary key." } ;
|
||||
|
||||
HELP: relation?
|
||||
{ $values
|
||||
{ "spec" "a SQL spec" }
|
||||
{ "?" boolean } }
|
||||
{ $description "Returns true if a SQL spec is a relation." } ;
|
||||
|
||||
HELP: unknown-modifier
|
||||
{ $values { "modifier" string } }
|
||||
{ $description "Throws an error containing an unknown SQL modifier." } ;
|
||||
|
||||
ARTICLE: "db.types" "Database types"
|
||||
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
|
||||
"Primary keys:"
|
||||
{ $subsections
|
||||
+db-assigned-id+
|
||||
+user-assigned-id+
|
||||
+random-id+
|
||||
}
|
||||
"Null and boolean types:"
|
||||
{ $subsections
|
||||
NULL
|
||||
BOOLEAN
|
||||
}
|
||||
"Text types:"
|
||||
{ $subsections
|
||||
VARCHAR
|
||||
TEXT
|
||||
}
|
||||
"Number types:"
|
||||
{ $subsections
|
||||
INTEGER
|
||||
BIG-INTEGER
|
||||
SIGNED-BIG-INTEGER
|
||||
UNSIGNED-BIG-INTEGER
|
||||
DOUBLE
|
||||
REAL
|
||||
}
|
||||
"Calendar types:"
|
||||
{ $subsections
|
||||
DATE
|
||||
DATETIME
|
||||
TIME
|
||||
TIMESTAMP
|
||||
}
|
||||
"Factor byte-arrays:"
|
||||
{ $subsections BLOB }
|
||||
"Arbitrary Factor objects:"
|
||||
{ $subsections FACTOR-BLOB }
|
||||
"Factor URLs:"
|
||||
{ $subsections URL } ;
|
||||
|
||||
ABOUT: "db.types"
|
||||
|
|
@ -1,156 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations sequences.deep prettyprint
|
||||
words namespaces slots slots.private classes mirrors
|
||||
classes.tuple combinators calendar.format classes.singleton
|
||||
accessors quotations random db.private ;
|
||||
IN: db.types
|
||||
|
||||
HOOK: persistent-table db-connection ( -- hash )
|
||||
HOOK: compound db-connection ( string obj -- hash )
|
||||
|
||||
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
|
||||
|
||||
TUPLE: literal-bind key type value ;
|
||||
C: <literal-bind> literal-bind
|
||||
|
||||
TUPLE: generator-bind slot-name key generator-singleton type ;
|
||||
C: <generator-bind> generator-bind
|
||||
SINGLETON: random-id-generator
|
||||
|
||||
TUPLE: low-level-binding value ;
|
||||
C: <low-level-binding> low-level-binding
|
||||
|
||||
SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
|
||||
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
|
||||
|
||||
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
||||
+foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
|
||||
+set-null+ +set-default+ ;
|
||||
|
||||
SYMBOL: IGNORE
|
||||
|
||||
: filter-ignores ( tuple specs -- specs' )
|
||||
[ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
|
||||
[ slot-name>> swap member? ] with reject ;
|
||||
|
||||
ERROR: not-persistent class ;
|
||||
|
||||
: db-table-name ( class -- object )
|
||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||
|
||||
: db-columns ( class -- object )
|
||||
superclasses-of [ "db-columns" word-prop ] map concat ;
|
||||
|
||||
: db-relations ( class -- object )
|
||||
"db-relations" word-prop ;
|
||||
|
||||
: find-primary-key ( specs -- seq )
|
||||
[ primary-key>> ] filter ;
|
||||
|
||||
: set-primary-key ( value tuple -- )
|
||||
[
|
||||
class-of db-columns
|
||||
find-primary-key first slot-name>>
|
||||
] keep set-slot-named ;
|
||||
|
||||
: primary-key? ( spec -- ? )
|
||||
primary-key>> +primary-key+? ;
|
||||
|
||||
: db-assigned-id-spec? ( specs -- ? )
|
||||
[ primary-key>> +db-assigned-id+? ] any? ;
|
||||
|
||||
: user-assigned-id-spec? ( specs -- ? )
|
||||
[ primary-key>> +user-assigned-id+? ] any? ;
|
||||
|
||||
: normalize-spec ( spec -- )
|
||||
dup type>> dup +primary-key+? [
|
||||
>>primary-key drop
|
||||
] [
|
||||
drop dup modifiers>> [
|
||||
+primary-key+?
|
||||
] deep-find
|
||||
[ >>primary-key drop ] [ drop ] if*
|
||||
] if ;
|
||||
|
||||
: db-assigned? ( class -- ? )
|
||||
db-columns find-primary-key db-assigned-id-spec? ;
|
||||
|
||||
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
|
||||
|
||||
SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
|
||||
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
|
||||
FACTOR-BLOB NULL URL ;
|
||||
|
||||
: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
|
||||
sql-spec new
|
||||
swap >>modifiers
|
||||
swap >>type
|
||||
swap >>column-name
|
||||
swap >>slot-name
|
||||
swap >>class
|
||||
dup normalize-spec ;
|
||||
|
||||
: spec>tuple ( class spec -- tuple )
|
||||
3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
|
||||
|
||||
: number>string* ( n/string -- string )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
: remove-db-assigned-id ( specs -- obj )
|
||||
[ +db-assigned-id+? ] reject ;
|
||||
|
||||
: remove-relations ( specs -- newcolumns )
|
||||
[ relation? ] reject ;
|
||||
|
||||
: remove-id ( specs -- obj )
|
||||
[ primary-key>> ] reject ;
|
||||
|
||||
! SQLite Types: http://www.sqlite.org/datatype3.html
|
||||
! NULL INTEGER REAL TEXT BLOB
|
||||
! PostgreSQL Types:
|
||||
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
|
||||
|
||||
ERROR: unknown-modifier modifier ;
|
||||
|
||||
: lookup-modifier ( obj -- string )
|
||||
{
|
||||
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
|
||||
[ persistent-table ?at [ unknown-modifier ] unless third ]
|
||||
} cond ;
|
||||
|
||||
ERROR: no-sql-type type ;
|
||||
|
||||
: (lookup-type) ( obj -- string )
|
||||
persistent-table ?at [ no-sql-type ] unless ;
|
||||
|
||||
: lookup-type ( obj -- string )
|
||||
dup array? [
|
||||
unclip (lookup-type) first nip
|
||||
] [
|
||||
(lookup-type) first
|
||||
] if ;
|
||||
|
||||
: lookup-create-type ( obj -- string )
|
||||
dup array? [
|
||||
unclip (lookup-type) second swap compound
|
||||
] [
|
||||
(lookup-type) second
|
||||
] if ;
|
||||
|
||||
: modifiers ( spec -- string )
|
||||
modifiers>> [ lookup-modifier ] map " " join
|
||||
[ "" ] [ " " prepend ] if-empty ;
|
||||
|
||||
HOOK: bind% db-connection ( spec -- )
|
||||
HOOK: bind# db-connection ( spec obj -- )
|
||||
|
||||
ERROR: no-column column ;
|
||||
|
||||
: >reference-string ( string pair -- string )
|
||||
first2
|
||||
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
|
||||
swap [ column-name>> = ] with find nip
|
||||
[ no-column ] unless*
|
||||
column-name>> "(" ")" surround append ;
|
||||
Loading…
Reference in New Issue