fix postgresql connect error message

fix unit test
db4
Doug Coleman 2008-02-24 12:32:36 -06:00
parent c68c57b5e4
commit a4518150a7
4 changed files with 37 additions and 17 deletions

View File

@ -2,21 +2,25 @@
! 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
db.types tools.walker ;
db.types tools.walker ascii splitting ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
PQresultErrorMessage [ CHAR: \n = ] right-trim
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 get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
db get db-handle (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@ -27,7 +31,7 @@ IN: db.postgresql.lib
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [

View File

@ -208,7 +208,7 @@ M: postgresql-db <insert-assigned-statement> ( tuple -- statement )
");" 0%
] postgresql-make ;
M: postgresql-db <update-tuple-statement> ( tuple -- statement )
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
@ -220,7 +220,7 @@ M: postgresql-db <update-tuple-statement> ( tuple -- statement )
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( tuple -- statement )
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
"delete from " 0% 0%
" where " 0%

View File

@ -31,7 +31,8 @@ SYMBOL: the-person
[ ] [ 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
! [ ] [ person drop-table ] unit-test

View File

@ -32,6 +32,12 @@ HOOK: <delete-tuples-statement> db ( tuple -- obj )
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 )
dupd
[ 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
] 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 )
dup db-columns swap db-table ;
@ -51,7 +63,7 @@ HOOK: row-column-typed db ( result-set n type -- sql )
: insert-native ( tuple -- )
dup class <insert-native-statement>
[ bind-tuple ] 2keep query-tuple ;
[ bind-tuple ] 2keep query-tuple drop ;
: insert-assigned ( tuple -- )
dup <insert-assigned-statement>
@ -65,13 +77,12 @@ HOOK: row-column-typed db ( result-set n type -- sql )
] if ;
: update-tuple ( tuple -- )
<update-tuple-statement> execute-statement ;
dup class <update-tuple-statement>
[ bind-tuple ] keep execute-statement ;
: update-tuples ( seq -- )
<update-tuples-statement> execute-statement ;
! : persist ( 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 )
: select-tuple ( tuple -- tuple )
: setup-select ( tuple -- tuple 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 )
dup dup class <select-by-slots-statement>
[ bind-tuple ] 2keep query-tuples ;
setup-select query-tuples ;
! uniqueResult