Thread: TAP test module - PostgresClient
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
On 28 December 2017 at 16:31, Kyotaro HORIGUCHI <horiguchi.kyotaro@lab.ntt.co.jp> wrote:
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.
If you mean
then it says
"The GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or
The "Artistic License" which comes with Perl."
IOW, it's under the Perl license. These are the exact same terms as used by Perl its self:
so I don't think there's any need for hesitation in using it.
But... I wonder if time is better spent figuring out what's wrong with IPC::Run on Win32 so we can use psql properly. That way we don't start writing a new test-only client, and we expand our psql coverage too.
One thing that'd help a lot, IMO, would be teaching psql how to offer a better batch mode interface, where you can clearly determine:
- end of resultset
- start and end of error msg
- end of query (psql has reported any errors and results and is ready for a new query)
I'm sure this would offer benefits well beyond testing, too, given the number of pretty hairy scripts I've seen with psql and 'expect' etc.
Another option might be to teach the TAP infrastructure and the buildfarm client how to fetch cpanminus and build DBD::Pg against our build-tree, so we could use Perl DBI. I know prior discussions of relying on DBI and DBD::Pg have stalled on arguments that we shouldn't require buildfarm admins and especially random people running the test suite to install and maintain them. But if we teach the test suite how to build and run them scoped to the current Pg build using PERL5LIB, users wouldn't *have* to. Internet access could be a sticking point for some, but the same would be true of using something like PgPP unless we bundled it in the Pg tree.
Craig Ringer <craig@2ndquadrant.com> writes:
> Another option might be to teach the TAP infrastructure and the buildfarm
> client how to fetch cpanminus and build DBD::Pg against our build-tree, so
> we could use Perl DBI.
As a buildfarm owner, I'd take a *really* dim view of the buildfarm
trying to auto-fetch code off the internet. As a developer, the
idea that "make check-world" would try to do that is even scarier.
Buildfarm owners are likely to have taken at least some steps to
sandbox their builds, but developers not so much.
I do not think we should even think about going there.
Your thoughts about making psql have some more automation-friendly
output formats seem worth pursuing though.
regards, tom lane
On Thu, December 28, 2017 10:14 pm, Tom Lane wrote: > Craig Ringer <craig@2ndquadrant.com> writes: >> Another option might be to teach the TAP infrastructure and the >> buildfarm >> client how to fetch cpanminus and build DBD::Pg against our build-tree, >> so >> we could use Perl DBI. > > As a buildfarm owner, I'd take a *really* dim view of the buildfarm > trying to auto-fetch code off the internet. As a developer, the > idea that "make check-world" would try to do that is even scarier. > Buildfarm owners are likely to have taken at least some steps to > sandbox their builds, but developers not so much. > > I do not think we should even think about going there. Well, while I couldn't agree more on the "running code from the internet is dangerous" thing, there are a few points for it, tho: * if you use Perl modules on your system, you are likely doing already, anyway, as the Perl modules come, you guessed it, from the internet :) Just because a random $PackageMaintainer signed it does mean it is really safe. * And a lot of Perl modules are not in say, Debian repositories, so you need to use CPAN (or re-invent everything). Unfortunately, the trend for other languages seems to go into the same direction, with Ruby gems, the python package manager, and almost everybody else re-inventing their own packaging system, often poorly. So you might already have fallen in the trap of "use random code from the internet". (Of course, that is not really an argument for doing it, too...) * the other option seems to be "re-invent the wheel, again, locally", which isn't always the best, either. I do agree tho that having "setup" or "make check" auto-fetching stuff from the internet is not a good idea, however. Mostly because it becomes suddenly much harder to run in closed networks w/o access and such side-loading installations can bypass your systems packaging system, which doesn't sound good, either. OTOH, it is possible to setup local repositories, or maybe even pre-bundling modules into some sort of "approved TAP bundle" hosted on an official server. The last resort would be to pre-bundle the wanted modules, but this has the risk of outdating them fast. Plus, pre-bundled modules are not more security vetted than the ones from the internet, so you might as well use the CPAN version directly. The best course seems to me to have dependencies on the OS packackes for the Perl modules you want to use. Not sure, however, if the build farm client has "proper" Debian etc. packages and if it is even possible to add these dependencies in this way. Best wishes, Tels
On 12/29/2017 08:12 AM, Tels wrote: > On Thu, December 28, 2017 10:14 pm, Tom Lane wrote: >> Craig Ringer <craig@2ndquadrant.com> writes: >>> Another option might be to teach the TAP infrastructure and the >>> buildfarm >>> client how to fetch cpanminus and build DBD::Pg against our build-tree, >>> so >>> we could use Perl DBI. >> As a buildfarm owner, I'd take a *really* dim view of the buildfarm >> trying to auto-fetch code off the internet. As a developer, the >> idea that "make check-world" would try to do that is even scarier. >> Buildfarm owners are likely to have taken at least some steps to >> sandbox their builds, but developers not so much. >> >> I do not think we should even think about going there. > Well, while I couldn't agree more on the "running code from the internet > is dangerous" thing, there are a few points for it, tho: > > * if you use Perl modules on your system, you are likely doing already, > anyway, as the Perl modules come, you guessed it, from the internet :) > Just because a random $PackageMaintainer signed it does mean it is really > safe. > > * And a lot of Perl modules are not in say, Debian repositories, so you > need to use CPAN (or re-invent everything). Unfortunately, the trend for > other languages seems to go into the same direction, with Ruby gems, the > python package manager, and almost everybody else re-inventing their own > packaging system, often poorly. So you might already have fallen in the > trap of "use random code from the internet". (Of course, that is not > really an argument for doing it, too...) > > * the other option seems to be "re-invent the wheel, again, locally", > which isn't always the best, either. > > I do agree tho that having "setup" or "make check" auto-fetching stuff > from the internet is not a good idea, however. Mostly because it becomes > suddenly much harder to run in closed networks w/o access and such > side-loading installations can bypass your systems packaging system, which > doesn't sound good, either. > > OTOH, it is possible to setup local repositories, or maybe even > pre-bundling modules into some sort of "approved TAP bundle" hosted on an > official server. > > The last resort would be to pre-bundle the wanted modules, but this has > the risk of outdating them fast. Plus, pre-bundled modules are not more > security vetted than the ones from the internet, so you might as well use > the CPAN version directly. > > The best course seems to me to have dependencies on the OS packackes for > the Perl modules you want to use. Not sure, however, if the build farm > client has "proper" Debian etc. packages and if it is even possible to add > these dependencies in this way. > The buildfarm client isn't even packaged as a CPAN module let alone as a bunch of OS-level packages (and if I supported Debian packaging I'd need to support every other packaging system on the planet too, including Windows). It's always seemed to me unnecessary to use something beyond a simple tarball for something that has a target of less than 100 tolerably savvy users and which requires no actual build. In any case, I agree with Craig that we'd be much better off spending time working out why we can't get IPC::Run to do everything we want on Windows. As for out-dating, if we used DBD::PgPP we'd not be not in great danger there - it doesn't appear to have changed for many years - latest version is dated 2010. If we were to use it we'd have a dependency on DBI, but that in itself doesn't seem a great burden. cheers andrew -- Andrew Dunstan https://www.2ndQuadrant.com PostgreSQL Development, 24x7 Support, Remote DBA, Training & Services
Andrew Dunstan <andrew.dunstan@2ndquadrant.com> writes:
> As for out-dating, if we used DBD::PgPP we'd not be not in great danger
> there - it doesn't appear to have changed for many years - latest
> version is dated 2010. If we were to use it we'd have a dependency on
> DBI, but that in itself doesn't seem a great burden.
[ blowing the dust off my old red fedora... ] Actually, there's a
different problem with this proposal: you can bet that DBD::Pg has got a
build dependency on Postgres. If Postgres starts to depend on DBD::Pg
then we've created circular-dependency hell for packagers. We could only
make that work if we carefully kept the DBD::Pg requirement *out* of
"make check" and anything else that a packager might care to run during
package sanity checks. I suppose maybe we could live with a restriction
like that, if we treat this like the SSL tests as something that doesn't
get run except by special manual invocation --- but that'd reduce its
utility greatly don't you think? And I fear there would be quite a risk
of somebody breaking the restriction because they weren't thinking about
it. I note that there are no buildfarm members running any distro
packaging script, so we wouldn't find out about unintended-dependency bugs
until packagers were trying to build a release.
I much prefer the other line of thought about doing whatever we need
to do to make psql workable for the desired type of tests. Or just
write a bespoke testing tool.
regards, tom lane
On 12/30/2017 10:45 AM, Tom Lane wrote: > Andrew Dunstan <andrew.dunstan@2ndquadrant.com> writes: >> As for out-dating, if we used DBD::PgPP we'd not be not in great danger >> there - it doesn't appear to have changed for many years - latest >> version is dated 2010. If we were to use it we'd have a dependency on >> DBI, but that in itself doesn't seem a great burden. > [ blowing the dust off my old red fedora... ] Actually, there's a > different problem with this proposal: you can bet that DBD::Pg has got a > build dependency on Postgres. If Postgres starts to depend on DBD::Pg > then we've created circular-dependency hell for packagers. The Pure Perl driver has no such dependency, since it doesn't require libpq. But ... > I much prefer the other line of thought about doing whatever we need > to do to make psql workable for the desired type of tests. ... agreed ... > Or just > write a bespoke testing tool. > > ... that's pretty much where we came in. cheers andrew -- Andrew Dunstan https://www.2ndQuadrant.com PostgreSQL Development, 24x7 Support, Remote DBA, Training & Services
Thank you for the discussion. # I didn't noticed that the license has been changed. At Sat, 30 Dec 2017 14:35:27 -0500, Andrew Dunstan <andrew.dunstan@2ndquadrant.com> wrote in <4ab7546e-dd48-c985-2b26-e98d58920244@2ndQuadrant.com> > > > On 12/30/2017 10:45 AM, Tom Lane wrote: > > Andrew Dunstan <andrew.dunstan@2ndquadrant.com> writes: > >> As for out-dating, if we used DBD::PgPP we'd not be not in great danger > >> there - it doesn't appear to have changed for many years - latest > >> version is dated 2010. If we were to use it we'd have a dependency on > >> DBI, but that in itself doesn't seem a great burden. > > [ blowing the dust off my old red fedora... ] Actually, there's a > > different problem with this proposal: you can bet that DBD::Pg has got a > > build dependency on Postgres. If Postgres starts to depend on DBD::Pg > > then we've created circular-dependency hell for packagers. > > The Pure Perl driver has no such dependency, since it doesn't require > libpq. But ... > > > I much prefer the other line of thought about doing whatever we need > > to do to make psql workable for the desired type of tests. > > ... agreed ... The module intends to perform multiple operations interactively on a session, or a transaction while performing test. We must keep the session by something persistent to do that. The PostgresClient is that for TAP tests. If we want to let psql have such feature, it would be something like "psql server" or "reconnectable session" of frontend protocol. Both seem too much or leading to something dangerous. > > Or just > > write a bespoke testing tool. > > > > > > ... that's pretty much where we came in. Agreed. And we can add anything PostgreSQL or test specific features to this. regards, -- Kyotaro Horiguchi NTT Open Source Software Center
Hi, On 2018-01-11 16:54:10 +0900, Kyotaro HORIGUCHI wrote: > Thank you for the discussion. If I understand correctly there's been no progress on this since, and there'd definitely need to be major work to get something we can agree upon. Doesn't seem v11 material. I think we should mark this as returned with feedback. Arguments against? Greetings, Andres Freund
On Thu, Mar 01, 2018 at 02:27:13AM -0800, Andres Freund wrote: > If I understand correctly there's been no progress on this since, and > there'd definitely need to be major work to get something we can agree > upon. Doesn't seem v11 material. I think we should mark this as returned > with feedback. Arguments against? Agreed with your position. The TAP tests rely on IPC::Run as a pillar of its infrastructure. I think that if we need a base API to do such capabilities we ought to prioritize what we can do with it first instead of trying to reinvent the wheel as this patch proposes in such a complicated way. -- Michael
Attachment
On 3/1/18 23:39, Michael Paquier wrote: > On Thu, Mar 01, 2018 at 02:27:13AM -0800, Andres Freund wrote: >> If I understand correctly there's been no progress on this since, and >> there'd definitely need to be major work to get something we can agree >> upon. Doesn't seem v11 material. I think we should mark this as returned >> with feedback. Arguments against? > > Agreed with your position. The TAP tests rely on IPC::Run as a pillar > of its infrastructure. I think that if we need a base API to do such > capabilities we ought to prioritize what we can do with it first instead > of trying to reinvent the wheel as this patch proposes in such a > complicated way. I haven't seen any explanation for a problem this is solving. The original submission contained a sample test case, by I don't see why that couldn't be done with the existing infrastructure. Patch closed for now. -- Peter Eisentraut http://www.2ndQuadrant.com/ PostgreSQL Development, 24x7 Support, Remote DBA, Training & Services
At Sat, 3 Mar 2018 09:46:11 -0500, Peter Eisentraut <peter.eisentraut@2ndquadrant.com> wrote in <7f1e5f2f-4902-2c29-de82-381de8cc6d66@2ndquadrant.com> > On 3/1/18 23:39, Michael Paquier wrote: > > On Thu, Mar 01, 2018 at 02:27:13AM -0800, Andres Freund wrote: > >> If I understand correctly there's been no progress on this since, and > >> there'd definitely need to be major work to get something we can agree > >> upon. Doesn't seem v11 material. I think we should mark this as returned > >> with feedback. Arguments against? > > > > Agreed with your position. The TAP tests rely on IPC::Run as a pillar > > of its infrastructure. I think that if we need a base API to do such > > capabilities we ought to prioritize what we can do with it first instead > > of trying to reinvent the wheel as this patch proposes in such a > > complicated way. > > I haven't seen any explanation for a problem this is solving. The > original submission contained a sample test case, by I don't see why > that couldn't be done with the existing infrastructure. > > Patch closed for now. Agreed. This is not a v11 matter. Thanks. regards, -- Kyotaro Horiguchi NTT Open Source Software Center