TAP test module - PostgresClient - Mailing list pgsql-hackers
| From | Kyotaro HORIGUCHI |
|---|---|
| Subject | TAP test module - PostgresClient |
| Date | |
| Msg-id | 20171228.173147.48313752.horiguchi.kyotaro@lab.ntt.co.jp Whole thread Raw |
| Responses |
Re: TAP test module - PostgresClient
(Craig Ringer <craig@2ndquadrant.com>)
|
| List | pgsql-hackers |
Hello. It would be useful if we have interactive sessions for TAP tests. My first attempt was apparently unstable one that was using psql. https://www.postgresql.org/message-id/20170720.152533.252230418.horiguchi.kyotaro@lab.ntt.co.jp Finally the test for the patch in the thread made not need such a machinery but it is still potentially useful. I found that there's already a implementation of Perl client but I saw it was GPL. So before I see the code of the client, I made a small set of Perl client (almost only) for the purpose of TAP testing. (I don't want replace the existing library with this.) The patch creates two modules PostgresClient and PgResult in src/test/perl directory. (patch 1) Typical usage of it is as follows. my $server = get_new_node('server'); $server->init(); $server->start; my $session1 = $server->get_new_session('postgres', 'session1'); my $result = $session1->exec("SELECT c1 FROM ft1 LIMIT 1;"); ... As an usage example, a test for postgres_fdw reconnection behavior is added as patch 2. regards, -- Kyotaro Horiguchi NTT Open Source Software Center From 982d4eb86b9ab7f91bffc3ac722d9ac2a46b176b Mon Sep 17 00:00:00 2001 From: Kyotaro Horiguchi <horiguchi.kyotaro@lab.ntt.co.jp> Date: Thu, 2 Nov 2017 20:43:06 +0900 Subject: [PATCH 1/2] Simple perl client module for testing We are missing a means to perform interactive client operations. This patch adds a simple client interface usable from perl scripts. --- contrib/postgres_fdw/Makefile | 6 + src/test/perl/Makefile | 31 +++ src/test/perl/PgResult.pm | 80 ++++++ src/test/perl/PgResult.xs | 152 +++++++++++ src/test/perl/PostgresClient.pm | 221 ++++++++++++++++ src/test/perl/PostgresClient.xs | 473 ++++++++++++++++++++++++++++++++++ src/test/perl/PostgresNode.pm | 21 ++ src/test/perl/const-c.inc | 544 ++++++++++++++++++++++++++++++++++++++++ src/test/perl/const-xs.inc | 90 +++++++ 9 files changed, 1618 insertions(+) create mode 100644 src/test/perl/PgResult.pm create mode 100644 src/test/perl/PgResult.xs create mode 100644 src/test/perl/PostgresClient.pm create mode 100644 src/test/perl/PostgresClient.xs create mode 100644 src/test/perl/const-c.inc create mode 100644 src/test/perl/const-xs.inc diff --git a/contrib/postgres_fdw/Makefile b/contrib/postgres_fdw/Makefile index 3543312..240bd19 100644 --- a/contrib/postgres_fdw/Makefile +++ b/contrib/postgres_fdw/Makefile @@ -23,3 +23,9 @@ top_builddir = ../.. include $(top_builddir)/src/Makefile.global include $(top_srcdir)/contrib/contrib-global.mk endif + +check: + $(prove_check) + +installcheck: + $(prove_installcheck) diff --git a/src/test/perl/Makefile b/src/test/perl/Makefile index a974f35..2a54a7c 100644 --- a/src/test/perl/Makefile +++ b/src/test/perl/Makefile @@ -15,6 +15,31 @@ include $(top_builddir)/src/Makefile.global ifeq ($(enable_tap_tests),yes) +OBJS = PostgresClient.o PgResult.o PostgresClient.so PgResult.so \ + PostgresClient.c PgResult.c +XSUBPPDIR = $(shell $(PERL) -e 'use List::Util qw(first); print first { -r "$$_/ExtUtils/xsubpp" } @INC') +XSUBPPTYPEMAP = $(XSUBPPDIR)/../ExtUtils/typemap +LDFLAGS = -L$(top_builddir)/src/interfaces/libpq -lpq +ARCHLIBEXP = $(shell $(PERL) -e 'use Config; print $$Config{"archlibexp"};') +override CPPFLAGS := -fPIC -I. -I$(srcdir) -I$(CPPFLAGS) -I$(top_builddir)/src/include -I$(top_builddir)/src/interfaces/libpq-I$(ARCHLIBEXP)/CORE -I$(top_builddir)/src/pl/plperl + +%.c: %.xs + $(PERL) $(XSUBPPDIR)/ExtUtils/xsubpp -typemap $(XSUBPPTYPEMAP) $< >$@ + +# These files are generated from libpq-fe.h. Must be re-generated when +# definitions of constants in the file is changed. Especially, +# EXPORT_TAGS and EXPORT in PostgresClient.pm must be edited according +# to generated PostgresClient/lib/PostgresClient.pm if related symbols +# in libpq-fe.h are removed or added. +const-c.inc const-xs.inc: + h2xs -OPb 5.8.0 -n PostgresClient $(top_builddir)/src/interfaces/libpq/libpq-fe.h + (cd PostgresClient; $(PERL) Makefile.PL) + cp PostgresClient/*.inc ./ + +PostgresClient.c PgResult.c : $(XSUBPPDEPS) const-c.inc const-xs.inc + +all: PostgresClient.so PgResult.so + installdirs: $(MKDIR_P) '$(DESTDIR)$(pgxsdir)/$(subdir)' @@ -30,4 +55,10 @@ uninstall: rm -f '$(DESTDIR)$(pgxsdir)/$(subdir)/RecursiveCopy.pm' rm -f '$(DESTDIR)$(pgxsdir)/$(subdir)/PostgresNode.pm' +clean: + rm -rf $(OBJS) PostgresClient + +distclean: clean + rm *.inc + endif diff --git a/src/test/perl/PgResult.pm b/src/test/perl/PgResult.pm new file mode 100644 index 0000000..dc9cee2 --- /dev/null +++ b/src/test/perl/PgResult.pm @@ -0,0 +1,80 @@ +=pod + +=head1 NAME + +PgResult - class representing PostgreSQL result object + +=head1 SYNOPSIS + use Client; + use Result; + use Carp; + + my $conn = $server->get_new_session('postgres', 'session1'); + $result = $conn->exec('SELECT pg_backend_pid()'); + + croak($conn->errorMessage()) + if ($result->resultStatus() ne "PGRES_TUPLES_OK"); + + $ntuples = $result->getntuples(); + $nfields = $result->nfields(); + for $i (0 .. ($ntuples - 1)) + { + $s = ""; + for $j (0 .. $nfields - 1) + { + $s .= $result->getvalue($i, $j); + } + print $s,"\n"; + } + + # get information. + # see the corresponding functions of libpq. Several functions that + # corresponding libpq function returns a enum value returns a string + # representation + + $result->resultStatus() + $result->clear() + $result->getntuples() + $result->nfields() + $result->getvalue() + $result->getlength() + $result->getisnull() + +=head1 DESCRIPTION + +PgResult contains a set of routines to handle a result object obtained +from a query execution. + +=cut + +package PgResult; + +use 5.016003; +use strict; +use warnings; + +require Exporter; + +our @ISA = qw(Exporter); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +# This allows declaration use PgResult ':all'; +# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw() ] ); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw(); + +our $VERSION = '0.01'; + +require XSLoader; +XSLoader::load('PgResult', $VERSION); + +# Preloaded methods go here. + +1; diff --git a/src/test/perl/PgResult.xs b/src/test/perl/PgResult.xs new file mode 100644 index 0000000..be40160 --- /dev/null +++ b/src/test/perl/PgResult.xs @@ -0,0 +1,152 @@ +/********************************************************************** + * PgResult + * + * Simple client interface for perl + * + * src/test/perl/PgResult.xs + * + **********************************************************************/ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + +/* conflicts with the same symbol defined by postgres_fe.h */ +#undef _ + +#include "libpq-fe.h" + +PGresult *getpgresult(SV *ressvrv); + +PGresult * +getpgresult(SV *ressvrv) +{ + SV *resivsv = SvRV(ressvrv); + + if (!sv_isobject(ressvrv) || !sv_isa(ressvrv, "PgResult")) + croak("unexpected parameter"); + + return (PGresult *) SvIV(resivsv); +} + + +MODULE = PgResult PACKAGE = PgResult +PROTOTYPES: ENABLE + +=pod + +=item $client->resultStatus() + +Get the result status of the command. +=cut + +int +resultStatus(result) + CODE: + PGresult *res = getpgresult(ST(0)); + + /* believing the reuslt */ + RETVAL = PQresultStatus(res); + + OUTPUT: + RETVAL + + +=pod + +=item $client->ntuples() + +Get the number of rows in the query result. +=cut + +int +ntuples(result) + CODE: + PGresult *res = getpgresult(ST(0)); + + RETVAL = PQntuples(res); + + OUTPUT: + RETVAL + +=pod + +=item $client->nfields() + +Get the number of columns in each row of the query result. +=cut + +int +nfields(result) + CODE: + PGresult *res = getpgresult(ST(0)); + + RETVAL = PQnfields(res); + + OUTPUT: + RETVAL + +=pod + +=item $client->getvalue() + +Returns a single field value of one row of a PgResult. +Row nad column numbers start at 0. +=cut + +char * +getvalue(result, tup_num, field_num) + int tup_num; + int field_num; + CODE: + PGresult *res = getpgresult(ST(0)); + + RETVAL = PQgetvalue(res, tup_num, field_num); + + OUTPUT: + RETVAL + +=pod + +=item $client->getvalue() + +Returns the actual length of a field value in bytes. +Row nad column numbers start at 0. +=cut + +int +getlength(result, tup_num, field_num) + int tup_num; + int field_num; + CODE: + PGresult *res = getpgresult(ST(0)); + + RETVAL = PQgetlength(res, tup_num, field_num); + + OUTPUT: + RETVAL + +=item $client->getisnull() + +Tests a field for a null value. +Row nad column numbers start at 0. +=cut + +int +getisnull(result, tup_num, field_num) + int tup_num; + int field_num; + CODE: + PGresult *res = getpgresult(ST(0)); + + RETVAL = PQgetisnull(res, tup_num, field_num); + + OUTPUT: + RETVAL + +void +DESTROY(result) + CODE: + PGresult *res = getpgresult(ST(0)); + PQclear(res); diff --git a/src/test/perl/PostgresClient.pm b/src/test/perl/PostgresClient.pm new file mode 100644 index 0000000..b8287b9 --- /dev/null +++ b/src/test/perl/PostgresClient.pm @@ -0,0 +1,221 @@ + +=pod + +=head1 NAME + +PostgresClient - class representing PostgreSQL client interface + +=head1 SYNOPSIS + + use PostgresClient; + + my $conn = PostgresClient::connectdb(<name>, <dbname>, <PostgresNode>); + + Or + + my $conn = PostgresClient::connectdb(<name>, <dbname>, {param1 => val1, ..}); + + OR + + my $conn = PostgresClient::connectdb(<name>, <connection strting>); + + PostgresNode also provides get_new_session() to create a new session. + + # execute a query + $result = $conn->exec('query'); + + # executes a multiple query at once + $success = $conn->exec_multi('query 1', 'query 2', ...); + + # close the connection + $conn->finish(); + + # get information. + # see the corresponding functions of libpq. Several functions that + # corresponding libpq function returns a enum value returns a string + # representation + + $conn->name(); + $conn->db(); + $conn->user(); + $conn->pass(); + $conn->host(); + $conn->port(); + $conn->notice(); + $conn->clear_notice(); + $conn->status(); + $conn->transactionStatus(); + $conn->errorMessage(); + +=head1 DESCRIPTION + +PostgresClient contains a set of routines able to work as a PostgreSQL +client, allowing to connect, disconnect and send a query and receive +the result. + +=cut + +package PostgresClient; + +use 5.016003; +use strict; +use warnings; +use Carp; +use PgResult; + +require Exporter; + +our @ISA = qw(Exporter); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +# This allows declaration use PostgresClient ':all'; +# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( + CONNECTION_AUTH_OK + CONNECTION_AWAITING_RESPONSE + CONNECTION_BAD + CONNECTION_CHECK_WRITABLE + CONNECTION_CONSUME + CONNECTION_MADE + CONNECTION_NEEDED + CONNECTION_OK + CONNECTION_SETENV + CONNECTION_SSL_STARTUP + CONNECTION_STARTED + PGRES_BAD_RESPONSE + PGRES_COMMAND_OK + PGRES_COPY_BOTH + PGRES_COPY_IN + PGRES_COPY_OUT + PGRES_EMPTY_QUERY + PGRES_FATAL_ERROR + PGRES_NONFATAL_ERROR + PGRES_POLLING_ACTIVE + PGRES_POLLING_FAILED + PGRES_POLLING_OK + PGRES_POLLING_READING + PGRES_POLLING_WRITING + PGRES_SINGLE_TUPLE + PGRES_TUPLES_OK + PG_COPYRES_ATTRS + PG_COPYRES_EVENTS + PG_COPYRES_NOTICEHOOKS + PG_COPYRES_TUPLES + PQERRORS_DEFAULT + PQERRORS_TERSE + PQERRORS_VERBOSE + PQPING_NO_ATTEMPT + PQPING_NO_RESPONSE + PQPING_OK + PQPING_REJECT + PQSHOW_CONTEXT_ALWAYS + PQSHOW_CONTEXT_ERRORS + PQSHOW_CONTEXT_NEVER + PQTRANS_ACTIVE + PQTRANS_IDLE + PQTRANS_INERROR + PQTRANS_INTRANS + PQTRANS_UNKNOWN +) ] ); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw( + connectdb connectdbParams + CONNECTION_AUTH_OK + CONNECTION_AWAITING_RESPONSE + CONNECTION_BAD + CONNECTION_CHECK_WRITABLE + CONNECTION_CONSUME + CONNECTION_MADE + CONNECTION_NEEDED + CONNECTION_OK + CONNECTION_SETENV + CONNECTION_SSL_STARTUP + CONNECTION_STARTED + PGRES_BAD_RESPONSE + PGRES_COMMAND_OK + PGRES_COPY_BOTH + PGRES_COPY_IN + PGRES_COPY_OUT + PGRES_EMPTY_QUERY + PGRES_FATAL_ERROR + PGRES_NONFATAL_ERROR + PGRES_POLLING_ACTIVE + PGRES_POLLING_FAILED + PGRES_POLLING_OK + PGRES_POLLING_READING + PGRES_POLLING_WRITING + PGRES_SINGLE_TUPLE + PGRES_TUPLES_OK + PG_COPYRES_ATTRS + PG_COPYRES_EVENTS + PG_COPYRES_NOTICEHOOKS + PG_COPYRES_TUPLES + PQERRORS_DEFAULT + PQERRORS_TERSE + PQERRORS_VERBOSE + PQPING_NO_ATTEMPT + PQPING_NO_RESPONSE + PQPING_OK + PQPING_REJECT + PQSHOW_CONTEXT_ALWAYS + PQSHOW_CONTEXT_ERRORS + PQSHOW_CONTEXT_NEVER + PQTRANS_ACTIVE + PQTRANS_IDLE + PQTRANS_INERROR + PQTRANS_INTRANS + PQTRANS_UNKNOWN +); + +our $VERSION = '0.01'; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + croak("&PostgresClient::constant not defined") if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { croak $error; } + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 +#XXX if ($] >= 5.00561) { +#XXX *$AUTOLOAD = sub () { $val }; +#XXX } +#XXX else { + *$AUTOLOAD = sub { $val }; +#XXX } + } + goto &$AUTOLOAD; +} + +require XSLoader; +XSLoader::load('PostgresClient', $VERSION); + +sub exec_multi +{ + my ($self, @commands) = @_; + + foreach my $command (@commands) + { + my $result = $self->exec($command); + + return 1 if (!defined $result || + ($result->resultStatus() != &PGRES_COMMAND_OK && + $result->resultStatus() != &PGRES_TUPLES_OK)); + } + + return 0; +} + + +1; diff --git a/src/test/perl/PostgresClient.xs b/src/test/perl/PostgresClient.xs new file mode 100644 index 0000000..768b0c4 --- /dev/null +++ b/src/test/perl/PostgresClient.xs @@ -0,0 +1,473 @@ +/********************************************************************** + * PostgresClient.xs + * + * Simple client interface for perl + * + * src/test/perl/PostgresClient.xs + * + **********************************************************************/ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + +/* conflicts with the same symbol defined by postgres_fe.h */ +#undef _ + +#include "libpq-fe.h" +#include "const-c.inc" + +typedef struct clientobj +{ + char *name; + PGconn *conn; + char *notice; +} clientobj; + +static clientobj *getclientobj(SV *connsvrv, int ignore_err); +static void PgClientNoticeProcessor(void *clientobj, const char *message); + +static clientobj * +getclientobj(SV *connsvrv, int ignore_err) +{ + SV *connsvsv = SvRV(connsvrv); + + if (!sv_isobject(connsvrv) || !sv_isa(connsvrv, "PostgresClient")) + { + if (!ignore_err) + croak("unexpected parameter"); + } + + return (clientobj *) SvIV(connsvsv); +} + +static void +PgClientNoticeProcessor(void *clobj, const char *message) +{ + clientobj *obj = (clientobj *) clobj; + char *notice = obj->notice; + int len = 0; + + if (notice) + len = strlen(notice); + len += strlen(message); + obj->notice = malloc(len + 1); + obj->notice[0] = 0; + if (notice) + { + strcpy(obj->notice, notice); + free(notice); + } + strcat(obj->notice, message); +} + +MODULE = PostgresClient PACKAGE = PostgresClient +INCLUDE: const-xs.inc +PROTOTYPES: ENABLE + +=pod + +=item PostgresClient::connectdb(name, dbname[, params...]) + +Create a new connection as specified. + +name: the name of this connection +dbname: the name of the database to connect + this can be a connection string but the behavior is not defined + when params is specified together. +params: reference to connection parameter hash or PostgresNode object. +=cut + +SV * +connectdb(name, dbname, ...) + char *name; + char *dbname; + CODE: + PGconn *conn; + clientobj *obj; + SV *options_sv; + char *connstr; + const char **keywords = NULL; + const char **values = NULL; + int nparams = 0; + + if (items < 1) + croak("Usage: PostgresClient->connectdb(name, dbname, options|node)"); + + /* build parameter list for PQconnectdbParmas() */ + if (items >= 3) + { + options_sv = ST(2); + + if (sv_isobject(options_sv)) + { + PQconninfoOption *options; + PQconninfoOption *option; + char *errmsg; + int i; + + /* ask PostgresNode for connection string */ + if (!sv_isa(options_sv, "PostgresNode")) + croak("node is not a PostgresNode object"); + + PUSHMARK(SP); + XPUSHs(options_sv); + XPUSHs(sv_2mortal(newSVpv(dbname, 0))); + PUTBACK; + if (call_method("connstr", G_SCALAR) != 1) + croak("failed to call PostgresNode::connstr"); + connstr = SvPV_nolen(POPs); + + options = PQconninfoParse(connstr, &errmsg); + + if (!options) + croak("No options?"); + + for (i = 0, option = options ; option->keyword ; option++) + { + if (option->val) + i++; + } + i += 2; /* room for dbname and terminator */ + + keywords = (const char **) malloc(sizeof(char *) * i); + values = (const char **) malloc(sizeof(char *) * i); + + for (i = 0, option = options ; option->keyword ; option++) + { + if (!option->val || strcmp(option->keyword, "dbname") == 0) + continue; + + keywords[i] = strdup(option->keyword); + if (option->val) + values[i] = strdup(option->val); + else + values[i] = NULL; + i++; + } + PQconninfoFree(options); + nparams = i; + } + else if (SvROK(options_sv) && SvTYPE(SvRV(options_sv)) == SVt_PVHV) + { + HV *params_hv = (HV *) SvRV(options_sv); + HE *hent; + int i; + + nparams = hv_iterinit(params_hv) + 2; + keywords = (const char **) malloc(sizeof(char *) * nparams); + values = (const char **) malloc(sizeof(char *) * nparams); + + i = 0; + while ((hent = hv_iternext(params_hv)) != NULL) + { + I32 keylen; + STRLEN vallen; + SV *valsv; + char *keystr, *valstr; + + keystr = hv_iterkey(hent, &keylen); + + /* ignore dbname */ + if (strncmp(keystr, "dbname", keylen) == 0) + continue; + + valsv = hv_iterval(params_hv, hent); + if (SvOK(valsv)) + { + keywords[i] = strndup(keystr, keylen); + valstr = SvPV(valsv, vallen); + values[i] = strndup(valstr, vallen); + i++; + } + } + nparams = i; + } + else + croak("Invalid paralmeter options"); + } + else + { + keywords = (const char **) malloc(sizeof(char *) * 2); + values = (const char **) malloc(sizeof(char *) * 2); + } + + keywords[nparams] = strndup("dbname", 6); + values[nparams] = strdup(dbname); + keywords[++nparams] = 0; + + /* Connect using the parameters */ + conn = PQconnectdbParams(keywords, values, true); + if (!conn) + croak("connection failure"); + if (PQstatus(conn) == CONNECTION_BAD) + croak("connection failure: %s", PQerrorMessage(conn)); + + obj = malloc(sizeof(clientobj)); + obj->name = strdup(name); + obj->conn = conn; + obj->notice = NULL; + + PQsetNoticeProcessor(conn, PgClientNoticeProcessor, (void *)obj); + RETVAL = sv_setref_pv(newSV(0), "PostgresClient", (void *) obj); + + OUTPUT: + RETVAL + +=pod + +=item $client->name() + +Get the name of this connection. +=cut + +char * +name(connsvrv) + CODE: + RETVAL = getclientobj(ST(0), 0)->name; + + OUTPUT: + RETVAL + +=pod + +=item $client->db() + +Get the database name of the connection. +=cut + +char * +db(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + RETVAL = PQdb(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->user() + +Get the user name of the connection. +=cut + +char * +user(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + RETVAL = PQuser(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->pass() + +Get the password of the connection. +=cut + +char * +pass(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + RETVAL = PQpass(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->host() + +Get the server host name of the connection. +=cut + +char * +host(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + RETVAL = PQhost(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->port() + +Get the port of the connection. +=cut + +char * +port(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + RETVAL = PQport(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->notice() + +Get the notice messages accumulated in the connection. +=cut + +char * +notice(connsvrv) + CODE: + clientobj *obj = getclientobj(ST(0), 0); + if (obj->notice) + RETVAL = strdup(obj->notice); + else + RETVAL = NULL; + + OUTPUT: + RETVAL + +=pod + +=item $client->clear_notice() + +Clear the notice messages of the connection. +=cut + +void +clear_notice(connsvrv) + CODE: + clientobj *obj = getclientobj(ST(0), 0); + if (obj->notice) + { + free(obj->notice); + obj->notice = NULL; + } + +=pod + +=item $client->status() + +Get the status of the connection. +=cut + +int +status(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + + RETVAL = PQstatus(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->transactionStatus() + +Get the transaction status of the connection. +=cut + +int +transactionStatus(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + + RETVAL = PQtransactionStatus(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->errorMessage() + +Get the error message of the connection. +=cut + +char * +errorMessage(connsvrv) + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + + RETVAL = PQerrorMessage(conn); + + OUTPUT: + RETVAL + +=pod + +=item $client->finish() + +Properly close the connection. +=cut + +void +finish(connsvrv) + CODE: + SV *connsvrv = ST(0); + SV *connivsv = SvRV(connsvrv); + clientobj *obj; + + if (!sv_isobject(connsvrv) || !sv_isa(connsvrv, "PostgresClient")) + croak("unexpected parameter"); + obj = (clientobj *) SvIV(connivsv); + if (obj) + { + PQfinish(obj->conn); + free(obj->name); + if (obj->notice) + free(obj->notice); + free(obj); + sv_setiv(connivsv, 0); + } + +void +DESTROY(connsvrv) + CODE: + SV *connsvrv = ST(0); + + /* Silently ignore unexpected parameters */ + if (sv_isobject(connsvrv) && sv_isa(connsvrv, "PostgresClient")) + { + clientobj *obj = (clientobj *) SvIV(SvRV(connsvrv)); + if (obj) + { + if (obj->conn) + PQfinish(obj->conn); + free(obj->name); + if (obj->notice) + free(obj->notice); + free(obj); + } + } + + +=pod + +=item $client->exec() + +Execute a query and return the result. +=cut + +SV * +exec(connsvrv, query) + char *query; + CODE: + PGconn *conn = getclientobj(ST(0), 0)->conn; + PGresult *res; + + if (!conn) + croak("connection closed"); + + res = PQexec(conn, query); + + if (res) + RETVAL = sv_setref_pv(newSV(0), "PgResult", (void *) res); + else + RETVAL = &PL_sv_undef; + + OUTPUT: + RETVAL diff --git a/src/test/perl/PostgresNode.pm b/src/test/perl/PostgresNode.pm index 93faadc..b7dcb04 100644 --- a/src/test/perl/PostgresNode.pm +++ b/src/test/perl/PostgresNode.pm @@ -82,6 +82,7 @@ package PostgresNode; use strict; use warnings; +use PostgresClient; use Config; use Cwd; use Exporter 'import'; @@ -1259,6 +1260,26 @@ sub psql =pod +=item $node->get_new_session($dbname, $session_name) + +Create a new sesson to the database $dbname. $session_name is a name +of the session. Returns a PostgresClient object. +=cut + + +sub get_new_session +{ + my ($self, $dbname, $sessionname) = @_; + + $sessionname = 'unnamed connection' if (!defined $sessionname); + my $client = + PostgresClient::connectdb($sessionname, $self->connstr($dbname)); + + return $client; +} + +=pod + =item $node->poll_query_until($dbname, $query [, $expected ]) Run B<$query> repeatedly, until it returns the B<$expected> result diff --git a/src/test/perl/const-c.inc b/src/test/perl/const-c.inc new file mode 100644 index 0000000..669c21c --- /dev/null +++ b/src/test/perl/const-c.inc @@ -0,0 +1,544 @@ +#define PERL_constant_NOTFOUND 1 +#define PERL_constant_NOTDEF 2 +#define PERL_constant_ISIV 3 +#define PERL_constant_ISNO 4 +#define PERL_constant_ISNV 5 +#define PERL_constant_ISPV 6 +#define PERL_constant_ISPVN 7 +#define PERL_constant_ISSV 8 +#define PERL_constant_ISUNDEF 9 +#define PERL_constant_ISUV 10 +#define PERL_constant_ISYES 11 + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif + +static int +constant_13 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CONNECTION_OK PGRES_COPY_IN PQPING_REJECT */ + /* Offset 2 gives the best switch position. */ + switch (name[2]) { + case 'N': + if (memEQ(name, "CONNECTION_OK", 13)) { + /* ^ */ + *iv_return = CONNECTION_OK; + return PERL_constant_ISIV; + } + break; + case 'P': + if (memEQ(name, "PQPING_REJECT", 13)) { + /* ^ */ + *iv_return = PQPING_REJECT; + return PERL_constant_ISIV; + } + break; + case 'R': + if (memEQ(name, "PGRES_COPY_IN", 13)) { + /* ^ */ + *iv_return = PGRES_COPY_IN; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_14 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CONNECTION_BAD PGRES_COPY_OUT PQERRORS_TERSE PQTRANS_ACTIVE */ + /* Offset 2 gives the best switch position. */ + switch (name[2]) { + case 'E': + if (memEQ(name, "PQERRORS_TERSE", 14)) { + /* ^ */ + *iv_return = PQERRORS_TERSE; + return PERL_constant_ISIV; + } + break; + case 'N': + if (memEQ(name, "CONNECTION_BAD", 14)) { + /* ^ */ + *iv_return = CONNECTION_BAD; + return PERL_constant_ISIV; + } + break; + case 'R': + if (memEQ(name, "PGRES_COPY_OUT", 14)) { + /* ^ */ + *iv_return = PGRES_COPY_OUT; + return PERL_constant_ISIV; + } + break; + case 'T': + if (memEQ(name, "PQTRANS_ACTIVE", 14)) { + /* ^ */ + *iv_return = PQTRANS_ACTIVE; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_15 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CONNECTION_MADE PGRES_COPY_BOTH PGRES_TUPLES_OK PQTRANS_INERROR + PQTRANS_INTRANS PQTRANS_UNKNOWN */ + /* Offset 14 gives the best switch position. */ + switch (name[14]) { + case 'E': + if (memEQ(name, "CONNECTION_MAD", 14)) { + /* E */ + *iv_return = CONNECTION_MADE; + return PERL_constant_ISIV; + } + break; + case 'H': + if (memEQ(name, "PGRES_COPY_BOT", 14)) { + /* H */ + *iv_return = PGRES_COPY_BOTH; + return PERL_constant_ISIV; + } + break; + case 'K': + if (memEQ(name, "PGRES_TUPLES_O", 14)) { + /* K */ + *iv_return = PGRES_TUPLES_OK; + return PERL_constant_ISIV; + } + break; + case 'N': + if (memEQ(name, "PQTRANS_UNKNOW", 14)) { + /* N */ + *iv_return = PQTRANS_UNKNOWN; + return PERL_constant_ISIV; + } + break; + case 'R': + if (memEQ(name, "PQTRANS_INERRO", 14)) { + /* R */ + *iv_return = PQTRANS_INERROR; + return PERL_constant_ISIV; + } + break; + case 'S': + if (memEQ(name, "PQTRANS_INTRAN", 14)) { + /* S */ + *iv_return = PQTRANS_INTRANS; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_16 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + PGRES_COMMAND_OK PGRES_POLLING_OK PG_COPYRES_ATTRS PQERRORS_DEFAULT + PQERRORS_VERBOSE */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'D': + if (memEQ(name, "PQERRORS_DEFAULT", 16)) { + /* ^ */ + *iv_return = PQERRORS_DEFAULT; + return PERL_constant_ISIV; + } + break; + case 'L': + if (memEQ(name, "PGRES_POLLING_OK", 16)) { + /* ^ */ + *iv_return = PGRES_POLLING_OK; + return PERL_constant_ISIV; + } + break; + case 'M': + if (memEQ(name, "PGRES_COMMAND_OK", 16)) { + /* ^ */ + *iv_return = PGRES_COMMAND_OK; + return PERL_constant_ISIV; + } + break; + case 'S': + if (memEQ(name, "PG_COPYRES_ATTRS", 16)) { + /* ^ */ +#ifdef PG_COPYRES_ATTRS + *iv_return = PG_COPYRES_ATTRS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'V': + if (memEQ(name, "PQERRORS_VERBOSE", 16)) { + /* ^ */ + *iv_return = PQERRORS_VERBOSE; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_17 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CONNECTION_NEEDED CONNECTION_SETENV PGRES_EMPTY_QUERY PGRES_FATAL_ERROR + PG_COPYRES_EVENTS PG_COPYRES_TUPLES PQPING_NO_ATTEMPT */ + /* Offset 14 gives the best switch position. */ + switch (name[14]) { + case 'D': + if (memEQ(name, "CONNECTION_NEEDED", 17)) { + /* ^ */ + *iv_return = CONNECTION_NEEDED; + return PERL_constant_ISIV; + } + break; + case 'E': + if (memEQ(name, "CONNECTION_SETENV", 17)) { + /* ^ */ + *iv_return = CONNECTION_SETENV; + return PERL_constant_ISIV; + } + if (memEQ(name, "PGRES_EMPTY_QUERY", 17)) { + /* ^ */ + *iv_return = PGRES_EMPTY_QUERY; + return PERL_constant_ISIV; + } + break; + case 'L': + if (memEQ(name, "PG_COPYRES_TUPLES", 17)) { + /* ^ */ +#ifdef PG_COPYRES_TUPLES + *iv_return = PG_COPYRES_TUPLES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "PQPING_NO_ATTEMPT", 17)) { + /* ^ */ + *iv_return = PQPING_NO_ATTEMPT; + return PERL_constant_ISIV; + } + break; + case 'N': + if (memEQ(name, "PG_COPYRES_EVENTS", 17)) { + /* ^ */ +#ifdef PG_COPYRES_EVENTS + *iv_return = PG_COPYRES_EVENTS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "PGRES_FATAL_ERROR", 17)) { + /* ^ */ + *iv_return = PGRES_FATAL_ERROR; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_18 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CONNECTION_AUTH_OK CONNECTION_CONSUME CONNECTION_STARTED + PGRES_BAD_RESPONSE PGRES_SINGLE_TUPLE PQPING_NO_RESPONSE */ + /* Offset 14 gives the best switch position. */ + switch (name[14]) { + case 'H': + if (memEQ(name, "CONNECTION_AUTH_OK", 18)) { + /* ^ */ + *iv_return = CONNECTION_AUTH_OK; + return PERL_constant_ISIV; + } + break; + case 'O': + if (memEQ(name, "PGRES_BAD_RESPONSE", 18)) { + /* ^ */ + *iv_return = PGRES_BAD_RESPONSE; + return PERL_constant_ISIV; + } + if (memEQ(name, "PQPING_NO_RESPONSE", 18)) { + /* ^ */ + *iv_return = PQPING_NO_RESPONSE; + return PERL_constant_ISIV; + } + break; + case 'R': + if (memEQ(name, "CONNECTION_STARTED", 18)) { + /* ^ */ + *iv_return = CONNECTION_STARTED; + return PERL_constant_ISIV; + } + break; + case 'S': + if (memEQ(name, "CONNECTION_CONSUME", 18)) { + /* ^ */ + *iv_return = CONNECTION_CONSUME; + return PERL_constant_ISIV; + } + break; + case 'U': + if (memEQ(name, "PGRES_SINGLE_TUPLE", 18)) { + /* ^ */ + *iv_return = PGRES_SINGLE_TUPLE; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_20 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + PGRES_NONFATAL_ERROR PGRES_POLLING_ACTIVE PGRES_POLLING_FAILED + PQSHOW_CONTEXT_NEVER */ + /* Offset 15 gives the best switch position. */ + switch (name[15]) { + case 'A': + if (memEQ(name, "PGRES_POLLING_FAILED", 20)) { + /* ^ */ + *iv_return = PGRES_POLLING_FAILED; + return PERL_constant_ISIV; + } + break; + case 'C': + if (memEQ(name, "PGRES_POLLING_ACTIVE", 20)) { + /* ^ */ + *iv_return = PGRES_POLLING_ACTIVE; + return PERL_constant_ISIV; + } + break; + case 'E': + if (memEQ(name, "PGRES_NONFATAL_ERROR", 20)) { + /* ^ */ + *iv_return = PGRES_NONFATAL_ERROR; + return PERL_constant_ISIV; + } + break; + case 'N': + if (memEQ(name, "PQSHOW_CONTEXT_NEVER", 20)) { + /* ^ */ + *iv_return = PQSHOW_CONTEXT_NEVER; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_21 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + PGRES_POLLING_READING PGRES_POLLING_WRITING PQSHOW_CONTEXT_ALWAYS + PQSHOW_CONTEXT_ERRORS */ + /* Offset 16 gives the best switch position. */ + switch (name[16]) { + case 'A': + if (memEQ(name, "PGRES_POLLING_READING", 21)) { + /* ^ */ + *iv_return = PGRES_POLLING_READING; + return PERL_constant_ISIV; + } + break; + case 'I': + if (memEQ(name, "PGRES_POLLING_WRITING", 21)) { + /* ^ */ + *iv_return = PGRES_POLLING_WRITING; + return PERL_constant_ISIV; + } + break; + case 'L': + if (memEQ(name, "PQSHOW_CONTEXT_ALWAYS", 21)) { + /* ^ */ + *iv_return = PQSHOW_CONTEXT_ALWAYS; + return PERL_constant_ISIV; + } + break; + case 'R': + if (memEQ(name, "PQSHOW_CONTEXT_ERRORS", 21)) { + /* ^ */ + *iv_return = PQSHOW_CONTEXT_ERRORS; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { + /* Initially switch on the length of the name. */ + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!/usr/bin/perl -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +my $types = {map {($_, 1)} qw(IV)}; +my @names = (qw(PG_COPYRES_ATTRS PG_COPYRES_EVENTS PG_COPYRES_NOTICEHOOKS + PG_COPYRES_TUPLES), + {name=>"CONNECTION_AUTH_OK", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_AWAITING_RESPONSE", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_BAD", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_CHECK_WRITABLE", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_CONSUME", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_MADE", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_NEEDED", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_OK", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_SETENV", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_SSL_STARTUP", type=>"IV", macro=>"1"}, + {name=>"CONNECTION_STARTED", type=>"IV", macro=>"1"}, + {name=>"PGRES_BAD_RESPONSE", type=>"IV", macro=>"1"}, + {name=>"PGRES_COMMAND_OK", type=>"IV", macro=>"1"}, + {name=>"PGRES_COPY_BOTH", type=>"IV", macro=>"1"}, + {name=>"PGRES_COPY_IN", type=>"IV", macro=>"1"}, + {name=>"PGRES_COPY_OUT", type=>"IV", macro=>"1"}, + {name=>"PGRES_EMPTY_QUERY", type=>"IV", macro=>"1"}, + {name=>"PGRES_FATAL_ERROR", type=>"IV", macro=>"1"}, + {name=>"PGRES_NONFATAL_ERROR", type=>"IV", macro=>"1"}, + {name=>"PGRES_POLLING_ACTIVE", type=>"IV", macro=>"1"}, + {name=>"PGRES_POLLING_FAILED", type=>"IV", macro=>"1"}, + {name=>"PGRES_POLLING_OK", type=>"IV", macro=>"1"}, + {name=>"PGRES_POLLING_READING", type=>"IV", macro=>"1"}, + {name=>"PGRES_POLLING_WRITING", type=>"IV", macro=>"1"}, + {name=>"PGRES_SINGLE_TUPLE", type=>"IV", macro=>"1"}, + {name=>"PGRES_TUPLES_OK", type=>"IV", macro=>"1"}, + {name=>"PQERRORS_DEFAULT", type=>"IV", macro=>"1"}, + {name=>"PQERRORS_TERSE", type=>"IV", macro=>"1"}, + {name=>"PQERRORS_VERBOSE", type=>"IV", macro=>"1"}, + {name=>"PQPING_NO_ATTEMPT", type=>"IV", macro=>"1"}, + {name=>"PQPING_NO_RESPONSE", type=>"IV", macro=>"1"}, + {name=>"PQPING_OK", type=>"IV", macro=>"1"}, + {name=>"PQPING_REJECT", type=>"IV", macro=>"1"}, + {name=>"PQSHOW_CONTEXT_ALWAYS", type=>"IV", macro=>"1"}, + {name=>"PQSHOW_CONTEXT_ERRORS", type=>"IV", macro=>"1"}, + {name=>"PQSHOW_CONTEXT_NEVER", type=>"IV", macro=>"1"}, + {name=>"PQTRANS_ACTIVE", type=>"IV", macro=>"1"}, + {name=>"PQTRANS_IDLE", type=>"IV", macro=>"1"}, + {name=>"PQTRANS_INERROR", type=>"IV", macro=>"1"}, + {name=>"PQTRANS_INTRANS", type=>"IV", macro=>"1"}, + {name=>"PQTRANS_UNKNOWN", type=>"IV", macro=>"1"}); + +print constant_types(), "\n"; # macro defs +foreach (C_constant ("PostgresClient", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "\n#### XS Section:\n"; +print XS_constant ("PostgresClient", $types); +__END__ + */ + + switch (len) { + case 9: + if (memEQ(name, "PQPING_OK", 9)) { + *iv_return = PQPING_OK; + return PERL_constant_ISIV; + } + break; + case 12: + if (memEQ(name, "PQTRANS_IDLE", 12)) { + *iv_return = PQTRANS_IDLE; + return PERL_constant_ISIV; + } + break; + case 13: + return constant_13 (aTHX_ name, iv_return); + break; + case 14: + return constant_14 (aTHX_ name, iv_return); + break; + case 15: + return constant_15 (aTHX_ name, iv_return); + break; + case 16: + return constant_16 (aTHX_ name, iv_return); + break; + case 17: + return constant_17 (aTHX_ name, iv_return); + break; + case 18: + return constant_18 (aTHX_ name, iv_return); + break; + case 20: + return constant_20 (aTHX_ name, iv_return); + break; + case 21: + return constant_21 (aTHX_ name, iv_return); + break; + case 22: + /* Names all of length 22. */ + /* CONNECTION_SSL_STARTUP PG_COPYRES_NOTICEHOOKS */ + /* Offset 21 gives the best switch position. */ + switch (name[21]) { + case 'P': + if (memEQ(name, "CONNECTION_SSL_STARTU", 21)) { + /* P */ + *iv_return = CONNECTION_SSL_STARTUP; + return PERL_constant_ISIV; + } + break; + case 'S': + if (memEQ(name, "PG_COPYRES_NOTICEHOOK", 21)) { + /* S */ +#ifdef PG_COPYRES_NOTICEHOOKS + *iv_return = PG_COPYRES_NOTICEHOOKS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + case 25: + if (memEQ(name, "CONNECTION_CHECK_WRITABLE", 25)) { + *iv_return = CONNECTION_CHECK_WRITABLE; + return PERL_constant_ISIV; + } + break; + case 28: + if (memEQ(name, "CONNECTION_AWAITING_RESPONSE", 28)) { + *iv_return = CONNECTION_AWAITING_RESPONSE; + return PERL_constant_ISIV; + } + break; + } + return PERL_constant_NOTFOUND; +} diff --git a/src/test/perl/const-xs.inc b/src/test/perl/const-xs.inc new file mode 100644 index 0000000..37025a6 --- /dev/null +++ b/src/test/perl/const-xs.inc @@ -0,0 +1,90 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + /* const char *pv; Uncomment this if you need to return PVs */ + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = + sv_2mortal(newSVpvf("%s is not a valid PostgresClient macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined PostgresClient macro %s, used", + s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + /* Uncomment this if you need to return PVs + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; */ + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing PostgresClient macro %s, used", + type, s)); + PUSHs(sv); + } -- 2.9.2 From e7977093b47fdf6373414cf5a0404085cecde363 Mon Sep 17 00:00:00 2001 From: Kyotaro Horiguchi <horiguchi.kyotaro@lab.ntt.co.jp> Date: Thu, 28 Dec 2017 17:03:52 +0900 Subject: [PATCH 2/2] Sample prove_check of PostgresClient. --- contrib/postgres_fdw/Makefile | 5 +-- contrib/postgres_fdw/t/001_reconnection.pl | 63 ++++++++++++++++++++++++++++++ 2 files changed, 64 insertions(+), 4 deletions(-) create mode 100644 contrib/postgres_fdw/t/001_reconnection.pl diff --git a/contrib/postgres_fdw/Makefile b/contrib/postgres_fdw/Makefile index 240bd19..bfebc5f 100644 --- a/contrib/postgres_fdw/Makefile +++ b/contrib/postgres_fdw/Makefile @@ -24,8 +24,5 @@ include $(top_builddir)/src/Makefile.global include $(top_srcdir)/contrib/contrib-global.mk endif -check: +prove_check: $(prove_check) - -installcheck: - $(prove_installcheck) diff --git a/contrib/postgres_fdw/t/001_reconnection.pl b/contrib/postgres_fdw/t/001_reconnection.pl new file mode 100644 index 0000000..3b81075 --- /dev/null +++ b/contrib/postgres_fdw/t/001_reconnection.pl @@ -0,0 +1,63 @@ +# Minimal test testing reconnection +use strict; +use warnings; +use PostgresNode; +use PostgresClient; +use TestLib; +use Test::More tests => 5; + +# start a server +my $server = get_new_node('server'); +$server->init(); +$server->start; +my $session1 = $server->get_new_session('postgres', 'session1'); +my $session2 = $server->get_new_session('postgres', 'session2'); +my $dbname = $session1->db(); +my $port = $session1->port(); + +ok (!$session1->exec_multi( + "CREATE EXTENSION postgres_fdw;", + "CREATE SERVER loopback FOREIGN DATA WRAPPER postgres_fdw OPTIONS (dbname \'$dbname\', port \'$port\');", + "CREATE USER MAPPING FOR CURRENT_USER SERVER loopback;", + "CREATE TABLE lt1 (c1 int);", + "INSERT INTO lt1 VALUES (1);", + "CREATE FOREIGN TABLE ft1 (c1 int) SERVER loopback OPTIONS (table_name 'lt1');", + "SET client_min_messages to DEBUG3;"), + 'setting up'); + +$session1->exec("BEGIN;"); + +my $result = $session1->exec("SELECT c1 FROM ft1 LIMIT 1;"); + +# check if the connection has been made +ok($session1->notice() =~ /DEBUG: *new postgres_fdw connection 0x[[:xdigit:]]+/, + "creating new fdw connection"); + +# change server host +$session2->exec_multi( + "ALTER SERVER loopback OPTIONS (ADD host 'hoge')", + "ALTER SERVER loopback OPTIONS (DROP host)"); + +# and no more +$session1->clear_notice(); +$result = $session1->exec("SELECT c1 FROM ft1 LIMIT 1;"); +ok($session1->notice() !~ /DEBUG: *closing connection 0x[[:xdigit:]]+ for option changes to take effect/, + 'check if no disconnection happens within a transaction'); + +$session1->exec("COMMIT;"); + +# access to ft1 here causes reconnection +$session1->clear_notice(); +$result = $session1->exec("SELECT c1 FROM ft1 LIMIT 1;"); +ok($session1->notice() =~ /DEBUG: *closing connection 0x[[:xdigit:]]+ for option changes to take effect\nDEBUG: *new postgres_fdwconnection 0x[[:xdigit:]]+/, + 'reconnection by option change happens after the end of the transactin'); + +# and no more +$session1->clear_notice(); +$result = $session1->exec("SELECT c1 FROM ft1 LIMIT 1;"); +ok($session1->notice() !~ /DEBUG: *closing connection 0x[[:xdigit:]]+ for option changes to take effect/, + 'no disconnection without option change'); + +$session1->finish; +$session2->finish; +$server->stop; -- 2.9.2
pgsql-hackers by date: