parent
9f2c032b2f
commit
eb75685031
|
@ -15,7 +15,8 @@ TUPLE: db handle insert-statements update-statements delete-statements select-st
|
||||||
GENERIC: db-open ( db -- )
|
GENERIC: db-open ( db -- )
|
||||||
HOOK: db-close db ( handle -- )
|
HOOK: db-close db ( handle -- )
|
||||||
|
|
||||||
: dispose-statements [ dispose drop ] assoc-each ;
|
: dispose-statements ( seq -- )
|
||||||
|
[ dispose drop ] assoc-each ;
|
||||||
|
|
||||||
: dispose-db ( db -- )
|
: dispose-db ( db -- )
|
||||||
dup db [
|
dup db [
|
||||||
|
@ -35,7 +36,13 @@ HOOK: <prepared-statement> db ( str -- statement )
|
||||||
GENERIC: prepare-statement ( statement -- )
|
GENERIC: prepare-statement ( statement -- )
|
||||||
GENERIC: bind-statement* ( obj statement -- )
|
GENERIC: bind-statement* ( obj statement -- )
|
||||||
GENERIC: reset-statement ( statement -- )
|
GENERIC: reset-statement ( statement -- )
|
||||||
GENERIC: execute-statement ( statement -- )
|
GENERIC: execute-statement* ( statement -- result-set )
|
||||||
|
HOOK: last-id db ( res -- id )
|
||||||
|
: execute-statement ( statement -- )
|
||||||
|
execute-statement* dispose ;
|
||||||
|
|
||||||
|
: execute-statement-last-id ( statement -- id )
|
||||||
|
execute-statement* [ last-id ] with-disposal ;
|
||||||
|
|
||||||
: bind-statement ( obj statement -- )
|
: bind-statement ( obj statement -- )
|
||||||
dup statement-bound? [ dup reset-statement ] when
|
dup statement-bound? [ dup reset-statement ] when
|
||||||
|
@ -51,8 +58,6 @@ GENERIC: #columns ( result-set -- n )
|
||||||
GENERIC# row-column 1 ( result-set n -- obj )
|
GENERIC# row-column 1 ( result-set n -- obj )
|
||||||
GENERIC: advance-row ( result-set -- ? )
|
GENERIC: advance-row ( result-set -- ? )
|
||||||
|
|
||||||
HOOK: last-id db ( -- id )
|
|
||||||
|
|
||||||
: init-result-set ( result-set -- )
|
: init-result-set ( result-set -- )
|
||||||
dup #rows over set-result-set-max
|
dup #rows over set-result-set-max
|
||||||
-1 swap set-result-set-n ;
|
-1 swap set-result-set-n ;
|
||||||
|
|
|
@ -50,6 +50,8 @@ IN: db.postgresql.ffi
|
||||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
: PQERRORS_DEFAULT HEX: 1 ; inline
|
||||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
: PQERRORS_VERBOSE HEX: 2 ; inline
|
||||||
|
|
||||||
|
: InvalidOid 0 ; inline
|
||||||
|
|
||||||
TYPEDEF: int size_t
|
TYPEDEF: int size_t
|
||||||
TYPEDEF: int ConnStatusType
|
TYPEDEF: int ConnStatusType
|
||||||
TYPEDEF: int ExecStatusType
|
TYPEDEF: int ExecStatusType
|
||||||
|
|
|
@ -37,8 +37,13 @@ IN: db.postgresql.lib
|
||||||
>r db get db-handle r>
|
>r db get db-handle r>
|
||||||
[ statement-sql ] keep
|
[ statement-sql ] keep
|
||||||
[ statement-params length f ] keep
|
[ statement-params length f ] keep
|
||||||
statement-params [ malloc-char-string ] map >c-void*-array
|
statement-params [ second malloc-char-string ] map >c-void*-array
|
||||||
f f 0 PQexecParams
|
f f 0 PQexecParams
|
||||||
dup postgresql-result-ok? [
|
dup postgresql-result-ok? [
|
||||||
dup postgresql-result-error-message swap PQclear throw
|
dup postgresql-result-error-message swap PQclear throw
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
: pq-oid-value ( res -- n )
|
||||||
|
PQoidValue dup InvalidOid = [
|
||||||
|
"postgresql returned an InvalidOid" throw
|
||||||
|
] when ;
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2007, 2008 Doug Coleman.
|
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs alien alien.syntax continuations io
|
USING: arrays assocs alien alien.syntax continuations io
|
||||||
kernel math namespaces prettyprint quotations
|
kernel math math.parser namespaces prettyprint quotations
|
||||||
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
|
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||||
|
db.tuples db.types ;
|
||||||
IN: db.postgresql
|
IN: db.postgresql
|
||||||
|
|
||||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||||
|
@ -51,8 +52,8 @@ M: postgresql-result-set #columns ( result-set -- n )
|
||||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||||
|
|
||||||
M: postgresql-statement execute-statement ( statement -- )
|
M: postgresql-statement execute-statement* ( statement -- obj )
|
||||||
query-results dispose ;
|
query-results ;
|
||||||
|
|
||||||
: increment-n ( result-set -- n )
|
: increment-n ( result-set -- n )
|
||||||
dup result-set-n 1+ dup rot set-result-set-n ;
|
dup result-set-n 1+ dup rot set-result-set-n ;
|
||||||
|
@ -103,3 +104,103 @@ M: postgresql-db commit-transaction ( -- )
|
||||||
|
|
||||||
M: postgresql-db rollback-transaction ( -- )
|
M: postgresql-db rollback-transaction ( -- )
|
||||||
"ROLLBACK" sql-command ;
|
"ROLLBACK" sql-command ;
|
||||||
|
|
||||||
|
|
||||||
|
M: postgresql-db create-sql ( columns table -- sql )
|
||||||
|
[
|
||||||
|
"create table " % %
|
||||||
|
" (" % [ ", " % ] [
|
||||||
|
dup second % " " %
|
||||||
|
dup third >sql-type % " " %
|
||||||
|
sql-modifiers " " join %
|
||||||
|
] interleave ")" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
M: postgresql-db drop-sql ( table -- sql )
|
||||||
|
[
|
||||||
|
"drop table " % %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
SYMBOL: postgresql-counter
|
||||||
|
|
||||||
|
M: postgresql-db insert-sql* ( columns table -- sql )
|
||||||
|
[
|
||||||
|
postgresql-counter off
|
||||||
|
"insert into " %
|
||||||
|
%
|
||||||
|
"(" %
|
||||||
|
dup [ ", " % ] [ second % ] interleave
|
||||||
|
") " %
|
||||||
|
" values (" %
|
||||||
|
[ ", " % ] [
|
||||||
|
drop "$" % postgresql-counter [ inc ] keep get #
|
||||||
|
] interleave
|
||||||
|
")" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
M: postgresql-db update-sql* ( columns table -- sql )
|
||||||
|
[
|
||||||
|
"update " %
|
||||||
|
%
|
||||||
|
" set " %
|
||||||
|
dup remove-id
|
||||||
|
[ ", " % ] [ second dup % " = :" % % ] interleave
|
||||||
|
" where " %
|
||||||
|
[ primary-key? ] find nip second dup % " = :" % %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
M: postgresql-db delete-sql* ( columns table -- sql )
|
||||||
|
[
|
||||||
|
"delete from " %
|
||||||
|
%
|
||||||
|
" where " %
|
||||||
|
first second dup % " = :" % %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
M: postgresql-db select-sql* ( columns table -- sql )
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: postgresql-db tuple>params ( columns tuple -- obj )
|
||||||
|
[
|
||||||
|
>r dup first r> get-slot-named swap third
|
||||||
|
] curry { } map>assoc ;
|
||||||
|
|
||||||
|
M: postgresql-db last-id ( res -- id )
|
||||||
|
pq-oid-value ;
|
||||||
|
|
||||||
|
: postgresql-db-modifiers ( -- hashtable )
|
||||||
|
H{
|
||||||
|
{ +native-id+ "primary key" }
|
||||||
|
{ +assigned-id+ "primary key" }
|
||||||
|
{ +autoincrement+ "autoincrement" }
|
||||||
|
{ +unique+ "unique" }
|
||||||
|
{ +default+ "default" }
|
||||||
|
{ +null+ "null" }
|
||||||
|
{ +not-null+ "not null" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
M: postgresql-db sql-modifiers* ( modifiers -- str )
|
||||||
|
postgresql-db-modifiers swap [
|
||||||
|
dup array? [
|
||||||
|
first2
|
||||||
|
>r swap at r> number>string*
|
||||||
|
" " swap 3append
|
||||||
|
] [
|
||||||
|
swap at
|
||||||
|
] if
|
||||||
|
] with map [ ] subset ;
|
||||||
|
|
||||||
|
: postgresql-type-hash ( -- assoc )
|
||||||
|
H{
|
||||||
|
{ INTEGER "integer" }
|
||||||
|
{ TEXT "text" }
|
||||||
|
{ VARCHAR "text" }
|
||||||
|
{ DOUBLE "real" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
M: postgresql-db >sql-type ( obj -- str )
|
||||||
|
dup pair? [
|
||||||
|
first >sql-type
|
||||||
|
] [
|
||||||
|
postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
|
||||||
|
] if ;
|
||||||
|
|
|
@ -108,7 +108,7 @@ LIBRARY: sqlite
|
||||||
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
|
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
|
||||||
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
|
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
|
||||||
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
|
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
|
||||||
FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
|
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
|
||||||
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
||||||
|
|
|
@ -30,7 +30,7 @@ IN: db.sqlite.lib
|
||||||
|
|
||||||
: sqlite-prepare ( db sql -- handle )
|
: sqlite-prepare ( db sql -- handle )
|
||||||
dup length "void*" <c-object> "void*" <c-object>
|
dup length "void*" <c-object> "void*" <c-object>
|
||||||
[ sqlite3_prepare_v2 sqlite-check-result ] 2keep
|
[ sqlite3_prepare sqlite-check-result ] 2keep
|
||||||
drop *void* ;
|
drop *void* ;
|
||||||
|
|
||||||
: sqlite-bind-parameter-index ( handle name -- index )
|
: sqlite-bind-parameter-index ( handle name -- index )
|
||||||
|
|
|
@ -25,7 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||||
TUPLE: sqlite-statement ;
|
TUPLE: sqlite-statement ;
|
||||||
C: <sqlite-statement> sqlite-statement
|
C: <sqlite-statement> sqlite-statement
|
||||||
|
|
||||||
TUPLE: sqlite-result-set ;
|
TUPLE: sqlite-result-set advanced? ;
|
||||||
: <sqlite-result-set> ( query -- sqlite-result-set )
|
: <sqlite-result-set> ( query -- sqlite-result-set )
|
||||||
dup statement-handle sqlite-result-set <result-set> ;
|
dup statement-handle sqlite-result-set <result-set> ;
|
||||||
|
|
||||||
|
@ -40,7 +40,13 @@ M: sqlite-db <prepared-statement> ( str -- obj )
|
||||||
M: sqlite-statement dispose ( statement -- )
|
M: sqlite-statement dispose ( statement -- )
|
||||||
statement-handle sqlite-finalize ;
|
statement-handle sqlite-finalize ;
|
||||||
|
|
||||||
|
: maybe-advance-row ( result-set -- result-set )
|
||||||
|
dup sqlite-result-set-advanced? [
|
||||||
|
dup advance-row drop
|
||||||
|
] unless ;
|
||||||
|
|
||||||
M: sqlite-result-set dispose ( result-set -- )
|
M: sqlite-result-set dispose ( result-set -- )
|
||||||
|
maybe-advance-row
|
||||||
f swap set-result-set-handle ;
|
f swap set-result-set-handle ;
|
||||||
|
|
||||||
: sqlite-bind ( triples handle -- )
|
: sqlite-bind ( triples handle -- )
|
||||||
|
@ -52,8 +58,8 @@ M: sqlite-statement bind-statement* ( triples statement -- )
|
||||||
M: sqlite-statement reset-statement ( statement -- )
|
M: sqlite-statement reset-statement ( statement -- )
|
||||||
statement-handle sqlite-reset ;
|
statement-handle sqlite-reset ;
|
||||||
|
|
||||||
M: sqlite-statement execute-statement ( statement -- )
|
M: sqlite-statement execute-statement* ( statement -- obj )
|
||||||
statement-handle sqlite-next drop ;
|
query-results ;
|
||||||
|
|
||||||
M: sqlite-result-set #columns ( result-set -- n )
|
M: sqlite-result-set #columns ( result-set -- n )
|
||||||
result-set-handle sqlite-#columns ;
|
result-set-handle sqlite-#columns ;
|
||||||
|
@ -62,7 +68,8 @@ M: sqlite-result-set row-column ( result-set n -- obj )
|
||||||
>r result-set-handle r> sqlite-column ;
|
>r result-set-handle r> sqlite-column ;
|
||||||
|
|
||||||
M: sqlite-result-set advance-row ( result-set -- handle ? )
|
M: sqlite-result-set advance-row ( result-set -- handle ? )
|
||||||
result-set-handle sqlite-next ;
|
[ result-set-handle sqlite-next ] keep
|
||||||
|
t swap set-sqlite-result-set-advanced? ;
|
||||||
|
|
||||||
M: sqlite-statement query-results ( query -- result-set )
|
M: sqlite-statement query-results ( query -- result-set )
|
||||||
dup statement-handle sqlite-result-set <result-set> ;
|
dup statement-handle sqlite-result-set <result-set> ;
|
||||||
|
@ -138,9 +145,10 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
|
||||||
third 3array
|
third 3array
|
||||||
] curry map ;
|
] curry map ;
|
||||||
|
|
||||||
M: sqlite-db last-id ( -- id )
|
M: sqlite-db last-id ( result-set -- id )
|
||||||
db get db-handle sqlite3_last_insert_rowid ;
|
maybe-advance-row drop
|
||||||
|
db get db-handle sqlite3_last_insert_rowid
|
||||||
|
dup zero? [ "last-id failed" throw ] when ;
|
||||||
|
|
||||||
: sqlite-db-modifiers ( -- hashtable )
|
: sqlite-db-modifiers ( -- hashtable )
|
||||||
H{
|
H{
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.files kernel tools.test db db.sqlite db.tuples
|
USING: io.files kernel tools.test db db.sqlite db.tuples
|
||||||
db.types continuations namespaces ;
|
db.types continuations namespaces db.postgresql math
|
||||||
|
tools.time ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
TUPLE: person the-id the-name the-number real ;
|
TUPLE: person the-id the-name the-number real ;
|
||||||
: <person> ( name age -- person )
|
: <person> ( name age real -- person )
|
||||||
{
|
{
|
||||||
set-person-the-name
|
set-person-the-name
|
||||||
set-person-the-number
|
set-person-the-number
|
||||||
|
@ -36,10 +37,10 @@ SYMBOL: the-person
|
||||||
test-tuples
|
test-tuples
|
||||||
] with-db ;
|
] with-db ;
|
||||||
|
|
||||||
! : test-postgres ( -- )
|
: test-postgresql ( -- )
|
||||||
! resource-path <postgresql-db> [
|
"localhost" "postgres" "" "factor-test" <postgresql-db> [
|
||||||
! test-tuples
|
test-tuples
|
||||||
! ] with-db ;
|
] with-db ;
|
||||||
|
|
||||||
person "PERSON"
|
person "PERSON"
|
||||||
{
|
{
|
||||||
|
@ -52,7 +53,7 @@ person "PERSON"
|
||||||
"billy" 10 3.14 <person> the-person set
|
"billy" 10 3.14 <person> the-person set
|
||||||
|
|
||||||
test-sqlite
|
test-sqlite
|
||||||
! test-postgres
|
! test-postgresql
|
||||||
|
|
||||||
person "PERSON"
|
person "PERSON"
|
||||||
{
|
{
|
||||||
|
@ -65,4 +66,4 @@ person "PERSON"
|
||||||
1 "billy" 20 6.28 <assigned-person> the-person set
|
1 "billy" 20 6.28 <assigned-person> the-person set
|
||||||
|
|
||||||
test-sqlite
|
test-sqlite
|
||||||
! test-postgres
|
! test-postgresql
|
||||||
|
|
|
@ -64,9 +64,12 @@ HOOK: tuple>params db ( columns tuple -- obj )
|
||||||
2dup . .
|
2dup . .
|
||||||
[ bind-statement ] keep ;
|
[ bind-statement ] keep ;
|
||||||
|
|
||||||
: do-tuple-statement ( tuple columns-quot statement-quot -- )
|
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
|
||||||
>r [ class db-columns ] swap compose keep
|
>r [ class db-columns ] swap compose keep
|
||||||
r> tuple-statement execute-statement ;
|
r> tuple-statement ;
|
||||||
|
|
||||||
|
: do-tuple-statement ( tuple columns-quot statement-quot -- )
|
||||||
|
make-tuple-statement execute-statement ;
|
||||||
|
|
||||||
: create-table ( class -- )
|
: create-table ( class -- )
|
||||||
dup db-columns swap db-table create-sql sql-command ;
|
dup db-columns swap db-table create-sql sql-command ;
|
||||||
|
@ -76,8 +79,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
|
||||||
|
|
||||||
: insert-tuple ( tuple -- )
|
: insert-tuple ( tuple -- )
|
||||||
[
|
[
|
||||||
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement
|
[ maybe-remove-id ] [ insert-sql ]
|
||||||
last-id
|
make-tuple-statement execute-statement-last-id
|
||||||
] keep set-primary-key ;
|
] keep set-primary-key ;
|
||||||
|
|
||||||
: update-tuple ( tuple -- )
|
: update-tuple ( tuple -- )
|
||||||
|
|
Loading…
Reference in New Issue