parent
c68c57b5e4
commit
a4518150a7
|
@ -2,21 +2,25 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays continuations db io kernel math namespaces
|
USING: arrays continuations db io kernel math namespaces
|
||||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||||
db.types tools.walker ;
|
db.types tools.walker ascii splitting ;
|
||||||
IN: db.postgresql.lib
|
IN: db.postgresql.lib
|
||||||
|
|
||||||
: postgresql-result-error-message ( res -- str/f )
|
: postgresql-result-error-message ( res -- str/f )
|
||||||
dup zero? [
|
dup zero? [
|
||||||
drop f
|
drop f
|
||||||
] [
|
] [
|
||||||
PQresultErrorMessage [ CHAR: \n = ] right-trim
|
PQresultErrorMessage [ blank? ] trim
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: postgres-result-error ( res -- )
|
: postgres-result-error ( res -- )
|
||||||
postgresql-result-error-message [ throw ] when* ;
|
postgresql-result-error-message [ throw ] when* ;
|
||||||
|
|
||||||
|
: (postgresql-error-message) ( handle -- str )
|
||||||
|
PQerrorMessage
|
||||||
|
"\n" split [ [ blank? ] trim ] map "\n" join ;
|
||||||
|
|
||||||
: postgresql-error-message ( -- str )
|
: postgresql-error-message ( -- str )
|
||||||
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
|
db get db-handle (postgresql-error-message) ;
|
||||||
|
|
||||||
: postgresql-error ( res -- res )
|
: postgresql-error ( res -- res )
|
||||||
dup [ postgresql-error-message throw ] unless ;
|
dup [ postgresql-error-message throw ] unless ;
|
||||||
|
@ -27,7 +31,7 @@ IN: db.postgresql.lib
|
||||||
|
|
||||||
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
|
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
|
||||||
PQsetdbLogin
|
PQsetdbLogin
|
||||||
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
|
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
|
||||||
|
|
||||||
: do-postgresql-statement ( statement -- res )
|
: do-postgresql-statement ( statement -- res )
|
||||||
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
|
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
|
||||||
|
|
|
@ -208,7 +208,7 @@ M: postgresql-db <insert-assigned-statement> ( tuple -- statement )
|
||||||
");" 0%
|
");" 0%
|
||||||
] postgresql-make ;
|
] postgresql-make ;
|
||||||
|
|
||||||
M: postgresql-db <update-tuple-statement> ( tuple -- statement )
|
M: postgresql-db <update-tuple-statement> ( class -- statement )
|
||||||
[
|
[
|
||||||
"update " 0% 0%
|
"update " 0% 0%
|
||||||
" set " 0%
|
" set " 0%
|
||||||
|
@ -220,7 +220,7 @@ M: postgresql-db <update-tuple-statement> ( tuple -- statement )
|
||||||
dup sql-spec-column-name 0% " = " 0% bind%
|
dup sql-spec-column-name 0% " = " 0% bind%
|
||||||
] postgresql-make ;
|
] postgresql-make ;
|
||||||
|
|
||||||
M: postgresql-db <delete-tuple-statement> ( tuple -- statement )
|
M: postgresql-db <delete-tuple-statement> ( class -- statement )
|
||||||
[
|
[
|
||||||
"delete from " 0% 0%
|
"delete from " 0% 0%
|
||||||
" where " 0%
|
" where " 0%
|
||||||
|
|
|
@ -31,7 +31,8 @@ SYMBOL: the-person
|
||||||
|
|
||||||
[ ] [ the-person get update-tuple ] unit-test
|
[ ] [ the-person get update-tuple ] unit-test
|
||||||
|
|
||||||
! T{ person f f f 200 f } select-tuples
|
[ T{ person f 1 "billy" 200 3.14 } ]
|
||||||
|
[ T{ person f 1 } select-tuple ] unit-test
|
||||||
|
|
||||||
! [ ] [ the-person get delete-tuple ] unit-test
|
! [ ] [ the-person get delete-tuple ] unit-test
|
||||||
! [ ] [ person drop-table ] unit-test
|
! [ ] [ person drop-table ] unit-test
|
||||||
|
|
|
@ -32,6 +32,12 @@ HOOK: <delete-tuples-statement> db ( tuple -- obj )
|
||||||
|
|
||||||
HOOK: row-column-typed db ( result-set n type -- sql )
|
HOOK: row-column-typed db ( result-set n type -- sql )
|
||||||
|
|
||||||
|
: resulting-tuple ( class out-params row -- tuple )
|
||||||
|
>r >r construct-empty r> r> rot [
|
||||||
|
>r [ sql-spec-type sql-type>factor-type ] keep
|
||||||
|
sql-spec-slot-name r> set-slot-named
|
||||||
|
] curry 2each ;
|
||||||
|
|
||||||
: query-tuple ( tuple statement -- seq )
|
: query-tuple ( tuple statement -- seq )
|
||||||
dupd
|
dupd
|
||||||
[ query-results [ sql-row ] with-disposal ] keep
|
[ query-results [ sql-row ] with-disposal ] keep
|
||||||
|
@ -40,8 +46,14 @@ HOOK: row-column-typed db ( result-set n type -- sql )
|
||||||
sql-spec-slot-name r> set-slot-named
|
sql-spec-slot-name r> set-slot-named
|
||||||
] curry 2each ;
|
] curry 2each ;
|
||||||
|
|
||||||
: query-tuples ( statement -- seq )
|
: query-tuples ( tuple statement -- seq )
|
||||||
;
|
dup query-results [
|
||||||
|
statement-out-params [
|
||||||
|
break
|
||||||
|
>r [ sql-spec-type sql-type>factor-type ] keep
|
||||||
|
sql-spec-slot-name r> set-slot-named
|
||||||
|
] with with query-map
|
||||||
|
] with-disposal ;
|
||||||
|
|
||||||
: sql-props ( class -- columns table )
|
: sql-props ( class -- columns table )
|
||||||
dup db-columns swap db-table ;
|
dup db-columns swap db-table ;
|
||||||
|
@ -51,7 +63,7 @@ HOOK: row-column-typed db ( result-set n type -- sql )
|
||||||
|
|
||||||
: insert-native ( tuple -- )
|
: insert-native ( tuple -- )
|
||||||
dup class <insert-native-statement>
|
dup class <insert-native-statement>
|
||||||
[ bind-tuple ] 2keep query-tuple ;
|
[ bind-tuple ] 2keep query-tuple drop ;
|
||||||
|
|
||||||
: insert-assigned ( tuple -- )
|
: insert-assigned ( tuple -- )
|
||||||
dup <insert-assigned-statement>
|
dup <insert-assigned-statement>
|
||||||
|
@ -65,13 +77,12 @@ HOOK: row-column-typed db ( result-set n type -- sql )
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: update-tuple ( tuple -- )
|
: update-tuple ( tuple -- )
|
||||||
<update-tuple-statement> execute-statement ;
|
dup class <update-tuple-statement>
|
||||||
|
[ bind-tuple ] keep execute-statement ;
|
||||||
|
|
||||||
: update-tuples ( seq -- )
|
: update-tuples ( seq -- )
|
||||||
<update-tuples-statement> execute-statement ;
|
<update-tuples-statement> execute-statement ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
! : persist ( tuple -- )
|
! : persist ( tuple -- )
|
||||||
|
|
||||||
HOOK: delete-by-id db ( tuple -- )
|
HOOK: delete-by-id db ( tuple -- )
|
||||||
|
@ -80,10 +91,14 @@ HOOK: delete-by-id db ( tuple -- )
|
||||||
|
|
||||||
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
|
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
|
||||||
|
|
||||||
: select-tuple ( tuple -- tuple )
|
: setup-select ( tuple -- tuple statement )
|
||||||
dup dup class <select-by-slots-statement>
|
dup dup class <select-by-slots-statement>
|
||||||
[ bind-tuple ] 2keep query-tuple ;
|
[ bind-tuple ] 2keep ;
|
||||||
|
|
||||||
|
: select-tuple ( tuple -- tuple )
|
||||||
|
setup-select query-tuple ;
|
||||||
|
|
||||||
: select-tuples ( tuple -- tuple )
|
: select-tuples ( tuple -- tuple )
|
||||||
dup dup class <select-by-slots-statement>
|
setup-select query-tuples ;
|
||||||
[ bind-tuple ] 2keep query-tuples ;
|
|
||||||
|
! uniqueResult
|
||||||
|
|
Loading…
Reference in New Issue