From 982d4eb86b9ab7f91bffc3ac722d9ac2a46b176b Mon Sep 17 00:00:00 2001 From: Kyotaro Horiguchi 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(, , ); + + Or + + my $conn = PostgresClient::connectdb(, , {param1 => val1, ..}); + + OR + + my $conn = PostgresClient::connectdb(, ); + + 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