mirrors/postgres
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

perl5 interface moved to gborg

Browse Source
This commit is contained in:
Marc G. Fournier 2002-08-30 13:06:22 +00:00
parent c411f51dfb
commit 9a0b4d7f84
17 changed files with 5 additions and 3805 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
GNUmakefile.in
View File

@ -1,7 +1,7 @@
#
# PostgreSQL top level makefile
#
# $Header: /cvsroot/pgsql/GNUmakefile.in,v 1.26 2002/08/22 22:43:08 scrappy Exp $
# $Header: /cvsroot/pgsql/GNUmakefile.in,v 1.27 2002/08/30 13:06:12 scrappy Exp $
#
subdir =
@ -72,7 +72,7 @@ $(distdir).tar: distdir
opt_files := src/backend/utils/mb contrib/retep/build.xml \
src/tools src/corba src/data src/tutorial \
$(addprefix src/bin/, pgaccess pgtclsh pg_encoding) \
$(addprefix src/interfaces/, libpgtcl perl5 python jdbc) \
$(addprefix src/interfaces/, libpgtcl python jdbc) \
$(addprefix src/pl/, plperl tcl)
docs_files := doc/postgres.tar.gz doc/src doc/TODO.detail

126
configure vendored
View File

@ -860,7 +860,6 @@ Optional Packages:
--without-tk do not build Tk interfaces if Tcl is enabled
--with-tclconfig=DIR tclConfig.sh and tkConfig.sh are in DIR
--with-tkconfig=DIR tkConfig.sh is in DIR
--with-perl build Perl interface and PL/Perl
--with-python build Python interface module
--with-java build JDBC interface and Java tools
--with-krb4[=DIR] build with Kerberos 4 support [/usr/athena]
@ -2945,41 +2944,6 @@ echo "$as_me: error: argument required for --with-tkconfig option" >&2;}
fi;
#
# Optionally build Perl modules (Pg.pm and PL/Perl)
#
echo "$as_me:$LINENO: checking whether to build Perl modules" >&5
echo $ECHO_N "checking whether to build Perl modules... $ECHO_C" >&6
# Check whether --with-perl or --without-perl was given.
if test "${with_perl+set}" = set; then
withval="$with_perl"
case $withval in
yes)
:
;;
no)
:
;;
*)
{ { echo "$as_me:$LINENO: error: no argument expected for --with-perl option" >&5
echo "$as_me: error: no argument expected for --with-perl option" >&2;}
{ (exit 1); exit 1; }; }
;;
esac
else
with_perl=no
fi;
echo "$as_me:$LINENO: result: $with_perl" >&5
echo "${ECHO_T}$with_perl" >&6
#
# Optionally build Python interface module
#
@ -4156,87 +4120,6 @@ echo "$as_me: error: 'wish' is required for Tk support" >&2;}
{ (exit 1); exit 1; }; }
fi
# Extract the first word of "perl", so it can be a program name with args.
set dummy perl; ac_word=$2
echo "$as_me:$LINENO: checking for $ac_word" >&5
echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
if test "${ac_cv_path_PERL+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
case $PERL in
[\\/]* | ?:[\\/]*)
ac_cv_path_PERL="$PERL" # Let the user override the test with a path.
;;
*)
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_path_PERL="$as_dir/$ac_word$ac_exec_ext"
echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
;;
esac
fi
PERL=$ac_cv_path_PERL
if test -n "$PERL"; then
echo "$as_me:$LINENO: result: $PERL" >&5
echo "${ECHO_T}$PERL" >&6
else
echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
fi
if test "$with_perl" = yes; then
echo "$as_me:$LINENO: checking for Perl installsitearch" >&5
echo $ECHO_N "checking for Perl installsitearch... $ECHO_C" >&6
perl_installsitearch=`$PERL -MConfig -e 'print $Config{installsitearch}'`
echo "$as_me:$LINENO: result: $perl_installsitearch" >&5
echo "${ECHO_T}$perl_installsitearch" >&6
echo "$as_me:$LINENO: checking for Perl installman3dir" >&5
echo $ECHO_N "checking for Perl installman3dir... $ECHO_C" >&6
perl_installman3dir=`$PERL -MConfig -e 'print $Config{installman3dir}'`
echo "$as_me:$LINENO: result: $perl_installman3dir" >&5
echo "${ECHO_T}$perl_installman3dir" >&6
echo "$as_me:$LINENO: checking for Perl archlibexp" >&5
echo $ECHO_N "checking for Perl archlibexp... $ECHO_C" >&6
perl_archlibexp=`$PERL -MConfig -e 'print $Config{archlibexp}'`
echo "$as_me:$LINENO: result: $perl_archlibexp" >&5
echo "${ECHO_T}$perl_archlibexp" >&6
echo "$as_me:$LINENO: checking for Perl privlibexp" >&5
echo $ECHO_N "checking for Perl privlibexp... $ECHO_C" >&6
perl_privlibexp=`$PERL -MConfig -e 'print $Config{privlibexp}'`
echo "$as_me:$LINENO: result: $perl_privlibexp" >&5
echo "${ECHO_T}$perl_privlibexp" >&6
echo "$as_me:$LINENO: checking for Perl useshrplib" >&5
echo $ECHO_N "checking for Perl useshrplib... $ECHO_C" >&6
perl_useshrplib=`$PERL -MConfig -e 'print $Config{useshrplib}'`
echo "$as_me:$LINENO: result: $perl_useshrplib" >&5
echo "${ECHO_T}$perl_useshrplib" >&6
echo "$as_me:$LINENO: checking for Perl man3ext" >&5
echo $ECHO_N "checking for Perl man3ext... $ECHO_C" >&6
perl_man3ext=`$PERL -MConfig -e 'print $Config{man3ext}'`
echo "$as_me:$LINENO: result: $perl_man3ext" >&5
echo "${ECHO_T}$perl_man3ext" >&6
echo "$as_me:$LINENO: checking for flags to link embedded Perl" >&5
echo $ECHO_N "checking for flags to link embedded Perl... $ECHO_C" >&6
pgac_tmp1=`$PERL -MExtUtils::Embed -e ldopts`
pgac_tmp2=`$PERL -MConfig -e 'print $Config{ccdlflags}'`
perl_embed_ldflags=`echo X"$pgac_tmp1" | sed "s/^X//;s%$pgac_tmp2%%"`
echo "$as_me:$LINENO: result: $perl_embed_ldflags" >&5
echo "${ECHO_T}$perl_embed_ldflags" >&6
fi
if test "$with_python" = yes; then
# Extract the first word of "python", so it can be a program name with args.
set dummy python; ac_word=$2
@ -16290,7 +16173,6 @@ s,@autodepend@,$autodepend,;t t
s,@INCLUDES@,$INCLUDES,;t t
s,@with_tcl@,$with_tcl,;t t
s,@with_tk@,$with_tk,;t t
s,@with_perl@,$with_perl,;t t
s,@with_python@,$with_python,;t t
s,@ANT@,$ANT,;t t
s,@with_java@,$with_java,;t t
@ -16318,14 +16200,6 @@ s,@STRIP_SHARED_LIB@,$STRIP_SHARED_LIB,;t t
s,@YACC@,$YACC,;t t
s,@YFLAGS@,$YFLAGS,;t t
s,@WISH@,$WISH,;t t
s,@PERL@,$PERL,;t t
s,@perl_installsitearch@,$perl_installsitearch,;t t
s,@perl_installman3dir@,$perl_installman3dir,;t t
s,@perl_archlibexp@,$perl_archlibexp,;t t
s,@perl_privlibexp@,$perl_privlibexp,;t t
s,@perl_useshrplib@,$perl_useshrplib,;t t
s,@perl_man3ext@,$perl_man3ext,;t t
s,@perl_embed_ldflags@,$perl_embed_ldflags,;t t
s,@PYTHON@,$PYTHON,;t t
s,@python_version@,$python_version,;t t
s,@python_prefix@,$python_prefix,;t t

17
configure.in
View File

@ -1,5 +1,5 @@
dnl Process this file with autoconf to produce a configure script.
dnl $Header: /cvsroot/pgsql/configure.in,v 1.197 2002/08/22 22:43:08 scrappy Exp $
dnl $Header: /cvsroot/pgsql/configure.in,v 1.198 2002/08/30 13:06:17 scrappy Exp $
dnl
dnl Developers, please strive to achieve this order:
dnl
@ -356,14 +356,6 @@ PGAC_ARG_REQ(with, tclconfig, [ --with-tclconfig=DIR tclConfig.sh and tkConf
PGAC_ARG_REQ(with, tkconfig, [ --with-tkconfig=DIR tkConfig.sh is in DIR])
#
# Optionally build Perl modules (Pg.pm and PL/Perl)
#
AC_MSG_CHECKING([whether to build Perl modules])
PGAC_ARG_BOOL(with, perl, no, [ --with-perl build Perl interface and PL/Perl])
AC_MSG_RESULT([$with_perl])
AC_SUBST(with_perl)
#
# Optionally build Python interface module
#
@ -579,13 +571,6 @@ if test "$with_tk" = yes; then
test -z "$WISH" && AC_MSG_ERROR(['wish' is required for Tk support])
fi
PGAC_PATH_PERL
if test "$with_perl" = yes; then
PGAC_CHECK_PERL_CONFIGS([installsitearch,installman3dir,
archlibexp,privlibexp,useshrplib,man3ext])
PGAC_CHECK_PERL_EMBED_LDFLAGS
fi
if test "$with_python" = yes; then
PGAC_PATH_PYTHON
PGAC_CHECK_PYTHON_MODULE_SETUP

8
src/interfaces/Makefile
View File

@ -4,7 +4,7 @@
#
# Copyright (c) 1994, Regents of the University of California
#
# $Header: /cvsroot/pgsql/src/interfaces/Makefile,v 1.48 2002/08/30 13:03:09 scrappy Exp $
# $Header: /cvsroot/pgsql/src/interfaces/Makefile,v 1.49 2002/08/30 13:06:20 scrappy Exp $
#
#-------------------------------------------------------------------------
@ -14,16 +14,12 @@ include $(top_builddir)/src/Makefile.global
DIRS := libpq ecpg
ALLDIRS := $(DIRS) libpgtcl perl5 python jdbc
ALLDIRS := $(DIRS) libpgtcl python jdbc
ifeq ($(with_tcl), yes)
DIRS += libpgtcl
endif
ifeq ($(with_perl), yes)
DIRS += perl5
endif
ifeq ($(with_python), yes)
DIRS += python
endif

126
src/interfaces/perl5/Changes
View File

@ -1,126 +0,0 @@
#-------------------------------------------------------
#
# $Id: Changes,v 1.9 2000/06/01 03:07:33 momjian Exp $
#
# Copyright (c) 1997, 1998 Edmund Mergl
#
#-------------------------------------------------------
Revision history for Perl extension Pg.
1.8.0 Sep 27 1998
- adapted to PostgreSQL-6.4:
added support for
o PQsetdbLogin
o PQpass
o PQsocket
o PQbackendPID
o PQsendQuery
o PQgetResult
o PQisBusy
o PQconsumeInput
o PQrequestCancel
o PQgetlineAsync
o PQputnbytes
o PQmakeEmptyPGresult
o PQbinaryTuples
o PQfmod
- fixed conndefaults()
- fixed lo_read
1.7.4 May 28 1998
- applied patches from
Brook Milligan <brook@trillium.NMSU.Edu>:
o changed Makefile.PL to look for include files
and libs in the source tree, except when the
environment variable POSTGRES_HOME is set.
o bug-fix in test.pl
1.7.3 Mar 28 1998
- linking again with the shared version of libpq
due to problems on several operating systems.
1.7.2 Mar 06 1998
- module is now linked with static libpq.a
1.7.1 Mar 03 1998
- expanded the search path for include files
- return to UNIX domain sockets in test-scripts
1.7.0 Feb 20 1998
- adapted to PostgreSQL-6.3:
add host=localhost to the conninfo-string
of test.pl and example-scripts
- connectdb() converts dbname to lower case,
unless it is surrounded by double quotes
- added new method fetchrow, now you can do:
while (@row = $result->fetchrow)
1.6.3 Sep 25 1997
- README update
1.6.2 Sep 20 1997
- adapted to PostgreSQL-6.2:
o added support for new method cmdTuples
o cmdStatus returns now for DELETE the status
followed by the number of affected rows,
- test.pl.newstyle renamed to examples/example.newstyle
- test.pl.oldstyle renamed to examples/example.oldstyle
- example script ApachePg.pl now uses
$result->print with HTML option
- Makefile looks for $ENV{POSTGRES_HOME} instead of
$ENV{POSTGRESHOME}
1.6.1 Jun 02 1997
- renamed to pgsql_perl5
- adapted to PostgreSQL-6.1
- test only functions, which are also
tested in pgsql regression tests
1.5.4 Feb 12, 1997
- changed test.pl for large objects:
test only lo_import and lo_export
1.5.3 Jan 2, 1997
- adapted to PostgreSQL-6.0
- new functions PQconnectdb, PQuser
- changed name of method 'new' to 'setdb'
1.4.2 Nov 21, 1996
- added a more Perl-like syntax
1.3.2 Nov 11, 1996
- adapted to Postgres95-1.09
- test.pl adapted to postgres95-1.0.9:
PQputline expects now '\.' as last input
and PQgetline outputs '\.' as last line.
1.3.1 Oct 22, 1996
- adapted to Postgres95-1.08
- large-object interface added, thanks to
Sven Verdoolaege (skimo@breughel.ufsia.ac.be)
- PQgetline() changed. This breaks old scripts !
- PQexec now returns in any case a valid pointer.
This fixes the annoying message:
'res is not of type PGresultPtr at ...'
- testsuite completely rewritten, contains
now examples for almost all functions
- resturn codes are now available as constants (PGRES_xxx)
- PQnotifies() works now
- enhanced doQuery()
1.2.0 Oct 15, 1995
- adapted to Postgres95-1.0
- README updated
- doQuery() in Pg.pm now returns 0 upon success
- testlibpq.pl: added test for PQgetline()
1.1.1 Aug 5, 95
- adapted to postgres95-beta0.03
- Note: the libpq interface has changed completely !
1.1 Jun 6, 1995
- Bug fix in PQgetline.
1.0 Mar 24, 1995
- creation

91
src/interfaces/perl5/GNUmakefile
View File

@ -1,91 +0,0 @@
# $Header: /cvsroot/pgsql/src/interfaces/perl5/Attic/GNUmakefile,v 1.9 2002/08/27 03:57:11 momjian Exp $
subdir = src/interfaces/perl5
top_builddir = ../../..
include $(top_builddir)/src/Makefile.global
# This would allow a non-root install of the Perl module, but it's not
# quite implemented yet.
ifeq ($(mysterious_feature),yes)
perl_installsitearch = $(pkglibdir)
perl_installsitelib = $(pkglibdir)
perl_installman3dir = $(mandir)/man3
endif
override CPPFLAGS := -I$(libpq_srcdir) -I$(top_srcdir)/src/include $(CPPFLAGS) -I$(perl_archlibexp)/CORE -I$(top_srcdir)/$(subdir)
override CFLAGS += $(CFLAGS_SL)
override CPPFLAGS += -DXS_VERSION=\"$(shell sed -n "s/\$$.*::VERSION.*=.*'\(.*\)';/\1/p" $(srcdir)/Pg.pm)\"
# The code isn't clean with regard to these warnings.
ifeq ($(GCC),yes)
override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes, $(CFLAGS))
endif
POD2MAN = pod2man
NAME = Pg
OBJS = Pg.o
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
SHLIB_LINK = -L$(libpq_builddir) -lpq
include $(top_srcdir)/src/Makefile.shlib
all: all-lib Pg.pm Pg.bs auto/Pg/autosplit.ix Pg.$(perl_man3ext)
all-lib: libpq-all
.PHONY: libpq-all
libpq-all:
$(MAKE) -C $(libpq_builddir) all
Pg.c: Pg.xs typemap
$(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap -typemap $(srcdir)/typemap $(srcdir)/Pg.xs >$@
auto/Pg/autosplit.ix: Pg.pm
@$(mkinstalldirs) auto
$(PERL) -MAutoSplit -e 'autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);' $< auto
Pg.bs:
$(PERL) -MExtUtils::Mkbootstrap -e "Mkbootstrap('Pg', '');"
touch $@
Pg.$(perl_man3ext): Pg.pm
$(POD2MAN) --section=$(perl_man3ext) $< > Pg.$(perl_man3ext)
# During install, we must guard against the likelihood that we don't
# have permissions to install into the Perl module library. It's not
# exactly fun to have to scan the build output, but...
install-warning-msg := { \
echo ""; \
echo "*** Skipping the installation of the Perl module for lack"; \
echo "*** of permissions. To install it, change to the directory"; \
echo "*** `pwd`,"; \
echo "*** become the appropriate user, and enter '$(MAKE) install'."; \
echo ""; }
install: all installdirs
@if test -w $(DESTDIR)$(perl_installsitearch); then \
$(INSTALL_DATA) Pg.pm $(DESTDIR)$(perl_installsitearch); \
$(INSTALL_DATA) Pg.bs $(DESTDIR)$(perl_installsitearch)/auto/Pg; \
$(INSTALL_SHLIB) $(shlib) $(DESTDIR)$(perl_installsitearch)/auto/Pg/Pg$(DLSUFFIX); \
$(INSTALL_DATA) auto/Pg/autosplit.ix $(DESTDIR)$(perl_installsitearch)/auto/Pg; \
$(INSTALL_DATA) Pg.$(perl_man3ext) $(DESTDIR)$(perl_installman3dir); \
else \
$(install-warning-msg); \
fi
installdirs:
-$(mkinstalldirs) $(DESTDIR)$(perl_installsitearch)/auto/Pg $(DESTDIR)$(perl_installman3dir)
uninstall:
rm -f $(addprefix $(DESTDIR)$(perl_installsitearch)/, Pg.pm auto/Pg/Pg.bs auto/Pg/Pg$(DLSUFFIX) auto/Pg/autosplit.ix) $(DESTDIR)$(perl_installman3dir)/Pg.$(perl_man3ext)
clean distclean maintainer-clean: clean-lib
rm -f $(OBJS) Pg.c Pg.bs Pg.$(perl_man3ext)
rm -rf auto

12
src/interfaces/perl5/MANIFEST
View File

@ -1,12 +0,0 @@
Changes
MANIFEST
Makefile.PL
Pg.pm
Pg.xs
README
examples/ApachePg.pl
examples/example.newstyle
examples/example.oldstyle
ppport.h
test.pl
typemap

107
src/interfaces/perl5/Makefile.PL
View File

@ -1,107 +0,0 @@
#-------------------------------------------------------
#
# $Id: Makefile.PL,v 1.18 2001/08/26 22:28:04 petere Exp $
#
# Copyright (c) 1997, 1998 Edmund Mergl
#
#-------------------------------------------------------
use ExtUtils::MakeMaker;
use Config;
use strict;
my $srcdir=$ENV{SRCDIR};
my %opts;
%opts = (
NAME => 'Pg',
VERSION_FROM => "Pg.pm",
OBJECT => "Pg\$(OBJ_EXT)",
# explicit mappings required for VPATH builds
PM => { "$srcdir/Pg.pm" => '$(INST_LIBDIR)/Pg.pm' },
MAN3PODS => { "$srcdir/Pg.pm" => '$(INST_MAN3DIR)/Pg.$(MAN3EXT)' },
);
if (! -d $ENV{POSTGRES_LIB} || ! -d $ENV{POSTGRES_INCLUDE}) {
# Check that we actually are inside the Postgres source tree
if (! -d "../libpq") {
die
"To install Pg separately from the Postgres distribution, you must
set environment variables POSTGRES_LIB and POSTGRES_INCLUDE to point
to where Postgres is installed (often /usr/local/pgsql/{lib,include}).\n";
}
} else {
# Setup for standalone installation when Postgres already is installed.
%opts = (
%opts,
INC => "-I$ENV{POSTGRES_INCLUDE}",
LIBS => ["-L$ENV{POSTGRES_LIB} -lpq"],
);
}
WriteMakefile(%opts);
# Put the proper runpath into the shared object.
sub MY::dynamic_lib {
package MY;
my $inherited= shift->SUPER::dynamic_lib(@_);
my $pglibdir = $ENV{PGLIBDIR};
return $inherited if $pglibdir eq '';
# Remove any misguided attempts to set the runpath.
$inherited =~ s/LD_RUN_PATH=\"\$\(LD_RUN_PATH\)\" //g;
$inherited =~ s/-R\S*//g;
$inherited =~ s/-rpath\S*//g;
my $rpath;
# Note that this could be different from what Makefile.port has
# because a different compiler/linker could be used.
SWITCH: for ($Config::Config{'osname'}) {
/hpux/ and $rpath = "+b $pglibdir", last;
/freebsd/ and $rpath = "-R$pglibdir", last;
/irix/ and $rpath = "-R$pglibdir", last;
/linux/ and $rpath = "-Wl,-rpath,$pglibdir", last;
/netbsd/ and $rpath = "-R$pglibdir", last;
/openbsd/ and $rpath = "-R$pglibdir", last;
/solaris/ and $rpath = "-R$pglibdir", last;
/svr5/ and $rpath = "-R$pglibdir", last;
}
$inherited=~ s,OTHERLDFLAGS =,OTHERLDFLAGS = $rpath , if defined $rpath;
$inherited;
}
# VPATH-aware version of this rule
sub MY::xs_c {
my($self) = shift;
return '' unless $self->needs_linking();
'
.xs.c:
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $< > $@
';
}
# Delete this rule. We can use the above one.
sub MY::xs_o {
'';
}
# This rule tries to rebuild the Makefile from Makefile.PL. We can do
# that better ourselves.
sub MY::makefile {
'';
}

657
src/interfaces/perl5/Pg.pm
View File

@ -1,657 +0,0 @@
#-------------------------------------------------------
#
# $Id: Pg.pm,v 1.11 2002/08/15 02:56:19 momjian Exp $
#
# Copyright (c) 1997, 1998 Edmund Mergl
#
#-------------------------------------------------------
package Pg;
#use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
require Exporter;
require DynaLoader;
require AutoLoader;
require 5.002;
@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default.
@EXPORT = qw(
PQconnectdb
PQsetdbLogin
PQsetdb
PQconndefaults
PQfinish
PQreset
PQrequestCancel
PQdb
PQuser
PQpass
PQhost
PQport
PQtty
PQoptions
PQstatus
PQerrorMessage
PQsocket
PQbackendPID
PQtrace
PQuntrace
PQexec
PQnotifies
PQsendQuery
PQgetResult
PQisBusy
PQconsumeInput
PQgetline
PQputline
PQgetlineAsync
PQputnbytes
PQendcopy
PQmakeEmptyPGresult
PQresultStatus
PQntuples
PQnfields
PQbinaryTuples
PQfname
PQfnumber
PQftype
PQfsize
PQfmod
PQcmdStatus
PQoidStatus
PQcmdTuples
PQgetvalue
PQgetlength
PQgetisnull
PQclear
PQprint
PQdisplayTuples
PQprintTuples
PQlo_open
PQlo_close
PQlo_read
PQlo_write
PQlo_lseek
PQlo_creat
PQlo_tell
PQlo_unlink
PQlo_import
PQlo_export
PGRES_CONNECTION_OK
PGRES_CONNECTION_BAD
PGRES_EMPTY_QUERY
PGRES_COMMAND_OK
PGRES_TUPLES_OK
PGRES_COPY_OUT
PGRES_COPY_IN
PGRES_BAD_RESPONSE
PGRES_NONFATAL_ERROR
PGRES_FATAL_ERROR
PGRES_INV_SMGRMASK
PGRES_INV_WRITE
PGRES_INV_READ
PGRES_InvalidOid
);
$Pg::VERSION = '1.9.0';
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function. If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/) {
$AutoLoader::AUTOLOAD = $AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
}
else {
croak "Your vendor has not defined Pg macro $constname";
}
}
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
}
bootstrap Pg $VERSION;
sub doQuery {
my $conn = shift;
my $query = shift;
my $array_ref = shift;
my ($result, $status, $i, $j);
if ($result = $conn->exec($query)) {
if (2 == ($status = $result->resultStatus)) {
for $i (0..$result->ntuples - 1) {
for $j (0..$result->nfields - 1) {
$$array_ref[$i][$j] = $result->getvalue($i, $j);
}
}
}
}
return $status;
}
1;
__END__
=head1 NAME
Pg - Perl5 extension for PostgreSQL
=head1 SYNOPSIS
new style:
use Pg;
$conn = Pg::connectdb("dbname=template1");
$result = $conn->exec("create database pgtest");
old style (depreciated):
use Pg;
$conn = PQsetdb('', '', '', '', template1);
$result = PQexec($conn, "create database pgtest");
PQclear($result);
PQfinish($conn);
=head1 DESCRIPTION
The Pg module permits you to access all functions of the
Libpq interface of PostgreSQL. Libpq is the programmer's
interface to PostgreSQL. Pg tries to resemble this
interface as close as possible. For examples of how to
use this module, look at the file test.pl. For further
examples look at the Libpq applications in
../src/test/examples and ../src/test/regress.
You have the choice between the old C-style and a
new, more Perl-ish style. The old style has the
benefit, that existing Libpq applications can be
ported to perl just by prepending every variable
with a '$'. The new style uses class packages and
might be more familiar for C++-programmers.
=head1 GUIDELINES
=head2 new style
The new style uses blessed references as objects.
After creating a new connection or result object,
the relevant Libpq functions serve as virtual methods.
One benefit of the new style: you do not have to care
about freeing the connection- and result-structures.
Perl calls the destructor whenever the last reference
to an object goes away.
The method fetchrow can be used to fetch the next row from
the server: while (@row = $result->fetchrow).
Columns which have NULL as value will be set to C<undef>.
=head2 old style
All functions and constants are imported into the calling
packages name-space. In order to to get a uniform naming,
all functions start with 'PQ' (e.g. PQlo_open) and all
constants start with 'PGRES_' (e.g. PGRES_CONNECTION_OK).
There are two functions, which allocate memory, that has
to be freed by the user:
PQsetdb, use PQfinish to free memory.
PQexec, use PQclear to free memory.
Pg.pm contains one convenience function: doQuery. It fills a
two-dimensional array with the result of your query. Usage:
Pg::doQuery($conn, "select attr1, attr2 from tbl", \@ary);
for $i ( 0 .. $#ary ) {
for $j ( 0 .. $#{$ary[$i]} ) {
print "$ary[$i][$j]\t";
}
print "\n";
}
Notice the inner loop !
=head1 CAVEATS
There are few exceptions, where the perl-functions differs
from the C-counterpart: PQprint, PQnotifies and PQconndefaults.
These functions deal with structures, which have been
implemented in perl using lists or hash.
=head1 FUNCTIONS
The functions have been divided into three sections:
Connection, Result, Large Objects. For details please
read L<libpq>.
=head2 1. Connection
With these functions you can establish and close a connection to a
database. In Libpq a connection is represented by a structure called
PGconn.
When opening a connection a given database name is always converted to
lower-case, unless it is surrounded by double quotes. All unspecified
parameters are replaced by environment variables or by hard coded defaults:
parameter environment variable hard coded default
------------------------------------------------------
host PGHOST localhost
port PGPORT 5432
options PGOPTIONS ""
tty PGTTY ""
dbname PGDATABASE current userid
user PGUSER current userid
password PGPASSWORD ""
passwordfile PGPASSWORDFILE ""
Using appropriate methods you can access almost all fields of the
returned PGconn structure.
$conn = Pg::setdbLogin($pghost, $pgport, $pgoptions, $pgtty, $dbname, $login, $pwd)
Opens a new connection to the backend. The connection identifier $conn
( a pointer to the PGconn structure ) must be used in subsequent commands
for unique identification. Before using $conn you should call $conn->status
to ensure, that the connection was properly made.
$conn = Pg::setdb($pghost, $pgport, $pgoptions, $pgtty, $dbname)
The method setdb should be used when username/password authentication is
not needed.
$conn = Pg::connectdb("option1=value option2=value ...")
Opens a new connection to the backend using connection information in a
string. Possible options are: host, port, options, tty, dbname, user, password.
The connection identifier $conn (a pointer to the PGconn structure)
must be used in subsequent commands for unique identification. Before using
$conn you should call $conn->status to ensure, that the connection was
properly made.
$Option_ref = Pg::conndefaults()
while(($key, $val) = each %$Option_ref) {
print "$key, $val\n";
Returns a reference to a hash containing as keys all possible options for
connectdb(). The values are the current defaults. This function differs from
his C-counterpart, which returns the complete conninfoOption structure.
PQfinish($conn)
Old style only !
Closes the connection to the backend and frees the connection data structure.
$conn->reset
Resets the communication port with the backend and tries
to establish a new connection.
$ret = $conn->requestCancel
Abandon processing of the current query. Regardless of the return value of
requestCancel, the application must continue with the normal result-reading
sequence using getResult. If the current query is part of a transaction,
cancellation will abort the whole transaction.
$dbname = $conn->db
Returns the database name of the connection.
$pguser = $conn->user
Returns the Postgres user name of the connection.
$pguser = $conn->pass
Returns the Postgres password of the connection.
$pghost = $conn->host
Returns the host name of the connection.
$pgport = $conn->port
Returns the port of the connection.
$pgtty = $conn->tty
Returns the tty of the connection.
$pgoptions = $conn->options
Returns the options used in the connection.
$status = $conn->status
Returns the status of the connection. For comparing the status
you may use the following constants:
- PGRES_CONNECTION_OK
- PGRES_CONNECTION_BAD
$errorMessage = $conn->errorMessage
Returns the last error message associated with this connection.
$fd = $conn->socket
Obtain the file descriptor number for the backend connection socket.
A result of -1 indicates that no backend connection is currently open.
$pid = $conn->backendPID
Returns the process-id of the corresponding backend proceess.
$conn->trace(debug_port)
Messages passed between frontend and backend are echoed to the
debug_port file stream.
$conn->untrace
Disables tracing.
$result = $conn->exec($query)
Submits a query to the backend. The return value is a pointer to
the PGresult structure, which contains the complete query-result
returned by the backend. In case of failure, the pointer points
to an empty structure. In this, the perl implementation differs
from the C-implementation. Using the old style, even the empty
structure has to be freed using PQfree. Before using $result you
should call resultStatus to ensure, that the query was
properly executed.
($table, $pid) = $conn->notifies
Checks for asynchronous notifications. This functions differs from
the C-counterpart which returns a pointer to a new allocated structure,
whereas the perl implementation returns a list. $table is the table
which has been listened to and $pid is the process id of the backend.
$ret = $conn->sendQuery($string, $query)
Submit a query to Postgres without waiting for the result(s). After
successfully calling PQsendQuery, call PQgetResult one or more times
to obtain the query results. PQsendQuery may not be called again until
getResult has returned NULL, indicating that the query is done.
$result = $conn->getResult
Wait for the next result from a prior PQsendQuery, and return it. NULL
is returned when the query is complete and there will be no more results.
getResult will block only if a query is active and the necessary response
data has not yet been read by PQconsumeInput.
$ret = $conn->isBusy
Returns TRUE if a query is busy, that is, PQgetResult would block waiting
for input. A FALSE return indicates that PQgetResult can be called with
assurance of not blocking.
$result = $conn->consumeInput
If input is available from the backend, consume it. After calling consumeInput,
the application may check isBusy and/or notifies to see if their state has changed.
$ret = $conn->getline($string, $length)
Reads a string up to $length - 1 characters from the backend.
getline returns EOF at EOF, 0 if the entire line has been read,
and 1 if the buffer is full. If a line consists of the two
characters "\." the backend has finished sending the results of
the copy command.
$ret = $conn->putline($string)
Sends a string to the backend. The application must explicitly
send the two characters "\." to indicate to the backend that
it has finished sending its data.
$ret = $conn->getlineAsync($buffer, $bufsize)
Non-blocking version of getline. It reads up to $bufsize
characters from the backend. getlineAsync returns -1 if
the end-of-copy-marker has been recognized, 0 if no data
is avilable, and >0 the number of bytes returned.
$ret = $conn->putnbytes($buffer, $nbytes)
Sends n bytes to the backend. Returns 0 if OK, EOF if not.
$ret = $conn->endcopy
This function waits until the backend has finished the copy.
It should either be issued when the last string has been sent
to the backend using putline or when the last string has
been received from the backend using getline. endcopy returns
0 on success, 1 on failure.
$result = $conn->makeEmptyPGresult($status);
Returns a newly allocated, initialized result with given status.
=head2 2. Result
With these functions you can send commands to a database and
investigate the results. In Libpq the result of a command is
represented by a structure called PGresult. Using the appropriate
methods you can access almost all fields of this structure.
$result_status = $result->resultStatus
Returns the status of the result. For comparing the status you
may use one of the following constants depending upon the
command executed:
- PGRES_EMPTY_QUERY
- PGRES_COMMAND_OK
- PGRES_TUPLES_OK
- PGRES_COPY_OUT
- PGRES_COPY_IN
- PGRES_BAD_RESPONSE
- PGRES_NONFATAL_ERROR
- PGRES_FATAL_ERROR
Use the functions below to access the contents of the PGresult structure.
$ntuples = $result->ntuples
Returns the number of tuples in the query result.
$nfields = $result->nfields
Returns the number of fields in the query result.
$ret = $result->binaryTuples
Returns 1 if the tuples in the query result are bianry.
$fname = $result->fname($field_num)
Returns the field name associated with the given field number.
$fnumber = $result->fnumber($field_name)
Returns the field number associated with the given field name.
$ftype = $result->ftype($field_num)
Returns the oid of the type of the given field number.
$fsize = $result->fsize($field_num)
Returns the size in bytes of the type of the given field number.
It returns -1 if the field has a variable length.
$fmod = $result->fmod($field_num)
Returns the type-specific modification data of the field associated
with the given field index. Field indices start at 0.
$cmdStatus = $result->cmdStatus
Returns the command status of the last query command.
In case of DELETE it returns also the number of deleted tuples.
In case of INSERT it returns also the OID of the inserted
tuple followed by 1 (the number of affected tuples).
$oid = $result->oidStatus
In case the last query was an INSERT command it returns the oid of the
inserted tuple.
$oid = $result->cmdTuples
In case the last query was an INSERT or DELETE command it returns the
number of affected tuples.
$value = $result->getvalue($tup_num, $field_num)
Returns the value of the given tuple and field. This is
a null-terminated ASCII string. Binary cursors will not
work.
$length = $result->getlength($tup_num, $field_num)
Returns the length of the value for a given tuple and field.
$null_status = $result->getisnull($tup_num, $field_num)
Returns the NULL status for a given tuple and field.
PQclear($result)
Old style only !
Frees all memory of the given result.
$res->fetchrow
New style only !
Fetches the next row from the server and returns NULL if all rows
have been processed. Columns which have NULL as value will be set to C<undef>.
$result->print($fout, $header, $align, $standard, $html3, $expanded, $pager, $fieldSep, $tableOpt, $caption, ...)
Prints out all the tuples in an intelligent manner. This function
differs from the C-counterpart. The struct PQprintOpt has been
implemented with a list. This list is of variable length, in order
to care for the character array fieldName in PQprintOpt.
The arguments $header, $align, $standard, $html3, $expanded, $pager
are boolean flags. The arguments $fieldSep, $tableOpt, $caption
are strings. You may append additional strings, which will be
taken as replacement for the field names.
$result->displayTuples($fp, $fillAlign, $fieldSep, $printHeader, qiet)
Kept for backward compatibility. Use print.
$result->printTuples($fout, $printAttName, $terseOutput, $width)
Kept for backward compatibility. Use print.
=head2 3. Large Objects
These functions provide file-oriented access to user data.
The large object interface is modeled after the Unix file
system interface with analogies of open, close, read, write,
lseek, tell. In order to get a consistent naming, all function
names have been prepended with 'PQ' (old style only).
$lobj_fd = $conn->lo_open($lobjId, $mode)
Opens an existing large object and returns an object id.
For the mode bits see lo_create. Returns -1 upon failure.
$ret = $conn->lo_close($lobj_fd)
Closes an existing large object. Returns 0 upon success
and -1 upon failure.
$nbytes = $conn->lo_read($lobj_fd, $buf, $len)
Reads $len bytes into $buf from large object $lobj_fd.
Returns the number of bytes read and -1 upon failure.
$nbytes = $conn->lo_write($lobj_fd, $buf, $len)
Writes $len bytes of $buf into the large object $lobj_fd.
Returns the number of bytes written and -1 upon failure.
$ret = $conn->lo_lseek($lobj_fd, $offset, $whence)
Change the current read or write location on the large object
$obj_id. Currently $whence can only be 0 (L_SET).
$lobjId = $conn->lo_creat($mode)
Creates a new large object. $mode is a bit-mask describing
different attributes of the new object. Use the following constants:
- PGRES_INV_SMGRMASK
- PGRES_INV_WRITE
- PGRES_INV_READ
Upon failure it returns PGRES_InvalidOid.
$location = $conn->lo_tell($lobj_fd)
Returns the current read or write location on the large object
$lobj_fd.
$ret = $conn->lo_unlink($lobjId)
Deletes a large object. Returns -1 upon failure.
$lobjId = $conn->lo_import($filename)
Imports a Unix file as large object and returns
the object id of the new object.
$ret = $conn->lo_export($lobjId, $filename)
Exports a large object into a Unix file.
Returns -1 upon failure, 1 otherwise.
=head1 AUTHOR
Edmund Mergl <E.Mergl@bawue.de>
=head1 SEE ALSO
L<libpq>, L<large_objects>
=cut

1320
src/interfaces/perl5/Pg.xs
View File

File diff suppressed because it is too large Load Diff

137
src/interfaces/perl5/README
View File

@ -1,137 +0,0 @@
#-------------------------------------------------------
#
# $Id: README,v 1.8 1998/09/27 19:12:24 mergl Exp $
#
# Copyright (c) 1997, 1998 Edmund Mergl
#
#-------------------------------------------------------
DESCRIPTION:
------------
This is version 1.8.0 of pgsql_perl5 (previously called pg95perl5).
Pgsql_perl5 is an interface between Larry Wall's language perl version 5 and
the database PostgreSQL (previously Postgres95). This has been done by using
the Perl5 application programming interface for C extensions which calls the
Postgres programmer's interface LIBPQ. Pgsql_perl5 tries to implement the LIBPQ-
interface as close as possible.
You have the choice between two different interfaces: the old C-style like
interface and a new one, using a more Perl-ish like style. The old style
has the benefit, that existing Libpq applications can easily be ported to
perl. The new style uses class packages and might be more familiar for C++-
programmers.
NOTE: it is planned to drop the old C-style interface in the next major release
of PostgreSQL.
COPYRIGHT:
----------
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
IF YOU HAVE PROBLEMS:
---------------------
Please send comments and bug-reports to <pgsql-interfaces@postgresql.org>
Please include the output of perl -v,
and perl -V,
the version of PostgreSQL,
and the version of pgsql_perl5
in your bug-report.
REQUIREMENTS:
-------------
- build, test and install Perl5 (at least 5.002)
- build, test and install PostgreSQL (at least 6.4)
PLATFORMS:
----------
This release of pgsql_perl5 has been developed using Linux 2.0 with
dynamic loading for the perl extensions. Let me know, if there are
any problems with other platforms.
INSTALLATION:
-------------
Since the perl5 interface is always contained in the source tree of PostgreSQL,
it is usually build together with PostgreSQL itself. This can be obtained by
adding the option '--with-perl' to the configure command.
In case you need to build the perl interface stand alone, you need to set the
environment variable POSTGRES_HOME, pointing to the PostgreSQL home-directory.
Also PostgreSQL needs to be installed having the include files in
$POSTGRES_HOME/include and the libs in $POSTGRES_HOME/lib. Then you have to
build the module as any standard perl-module with the following commands:
1. perl Makefile.PL
2. make
3. make test
4. make install
( 1. to 3. as normal user, not as root ! )
TESTING:
--------
Run 'make test'.
Note, that the user running this script must have been created with the access
rights to create databases *AND* users ! Do not run this script as root !
If testing fails with the message 'login failed', please check if access
to the database template1 as well as pgperltest is not protected via pg_hba.conf.
If you are using the shared library libpq.so check if your dynamic loader
finds libpq.so. With Linux the command /sbin/ldconfig -v should tell you,
where it finds libpq.so. If ldconfig does not find libpq.so, either add an
appropriate entry to /etc/ld.so.conf and re-run ldconfig or add the path to
the environment variable LD_LIBRARY_PATH.
A typical error message resulting from not finding libpq.so is:
Can't load './blib/arch/auto/Pg/Pg.so' for module Pg: File not found at
Some linux distributions have an incomplete perl installation.
If you have compile errors like "XS_VERSION_BOOTCHECK undeclared", make a
'find .../lib/perl5 -name XSUB.h -print'
If this file is not present, you need to recompile and reinstall perl.
Also RedHat 5.0 seems to have an incomplete perl-installation: if
you get error message during the installation complaining about a
missing perllocal.pod, you need to recompile and reinstall perl.
SGI users: if you get segmentation faults make sure, you use the malloc which
comes with perl when compiling perl (the default is not to).
"David R. Noble" <drnoble@engsci.sandia.gov>
HP users: if you get error messages like:
can't open shared library: .../lib/libpq.sl
No such file or directory
when running the test script, try to replace the
'shared' option in the LDDFLAGS with 'archive'.
Dan Lauterbach <danla@dimensional.com>
DOCUMENTATION:
--------------
Detailed documentation can be found in Pg.pm. Use 'perldoc Pg' after
installation to read the documentation.
---------------------------------------------------------------------------
Edmund Mergl <E.Mergl@bawue.de> September 27, 1998
---------------------------------------------------------------------------

55
src/interfaces/perl5/examples/ApachePg.pl
View File

@ -1,55 +0,0 @@
#!/usr/bin/perl
# $Id: ApachePg.pl,v 1.2 2001/09/04 11:41:04 petere Exp $
# demo script, tested with:
# - PostgreSQL-6.4
# - apache_1.3.1
# - mod_perl-1.15
# - perl5.005_02
use CGI;
use Pg;
use strict;
my $query = new CGI;
print $query->header,
$query->start_html(-title=>'A Simple Example'),
$query->startform,
"<CENTER><H3>Testing Module Pg</H3></CENTER>",
"<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>",
"<TR><TD>Enter conninfo string: </TD>",
"<TD>", $query->textfield(-name=>'conninfo', -size=>40, -default=>'dbname=template1'), "</TD>",
"</TR>",
"<TR><TD>Enter select command: </TD>",
"<TD>", $query->textfield(-name=>'cmd', -size=>40), "</TD>",
"</TR>",
"</TABLE></CENTER><P>",
"<CENTER>", $query->submit(-value=>'Submit'), "</CENTER>",
$query->endform;
if ($query->param) {
my $conninfo = $query->param('conninfo');
my $conn = Pg::connectdb($conninfo);
if (PGRES_CONNECTION_OK == $conn->status) {
my $cmd = $query->param('cmd');
my $result = $conn->exec($cmd);
if (PGRES_TUPLES_OK == $result->resultStatus) {
print "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>\n";
my @row;
while (@row = $result->fetchrow) {
print "<TR><TD>", join("</TD><TD>", @row), "</TD></TR>";
}
print "</TABLE></CENTER><P>\n";
} else {
print "<CENTER><H2>", $conn->errorMessage, "</H2></CENTER>\n";
}
} else {
print "<CENTER><H2>", $conn->errorMessage, "</H2></CENTER>\n";
}
}
print $query->end_html;

274
src/interfaces/perl5/examples/example.newstyle
View File

@ -1,274 +0,0 @@
#!/usr/bin/perl
# $Id: example.newstyle,v 1.2 2001/09/04 11:41:04 petere Exp $
######################### globals
$| = 1;
use Pg;
$dbmain = 'template1';
$dbname = 'pgperltest';
$trace = '/tmp/pgtrace.out';
$DEBUG = 0; # set this to 1 for traces
######################### the following methods will be used
# connectdb
# conndefaults
# db
# user
# port
# status
# errorMessage
# trace
# untrace
# exec
# consumeInput
# getline
# putline
# endcopy
# resultStatus
# ntuples
# nfields
# fname
# fnumber
# ftype
# fsize
# cmdStatus
# oidStatus
# cmdTuples
# getvalue
# print
# notifies
# lo_import
# lo_export
# lo_unlink
######################### the following methods will not be used
# setdb
# setdbLogin
# reset
# requestCancel
# pass
# host
# tty
# options
# socket
# backendPID
# sendQuery
# getResult
# isBusy
# getlineAsync
# putnbytes
# makeEmptyPGresult
# fmod
# getlength
# getisnull
# displayTuples
# printTuples
# lo_open
# lo_close
# lo_read
# lo_write
# lo_creat
# lo_seek
# lo_tell
######################### handles error condition
$SIG{PIPE} = sub { print "broken pipe\n" };
######################### create and connect to test database
$Option_ref = Pg::conndefaults();
($key, $val);
print "connection defaults:\n";
while (($key, $val) = each %$Option_ref) {
printf " keyword = %-12.12s val = >%s<\n", $key, $val;
}
$conn = Pg::connectdb("dbname=$dbmain");
die $conn->errorMessage unless PGRES_CONNECTION_OK eq $conn->status;
print "connected to $dbmain\n";
# do not complain when dropping $dbname
$conn->exec("DROP DATABASE $dbname");
$result = $conn->exec("CREATE DATABASE $dbname");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "created database $dbname\n";
$conn = Pg::connectdb("dbname=$dbname");
die $conn->errorMessage unless PGRES_CONNECTION_OK eq $conn->status;
print "connected to $dbname\n";
######################### debug, trace
if ($DEBUG) {
open(TRACE, ">$trace") || die "can not open $trace: $!";
$conn->trace(TRACE);
print "enabled tracing into $trace\n";
}
######################### check PGconn
$db = $conn->db;
print " database: $db\n";
$user = $conn->user;
print " user: $user\n";
$port = $conn->port;
print " port: $port\n";
######################### create and insert into table
$result = $conn->exec("CREATE TABLE person (id int4, name char(16))");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "created table, status = ", $result->cmdStatus, "\n";
for ($i = 1; $i <= 5; $i++) {
$result = $conn->exec("INSERT INTO person VALUES ($i, 'Edmund Mergl')");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
}
print "insert into table, last oid = ", $result->oidStatus, "\n";
######################### copy to stdout, getline
$result = $conn->exec("COPY person TO STDOUT");
die $conn->errorMessage unless PGRES_COPY_OUT eq $result->resultStatus;
print "copy table to STDOUT:\n";
$ret = 0;
$i = 1;
while (-1 != $ret) {
$ret = $conn->getline($string, 256);
last if $string eq "\\.";
print " ", $string, "\n";
$i ++;
}
die $conn->errorMessage unless 0 == $conn->endcopy;
######################### delete and copy from stdin, putline
$result = $conn->exec("BEGIN");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
$result = $conn->exec("DELETE FROM person");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "delete from table, command status = ", $result->cmdStatus, ", no. of tuples = ", $result->cmdTuples, "\n";
$result = $conn->exec("COPY person FROM STDIN");
die $conn->errorMessage unless PGRES_COPY_IN eq $result->resultStatus;
print "copy table from STDIN: ";
for ($i = 1; $i <= 5; $i++) {
# watch the tabs and do not forget the newlines
$conn->putline("$i Edmund Mergl\n");
}
$conn->putline("\\.\n");
die $conn->errorMessage unless 0 == $conn->endcopy;
$result = $conn->exec("END");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "ok\n";
######################### select from person, getvalue
$result = $conn->exec("SELECT * FROM person");
die $conn->errorMessage unless PGRES_TUPLES_OK eq $result->resultStatus;
print "select from table:\n";
for ($k = 0; $k < $result->nfields; $k++) {
print " field = ", $k, "\tfname = ", $result->fname($k), "\tftype = ", $result->ftype($k), "\tfsize = ", $result->fsize($k), "\tfnumber = ", $result->fnumber($result->fname($k)), "\n";
}
while (@row = $result->fetchrow) {
print " ", join(" ", @row), "\n";
}
######################### notifies
if (! defined($pid = fork)) {
die "can not fork: $!";
} elsif (! $pid) {
# I'm the child
sleep 2;
bless $conn;
$conn = Pg::connectdb("dbname=$dbname");
$result = $conn->exec("NOTIFY person");
exit;
}
$result = $conn->exec("LISTEN person");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "listen table: status = ", $result->cmdStatus, "\n";
while (1) {
$conn->consumeInput;
($table, $pid) = $conn->notifies;
last if $pid;
}
print "got notification: table = ", $table, " pid = ", $pid, "\n";
######################### print
$result = $conn->exec("SELECT * FROM person");
die $conn->errorMessage unless PGRES_TUPLES_OK eq $result->resultStatus;
print "select from table and print:\n";
$result->print(STDOUT, 0, 0, 0, 0, 0, 0, " ", "", "", "");
######################### lo_import, lo_export, lo_unlink
$lobject_in = '/tmp/gaga.in';
$lobject_out = '/tmp/gaga.out';
$data = "testing large objects using lo_import and lo_export";
open(FD, ">$lobject_in") or die "can not open $lobject_in";
print(FD $data);
close(FD);
$result = $conn->exec("BEGIN");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
$lobjOid = $conn->lo_import("$lobject_in") or die $conn->errorMessage;
print "importing file as large object, Oid = ", $lobjOid, "\n";
die $conn->errorMessage unless 1 == $conn->lo_export($lobjOid, "$lobject_out");
print "exporting large object as temporary file\n";
$result = $conn->exec("END");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "comparing imported file with exported file: ";
print "not " unless (-s "$lobject_in" == -s "$lobject_out");
print "ok\n";
die $conn->errorMessage if -1 == $conn->lo_unlink($lobjOid);
unlink $lobject_in;
unlink $lobject_out;
print "unlink large object\n";
######################### debug, untrace
if ($DEBUG) {
close(TRACE) || die "bad TRACE: $!";
$conn->untrace;
print "tracing disabled\n";
}
######################### disconnect and drop test database
$conn = Pg::connectdb("dbname=$dbmain");
die $conn->errorMessage unless PGRES_CONNECTION_OK eq $conn->status;
print "connected to $dbmain\n";
$result = $conn->exec("DROP DATABASE $dbname");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "drop database\n";
######################### EOF

294
src/interfaces/perl5/examples/example.oldstyle
View File

@ -1,294 +0,0 @@
#!/usr/bin/perl
# $Id: example.oldstyle,v 1.2 2001/09/04 11:41:04 petere Exp $
######################### globals
$| = 1;
use Pg;
$dbmain = 'template1';
$dbname = 'pgperltest';
$trace = '/tmp/pgtrace.out';
$DEBUG = 0; # set this to 1 for traces
######################### the following functions will be tested
# PQsetdb()
# PQdb()
# PQuser()
# PQport()
# PQstatus()
# PQfinish()
# PQerrorMessage()
# PQtrace()
# PQuntrace()
# PQexec()
# PQconsumeInput
# PQgetline()
# PQputline()
# PQendcopy()
# PQresultStatus()
# PQntuples()
# PQnfields()
# PQfname()
# PQfnumber()
# PQftype()
# PQfsize()
# PQcmdStatus()
# PQoidStatus()
# PQcmdTuples()
# PQgetvalue()
# PQclear()
# PQprint()
# PQnotifies()
# PQlo_import()
# PQlo_export()
# PQlo_unlink()
######################### the following functions will not be tested
# PQconnectdb()
# PQconndefaults()
# PQsetdbLogin()
# PQreset()
# PQrequestCancel()
# PQpass()
# PQhost()
# PQtty()
# PQoptions()
# PQsocket()
# PQbackendPID()
# PQsendQuery()
# PQgetResult()
# PQisBusy()
# PQgetlineAsync()
# PQputnbytes()
# PQmakeEmptyPGresult()
# PQfmod()
# PQgetlength()
# PQgetisnull()
# PQdisplayTuples()
# PQprintTuples()
# PQlo_open()
# PQlo_close()
# PQlo_read()
# PQlo_write()
# PQlo_creat()
# PQlo_lseek()
# PQlo_tell()
######################### handles error condition
$SIG{PIPE} = sub { print "broken pipe\n" };
######################### create and connect to test database
$conn = PQsetdb('', '', '', '', $dbmain);
die PQerrorMessage($conn) unless PGRES_CONNECTION_OK eq PQstatus($conn);
print "connected to $dbmain\n";
# do not complain when dropping $dbname
$result = PQexec($conn, "DROP DATABASE $dbname");
PQclear($result);
$result = PQexec($conn, "CREATE DATABASE $dbname");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
print "created database $dbname\n";
PQclear($result);
PQfinish($conn);
$conn = PQsetdb('', '', '', '', $dbname);
die PQerrorMessage($conn) unless PGRES_CONNECTION_OK eq PQstatus($conn);
print "connected to $dbname\n";
######################### debug, PQtrace
if ($DEBUG) {
open(TRACE, ">$trace") || die "can not open $trace: $!";
PQtrace($conn, TRACE);
print "enabled tracing into $trace\n";
}
######################### check PGconn
$db = PQdb($conn);
print " database: $db\n";
$user = PQuser($conn);
print " user: $user\n";
$port = PQport($conn);
print " port: $port\n";
######################### create and insert into table
$result = PQexec($conn, "CREATE TABLE person (id int4, name char(16))");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
print "created table, status = ", PQcmdStatus($result), "\n";
PQclear($result);
for ($i = 1; $i <= 5; $i++) {
$result = PQexec($conn, "INSERT INTO person VALUES ($i, 'Edmund Mergl')");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
PQclear($result);
}
print "insert into table, last oid = ", PQoidStatus($result), "\n";
######################### copy to stdout, PQgetline
$result = PQexec($conn, "COPY person TO STDOUT");
die PQerrorMessage($conn) unless PGRES_COPY_OUT eq PQresultStatus($result);
print "copy table to STDOUT:\n";
PQclear($result);
$ret = 0;
$i = 1;
while (-1 != $ret) {
$ret = PQgetline($conn, $string, 256);
last if $string eq "\\.";
print " ", $string, "\n";
$i++;
}
die PQerrorMessage($conn) unless 0 == PQendcopy($conn);
######################### delete and copy from stdin, PQputline
$result = PQexec($conn, "BEGIN");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
PQclear($result);
$result = PQexec($conn, "DELETE FROM person");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
print "delete from table, command status = ", PQcmdStatus($result), ", no. of tuples = ", PQcmdTuples($result), "\n";
PQclear($result);
$result = PQexec($conn, "COPY person FROM STDIN");
die PQerrorMessage($conn) unless PGRES_COPY_IN eq PQresultStatus($result);
print "copy table from STDIN:\n";
PQclear($result);
for ($i = 1; $i <= 5; $i++) {
# watch the tabs and do not forget the newlines
PQputline($conn, "$i Edmund Mergl\n");
}
PQputline($conn, "\\.\n");
die PQerrorMessage($conn) unless 0 == PQendcopy($conn);
$result = PQexec($conn, "END");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
PQclear($result);
######################### select from person, PQgetvalue
$result = PQexec($conn, "SELECT * FROM person");
die PQerrorMessage($conn) unless PGRES_TUPLES_OK eq PQresultStatus($result);
print "select from table:\n";
for ($k = 0; $k < PQnfields($result); $k++) {
print " field = ", $k, "\tfname = ", PQfname($result, $k), "\tftype = ", PQftype($result, $k), "\tfsize = ", PQfsize($result, $k), "\tfnumber = ", PQfnumber($result, PQfname($result, $k)), "\n";
}
for ($k = 0; $k < PQntuples($result); $k++) {
for ($l = 0; $l < PQnfields($result); $l++) {
print " ", PQgetvalue($result, $k, $l);
}
print "\n";
}
PQclear($result);
######################### PQnotifies
if (! defined($pid = fork)) {
die "can not fork: $!";
} elsif (! $pid) {
# I'm the child
sleep 2;
$conn = PQsetdb('', '', '', '', $dbname);
$result = PQexec($conn, "NOTIFY person");
PQclear($result);
PQfinish($conn);
exit;
}
$result = PQexec($conn, "LISTEN person");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
print "listen table: status = ", PQcmdStatus($result), "\n";
PQclear($result);
while (1) {
PQconsumeInput($conn);
($table, $pid) = PQnotifies($conn);
last if $pid;
}
print "got notification: table = ", $table, " pid = ", $pid, "\n";
######################### PQprint
$result = PQexec($conn, "SELECT * FROM person");
die PQerrorMessage($conn) unless PGRES_TUPLES_OK eq PQresultStatus($result);
print "select from table and print:\n";
PQprint(STDOUT, $result, 0, 0, 0, 0, 0, 0, " ", "", "", "");
PQclear($result);
######################### PQlo_import, PQlo_export, PQlo_unlink
$lobject_in = '/tmp/gaga.in';
$lobject_out = '/tmp/gaga.out';
$data = "testing large objects using lo_import and lo_export";
open(FD, ">$lobject_in") or die "can not open $lobject_in";
print(FD $data);
close(FD);
$result = PQexec($conn, "BEGIN");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
PQclear($result);
$lobjOid = PQlo_import($conn, "$lobject_in") or die PQerrorMessage($conn);
print "importing file as large object, Oid = ", $lobjOid, "\n";
die PQerrorMessage($conn) unless 1 == PQlo_export($conn, $lobjOid, "$lobject_out");
print "exporting large object as temporary file\n";
$result = PQexec($conn, "END");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
PQclear($result);
print "comparing imported file with exported file: ";
print "not " unless (-s "$lobject_in" == -s "$lobject_out");
print "ok\n";
die PQerrorMessage($conn) if -1 == PQlo_unlink($conn, $lobjOid);
unlink $lobject_in;
unlink $lobject_out;
print "unlink large object\n";
######################### debug, PQuntrace
if ($DEBUG) {
close(TRACE) || die "bad TRACE: $!";
PQuntrace($conn);
print "tracing disabled\n";
}
######################### disconnect and drop test database
PQfinish($conn);
$conn = PQsetdb('', '', '', '', $dbmain);
die PQerrorMessage($conn) unless PGRES_CONNECTION_OK eq PQstatus($conn);
print "connected to $dbmain\n";
$result = PQexec($conn, "DROP DATABASE $dbname");
die PQerrorMessage($conn) unless PGRES_COMMAND_OK eq PQresultStatus($result);
print "drop database\n";
PQclear($result);
PQfinish($conn);
######################### EOF

289
src/interfaces/perl5/ppport.h
View File

@ -1,289 +0,0 @@
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
/* Perl/Pollution/Portability Version 1.0007 */
/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
distributed under the same license as any version of Perl. */
/* For the latest version of this code, please retreive the Devel::PPPort
module from CPAN, contact the author at <kjahds@kjahds.com>, or check
with the Perl maintainers. */
/* If you needed to customize this file for your project, please mention
your changes, and visible alter the version number. */
/*
In order for a Perl extension module to be as portable as possible
across differing versions of Perl itself, certain steps need to be taken.
Including this header is the first major one, then using dTHR is all the
appropriate places and using a PL_ prefix to refer to global Perl
variables is the second.
*/
/* If you use one of a few functions that were not present in earlier
versions of Perl, please add a define before the inclusion of ppport.h
for a static include, or use the GLOBAL request in a single module to
produce a global definition that can be referenced from the other
modules.
Function: Static define: Extern define:
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
*/
/* To verify whether ppport.h is needed for your module, and whether any
special defines should be used, ppport.h can be run through Perl to check
your source code. Simply say:
perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
The result will be a list of patches suggesting changes that should at
least be acceptable, if not necessarily the most efficient solution, or a
fix for all possible problems. It won't catch where dTHR is needed, and
doesn't attempt to account for global macro or function definitions,
nested includes, typemaps, etc.
In order to test for the need of dTHR, please try your module under a
recent version of Perl that has threading compiled-in.
*/
/*
#!/usr/bin/perl
@ARGV = ("*.xs") if !@ARGV;
%badmacros = %funcs = %macros = (); $replace = 0;
foreach (<DATA>) {
$funcs{$1} = 1 if /Provide:\s+(\S+)/;
$macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
$replace = $1 if /Replace:\s+(\d+)/;
$badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
$badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
}
foreach $filename (map(glob($_),@ARGV)) {
unless (open(IN, "<$filename")) {
warn "Unable to read from $file: $!\n";
next;
}
print "Scanning $filename...\n";
$c = ""; while (<IN>) { $c .= $_; } close(IN);
$need_include = 0; %add_func = (); $changes = 0;
$has_include = ($c =~ /#.*include.*ppport/m);
foreach $func (keys %funcs) {
if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
if ($c !~ /\b$func\b/m) {
print "If $func isn't needed, you don't need to request it.\n" if
$changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
} else {
print "Uses $func\n";
$need_include = 1;
}
} else {
if ($c =~ /\b$func\b/m) {
$add_func{$func} =1 ;
print "Uses $func\n";
$need_include = 1;
}
}
}
if (not $need_include) {
foreach $macro (keys %macros) {
if ($c =~ /\b$macro\b/m) {
print "Uses $macro\n";
$need_include = 1;
}
}
}
foreach $badmacro (keys %badmacros) {
if ($c =~ /\b$badmacro\b/m) {
$changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
$need_include = 1;
}
}
if (scalar(keys %add_func) or $need_include != $has_include) {
if (!$has_include) {
$inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
"#include \"ppport.h\"\n";
$c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
} elsif (keys %add_func) {
$inc = join('',map("#define NEED_$_\n", sort keys %add_func));
$c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
}
if (!$need_include) {
print "Doesn't seem to need ppport.h.\n";
$c =~ s/^.*#.*include.*ppport.*\n//m;
}
$changes++;
}
if ($changes) {
open(OUT,">/tmp/ppport.h.$$");
print OUT $c;
close(OUT);
open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
close(DIFF);
unlink("/tmp/ppport.h.$$");
} else {
print "Looks OK\n";
}
}
__DATA__
*/
#ifndef PERL_REVISION
#ifndef __PATCHLEVEL_H_INCLUDED__
#include "patchlevel.h"
#endif
#ifndef PERL_REVISION
#define PERL_REVISION (5)
/* Replace: 1 */
#define PERL_VERSION PATCHLEVEL
#define PERL_SUBVERSION SUBVERSION
/* Replace PERL_PATCHLEVEL with PERL_VERSION */
/* Replace: 0 */
#endif
#endif
#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
#ifndef ERRSV
#define ERRSV perl_get_sv("@",FALSE)
#endif
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
/* Replace: 1 */
#define PL_sv_undef sv_undef
#define PL_sv_yes sv_yes
#define PL_sv_no sv_no
#define PL_na na
#define PL_stdingv stdingv
#define PL_hints hints
#define PL_curcop curcop
#define PL_curstash curstash
#define PL_copline copline
#define PL_Sv Sv
/* Replace: 0 */
#endif
#ifndef dTHR
#ifdef WIN32
#define dTHR extern int Perl___notused
#else
#define dTHR extern int errno
#endif
#endif
#ifndef boolSV
#define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
#endif
#ifndef gv_stashpvn
#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
#endif
#ifndef newSVpvn
#define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
#endif
#ifndef newRV_inc
/* Replace: 1 */
#define newRV_inc(sv) newRV(sv)
/* Replace: 0 */
#endif
#ifndef newRV_noinc
#ifdef __GNUC__
#define newRV_noinc(sv) \
({ \
SV *nsv = (SV*)newRV(sv); \
SvREFCNT_dec(sv); \
nsv; \
})
#else
#if defined(CRIPPLED_CC) || defined(USE_THREADS)
static SV *
newRV_noinc(SV * sv)
{
SV *nsv = (SV *) newRV(sv);
SvREFCNT_dec(sv);
return nsv;
}
#else
#define newRV_noinc(sv) \
((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
#endif
#endif
#endif
/* Provide: newCONSTSUB */
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
#if defined(NEED_newCONSTSUB)
static
#else
extern void newCONSTSUB _((HV * stash, char *name, SV * sv));
#endif
#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
void
newCONSTSUB(stash, name, sv)
HV *stash;
char *name;
SV *sv;
{
U32 oldhints = PL_hints;
HV *old_cop_stash = PL_curcop->cop_stash;
HV *old_curstash = PL_curstash;
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
/* before 5.003_22 */
start_subparse(),
#else
#if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
/* 5.003_22 */
start_subparse(0),
#else
/* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
#endif
newSVOP(OP_CONST, 0, newSVpv(name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == ""
* -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
PL_curcop->cop_line = oldline;
}
#endif
#endif /* newCONSTSUB */
#endif /* _P_P_PORTABILITY_H_ */

275
src/interfaces/perl5/test.pl
View File

@ -1,275 +0,0 @@
#!/usr/bin/perl -w
# $Id: test.pl,v 1.14 2001/09/04 11:41:04 petere Exp $
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
BEGIN { $| = 1; }
END {print "test failed\n" unless $loaded;}
use Pg;
$loaded = 1;
use strict;
######################### End of black magic.
my $dbmain = 'template1';
my $dbname = 'pgperltest';
my $trace = '/tmp/pgtrace.out';
my ($conn, $result, $i);
my $DEBUG = 0; # set this to 1 for traces
######################### the following methods will be tested
# connectdb
# conndefaults
# db
# user
# port
# status
# errorMessage
# trace
# untrace
# exec
# getline
# putline
# endcopy
# resultStatus
# fname
# fnumber
# ftype
# fsize
# cmdStatus
# oidStatus
# cmdTuples
# fetchrow
######################### the following methods will not be tested
# setdb
# setdbLogin
# reset
# requestCancel
# pass
# host
# tty
# options
# socket
# backendPID
# notifies
# sendQuery
# getResult
# isBusy
# consumeInput
# getlineAsync
# putnbytes
# makeEmptyPGresult
# ntuples
# nfields
# binaryTuples
# fmod
# getvalue
# getlength
# getisnull
# print
# displayTuples
# printTuples
# lo_import
# lo_export
# lo_unlink
# lo_open
# lo_close
# lo_read
# lo_write
# lo_creat
# lo_seek
# lo_tell
######################### handles error condition
$SIG{PIPE} = sub { print "broken pipe\n" };
######################### create and connect to test database
my $Option_ref = Pg::conndefaults();
my ($key, $val);
( $$Option_ref{port} ne "" && $$Option_ref{dbname} ne "" && $$Option_ref{user} ne "" )
and print "Pg::conndefaults ........ ok\n"
or die "Pg::conndefaults ........ not ok: ", $conn->errorMessage;
$conn = Pg::connectdb("dbname=$dbmain");
( PGRES_CONNECTION_OK eq $conn->status )
and print "Pg::connectdb ........... ok\n"
or die "Pg::connectdb ........... not ok: ", $conn->errorMessage;
# do not complain when dropping $dbname
$conn->exec("DROP DATABASE $dbname");
$result = $conn->exec("CREATE DATABASE $dbname");
( PGRES_COMMAND_OK eq $result->resultStatus )
and print "\$conn->exec ............. ok\n"
or die "\$conn->exec ............. not ok: ", $conn->errorMessage;
$conn = Pg::connectdb("dbname=rumpumpel");
( $conn->errorMessage =~ 'Database "rumpumpel" does not exist' )
and print "\$conn->errorMessage ..... ok\n"
or die "\$conn->errorMessage ..... not ok: ", $conn->errorMessage;
$conn = Pg::connectdb("dbname=$dbname");
die $conn->errorMessage unless PGRES_CONNECTION_OK eq $conn->status;
######################### debug, PQtrace
if ($DEBUG) {
open(FD, ">$trace") || die "can not open $trace: $!";
$conn->trace("FD");
}
######################### check PGconn
my $db = $conn->db;
( $dbname eq $db )
and print "\$conn->db ............... ok\n"
or print "\$conn->db ............... not ok: $db\n";
my $user = $conn->user;
( "" ne $user )
and print "\$conn->user ............. ok\n"
or print "\$conn->user ............. not ok: $user\n";
my $port = $conn->port;
( "" ne $port )
and print "\$conn->port ............. ok\n"
or print "\$conn->port ............. not ok: $port\n";
######################### create and insert into table
# we test comments inside string and with no trailing newline here
$result = $conn->exec("CREATE TABLE person (id int4, -- test\n name char(16)) -- test");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
my $cmd = $result->cmdStatus;
( "CREATE" eq $cmd )
and print "\$conn->cmdStatus ........ ok\n"
or print "\$conn->cmdStatus ........ not ok: $cmd\n";
for ($i = 1; $i <= 5; $i++) {
$result = $conn->exec("INSERT INTO person VALUES ($i, 'Edmund Mergl')");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
}
my $oid = $result->oidStatus;
( 0 != $oid )
and print "\$conn->oidStatus ........ ok\n"
or print "\$conn->oidStatus ........ not ok: $oid\n";
######################### copy to stdout, PQgetline
$result = $conn->exec("COPY person TO STDOUT");
die $conn->errorMessage unless PGRES_COPY_OUT eq $result->resultStatus;
my $ret = 0;
my $buf;
my $string;
$i = 1;
while (-1 != $ret) {
$ret = $conn->getline($buf, 256);
last if $buf eq "\\.";
$string = $buf if 1 == $i;
$i++;
}
( "1 Edmund Mergl " eq $string )
and print "\$conn->getline .......... ok\n"
or print "\$conn->getline .......... not ok: $string\n";
$ret = $conn->endcopy;
( 0 == $ret )
and print "\$conn->endcopy .......... ok\n"
or print "\$conn->endcopy .......... not ok: $ret\n";
######################### delete and copy from stdin, PQputline
$result = $conn->exec("BEGIN");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
$result = $conn->exec("DELETE FROM person");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
$ret = $result->cmdTuples;
( 5 == $ret )
and print "\$result->cmdTuples ...... ok\n"
or print "\$result->cmdTuples ...... not ok: $ret\n";
$result = $conn->exec("COPY person FROM STDIN");
die $conn->errorMessage unless PGRES_COPY_IN eq $result->resultStatus;
for ($i = 1; $i <= 5; $i++) {
# watch the tabs and do not forget the newlines
$conn->putline("$i Edmund Mergl\n");
}
$conn->putline("\\.\n");
die $conn->errorMessage if $conn->endcopy;
$result = $conn->exec("END");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
######################### select from person, PQgetvalue
$result = $conn->exec("SELECT * FROM person");
die $conn->errorMessage unless PGRES_TUPLES_OK eq $result->resultStatus;
my $fname = $result->fname(0);
( "id" eq $fname )
and print "\$result->fname .......... ok\n"
or print "\$result->fname .......... not ok: $fname\n";
my $ftype = $result->ftype(0);
( 23 == $ftype )
and print "\$result->ftype .......... ok\n"
or print "\$result->ftype .......... not ok: $ftype\n";
my $fsize = $result->fsize(0);
( 4 == $fsize )
and print "\$result->fsize .......... ok\n"
or print "\$result->fsize .......... not ok: $fsize\n";
my $fnumber = $result->fnumber($fname);
( 0 == $fnumber )
and print "\$result->fnumber ........ ok\n"
or print "\$result->fnumber ........ not ok: $fnumber\n";
$string = "";
my @row;
while (@row = $result->fetchrow) {
$string = join(" ", @row);
}
( "5 Edmund Mergl " eq $string )
and print "\$result->fetchrow ....... ok\n"
or print "\$result->fetchrow ....... not ok: $string\n";
######################### debug, PQuntrace
if ($DEBUG) {
close(FD) || die "bad TRACE: $!";
$conn->untrace;
}
######################### disconnect and drop test database
$conn = Pg::connectdb("dbname=$dbmain");
die $conn->errorMessage unless PGRES_CONNECTION_OK eq $conn->status;
# Race condition: it's quite possible that the DROP command will arrive
# at the new backend before the old backend has finished shutting down,
# resulting in an error message.
# There doesn't seem to be any more graceful way around this than to
# insert a small delay ...
sleep(1);
$result = $conn->exec("DROP DATABASE $dbname");
die $conn->errorMessage unless PGRES_COMMAND_OK eq $result->resultStatus;
print "test sequence finished.\n";
######################### EOF

18
src/interfaces/perl5/typemap
View File

@ -1,18 +0,0 @@
#-------------------------------------------------------
#
# $Id: typemap,v 1.8 1998/09/27 19:12:27 mergl Exp $
#
# Copyright (c) 1997, 1998 Edmund Mergl
#
#-------------------------------------------------------
TYPEMAP
PGconn * T_PTRREF
PGresult * T_PTRREF
PG_conn T_PTROBJ
PG_result T_PTROBJ
PG_results T_PTROBJ
ConnStatusType T_IV
ExecStatusType T_IV
Oid T_IV
pqbool T_IV