opensourcemirror
/
postgresql
mirror of git://git.postgresql.org/git/postgresql.git
1
0
Fork 0
Code Issues Releases Wiki Activity

creation for postgresql-6.1

This commit is contained in:
Edmund Mergl 1997-04-29 19:37:10 +00:00
parent a2fd844c3b
commit 0aba92a2c5
11 changed files with 2681 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
src/interfaces/perl5/ApachePg.pl Normal file
View File

@ -0,0 +1,47 @@
#!/usr/local/bin/perl
# demo script, has been tested with:
# - Postgres-6.1
# - apache_1.2b8
# - mod_perl-0.97
# - perl5.003_93
use CGI::Apache;
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>",
"Enter the database name: ",
$query->textfield(-name=>'dbname'),
"<P>",
"Enter the select command: ",
$query->textfield(-name=>'cmd', -size=>40),
"<P>",
$query->submit(-value=>'Submit'),
$query->endform;
if ($query->param) {
my $dbname = $query->param('dbname');
my $conn = Pg::connectdb("dbname = $dbname");
my $cmd = $query->param('cmd');
my $result = $conn->exec($cmd);
my $i, $j;
print "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>\n";
for ($i=0; $i < $result->ntuples; $i++) {
print "<TR>\n";
for ($j=0; $j < $result->nfields; $j++) {
print "<TD ALIGN=CENTER>", $result->getvalue($i, $j), "\n";
}
}
print "</TABLE></CENTER><P>\n";
}
print $query->end_html;

58
src/interfaces/perl5/Changes Normal file
View File

@ -0,0 +1,58 @@
Revision history for Perl extension Pg.
1.0 Mar 24, 1995
- creation
1.1 Jun 6, 1995
- Bug fix in PQgetline.
1.1.1 Aug 5, 95
- adapted to postgres95-beta0.03
- Note: the libpq interface has changed completely !
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.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.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.4.2 Nov 21, 1996
- added a more Perl-like syntax
1.5.3 Jan 2, 1997
- adapted to PostgreSQL-6.0
- new functions PQconnectdb, PQuser
- changed name of method 'new' to 'setdb'
1.5.4 Feb 12, 1997
- changed test.pl for large objects:
test only lo_import and lo_export
1.6.0 Apr 29, 1997
- renamed to pgsql_perl5
- adapted to PostgreSQL-6.1
- test only functions, which are also
tested in pgsql regression tests

11
src/interfaces/perl5/MANIFEST Normal file
View File

@ -0,0 +1,11 @@
ApachePg.pl
Changes
MANIFEST
Makefile.PL
Pg.pm
Pg.xs
README
test.pl
test.pl.newstyle
test.pl.oldstyle
typemap

38
src/interfaces/perl5/Makefile.PL Normal file
View File

@ -0,0 +1,38 @@
#-------------------------------------------------------
#
# $Id: Makefile.PL,v 1.1.1.1 1997/04/29 19:37:09 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
use ExtUtils::MakeMaker;
print "\nConfiguring Pg\n";
print "Remember to actually read the README file !\n";
die "\nYou didn't read the README file !\n" unless ($] >= 5.003);
if (! $ENV{POSTGRESHOME}) {
warn "\$POSTGRESHOME not defined. Searching for Postgres...\n";
foreach(qw(/usr/pgsql /usr/local/pgsql /usr/pgsql-6.1 /usr/local/pgsql-6.1)) {
if (-d "$_/lib") {
$ENV{POSTGRESHOME} = $_;
last;
}
}
}
if ($ENV{POSTGRESHOME}) {
print "\nFound Postgres in $ENV{POSTGRESHOME}\n";
} else {
die "Unable to determine \$POSTGRESHOME !\n";
}
WriteMakefile(
'NAME' => 'Pg',
'VERSION_FROM' => 'Pg.pm',
'LIBS' => ["-L$ENV{POSTGRESHOME}/lib -lpq"],
'INC' => "-I$ENV{POSTGRESHOME}/include",
);
# EOF

534
src/interfaces/perl5/Pg.pm Normal file
View File

@ -0,0 +1,534 @@
#-------------------------------------------------------
#
# $Id: Pg.pm,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
package Pg;
use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
require Exporter;
require DynaLoader;
require AutoLoader;
require 5.003;
@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default.
@EXPORT = qw(
PQconnectdb
PQconndefaults
PQsetdb
PQfinish
PQreset
PQdb
PQuser
PQhost
PQoptions
PQport
PQtty
PQstatus
PQerrorMessage
PQtrace
PQuntrace
PQexec
PQgetline
PQendcopy
PQputline
PQnotifies
PQresultStatus
PQntuples
PQnfields
PQfname
PQfnumber
PQftype
PQfsize
PQcmdStatus
PQoidStatus
PQgetvalue
PQgetlength
PQgetisnull
PQclear
PQprintTuples
PQprint
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_ARCHIVE
PGRES_INV_WRITE
PGRES_INV_READ
PGRES_InvalidOid
);
$VERSION = '1.6.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, $nfields, $ntuples, $i, $j);
$result = PQexec($conn, $query);
$status = PQresultStatus($result);
return($status) if (2 != $status);
$nfields = PQnfields($result);
$ntuples = PQntuples($result);
for ($i=0; $i < $ntuples; $i++) {
for ($j=0; $j < $nfields; $j++) {
$$array_ref[$i][$j] = PQgetvalue($result, $i, $j);
}
}
PQclear($result);
return 1;
}
1;
__END__
=head1 NAME
Pg - Perl extension for PostgreSQL
=head1 SYNOPSIS
new style:
use Pg;
$conn = Pg::connectdb("dbname = template1");
$result = $conn->exec("create database test");
you may also use the old style:
use Pg;
$conn = PQsetdb('', '', '', '', template1);
$result = PQexec($conn, "create database test");
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.
=head2 old style
All functions and constants are imported into the calling
packages namespace. 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.
=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. Using the appropriate methods you can access almost all
fields of this structure.
$conn = Pg::setdb($pghost, $pgport, $pgoptions, $pgtty, $dbname)
Opens a new connection to the backend. You may use an empty string for
any argument, in which case first the environment is checked and then
hardcoded defaults are used. 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. Use the methods below to access
the contents of the PGconn structure.
$conn = Pg::connectdb("option = value")
Opens a new connection to the backend using connection information in a string.
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.
Use the methods below to access the contents of the PGconn structure.
$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 all memory.
$conn->reset
Resets the communication port with the backend and tries
to establish a new connection.
$dbname = $conn->db
Returns the database name of the connection.
$pguser = $conn->user
Returns the Postgres user name of the connection.
$pghost = $conn->host
Returns the host name of the connection.
$pgoptions = $conn->options
Returns the options used in the connection.
$pgport = $conn->port
Returns the port of the connection.
$pgtty = $conn->tty
Returns the tty of 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.
$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.
$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.
$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->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, nonzero otherwise.
($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.
=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.
Use the functions below to access the contents of the PGresult structure.
$ntups = $result->ntuples
Returns the number of tuples in the query result.
$nfields = $result->nfields
Returns the number of fields in the query result.
$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.
$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.
$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
$cmdStatus = $result->cmdStatus
Returns the command status of the last query command.
$oid = $result->oidStatus
In case the last query was an INSERT command it returns the oid of the
inserted tuple.
$result->printTuples($fout, $printAttName, $terseOutput, $width)
Kept for backward compatibility. Use print.
$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.
PQclear($result)
Old style only !
Frees all memory of the given result.
=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 analogues 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).
$lobjId = $conn->lo_creat($mode)
Creates a new large object. $mode is a bitmask describing
different attributes of the new object. Use the following constants:
- PGRES_INV_SMGRMASK
- PGRES_INV_ARCHIVE
- PGRES_INV_WRITE
- PGRES_INV_READ
Upon failure it returns PGRES_InvalidOid.
$ret = $conn->lo_unlink($lobjId)
Deletes a large object. Returns -1 upon failure.
$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).
$location = $conn->lo_tell($lobj_fd)
Returns the current read or write location on the large object
$lobj_fd.
$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
libpq(3), large_objects(3).
=cut

948
src/interfaces/perl5/Pg.xs Normal file
View File

@ -0,0 +1,948 @@
/*-------------------------------------------------------
*
* $Id: Pg.xs,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
*
* Copyright (c) 1997 Edmund Mergl
*
*-------------------------------------------------------*/
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef bool
#undef bool
#endif
#ifdef DEBUG
#undef DEBUG
#endif
#ifdef ABORT
#undef ABORT
#endif
#include "postgres.h"
#include "libpq-fe.h"
typedef struct pg_conn* PG_conn;
typedef struct pg_result* PG_result;
static double
constant(name, arg)
char *name;
int arg;
{
errno = 0;
switch (*name) {
case 'A':
break;
case 'B':
break;
case 'C':
break;
case 'D':
break;
case 'E':
break;
case 'F':
break;
case 'G':
break;
case 'H':
break;
case 'I':
break;
case 'J':
break;
case 'K':
break;
case 'L':
break;
case 'M':
break;
case 'N':
break;
case 'O':
break;
case 'P':
if (strEQ(name, "PGRES_CONNECTION_OK"))
return 0;
if (strEQ(name, "PGRES_CONNECTION_BAD"))
return 1;
if (strEQ(name, "PGRES_INV_SMGRMASK"))
return 0x0000ffff;
if (strEQ(name, "PGRES_INV_ARCHIVE"))
return 0x00010000;
if (strEQ(name, "PGRES_INV_WRITE"))
return 0x00020000;
if (strEQ(name, "PGRES_INV_READ"))
return 0x00040000;
if (strEQ(name, "PGRES_InvalidOid"))
return 0;
if (strEQ(name, "PGRES_EMPTY_QUERY"))
return 0;
if (strEQ(name, "PGRES_COMMAND_OK"))
return 1;
if (strEQ(name, "PGRES_TUPLES_OK"))
return 2;
if (strEQ(name, "PGRES_COPY_OUT"))
return 3;
if (strEQ(name, "PGRES_COPY_IN"))
return 4;
if (strEQ(name, "PGRES_BAD_RESPONSE"))
return 5;
if (strEQ(name, "PGRES_NONFATAL_ERROR"))
return 6;
if (strEQ(name, "PGRES_FATAL_ERROR"))
return 7;
break;
case 'Q':
break;
case 'R':
break;
case 'S':
break;
case 'T':
break;
case 'U':
break;
case 'V':
break;
case 'W':
break;
case 'X':
break;
case 'Y':
break;
case 'Z':
break;
case 'a':
break;
case 'b':
break;
case 'c':
break;
case 'd':
break;
case 'e':
break;
case 'f':
break;
case 'g':
break;
case 'h':
break;
case 'i':
break;
case 'j':
break;
case 'k':
break;
case 'l':
break;
case 'm':
break;
case 'n':
break;
case 'o':
break;
case 'p':
break;
case 'q':
break;
case 'r':
break;
case 's':
break;
case 't':
break;
case 'u':
break;
case 'v':
break;
case 'w':
break;
case 'x':
break;
case 'y':
break;
case 'z':
break;
}
errno = EINVAL;
return 0;
not_there:
errno = ENOENT;
return 0;
}
MODULE = Pg PACKAGE = Pg
PROTOTYPES: DISABLE
double
constant(name,arg)
char * name
int arg
PGconn *
PQconnectdb(conninfo)
char * conninfo
CODE:
RETVAL = PQconnectdb((const char *)conninfo);
OUTPUT:
RETVAL
HV *
PQconndefaults()
CODE:
PQconninfoOption *infoOption;
RETVAL = newHV();
if (infoOption = PQconndefaults()) {
while (infoOption->keyword != NULL) {
hv_store(RETVAL, infoOption->keyword, strlen(infoOption->keyword), newSVpv(infoOption->val, 0), 0);
infoOption++;
}
}
OUTPUT:
RETVAL
PGconn *
PQsetdb(pghost, pgport, pgoptions, pgtty, dbname)
char * pghost
char * pgport
char * pgoptions
char * pgtty
char * dbname
void
PQfinish(conn)
PGconn * conn
void
PQreset(conn)
PGconn * conn
char *
PQdb(conn)
PGconn * conn
char *
PQuser(conn)
PGconn * conn
char *
PQhost(conn)
PGconn * conn
char *
PQoptions(conn)
PGconn * conn
char *
PQport(conn)
PGconn * conn
char *
PQtty(conn)
PGconn * conn
ConnStatusType
PQstatus(conn)
PGconn * conn
char *
PQerrorMessage(conn)
PGconn * conn
void
PQtrace(conn, debug_port)
PGconn * conn
FILE * debug_port
void
PQuntrace(conn)
PGconn * conn
PGresult *
PQexec(conn, query)
PGconn * conn
char * query
CODE:
RETVAL = PQexec(conn, query);
if (! RETVAL) { RETVAL = (PGresult *)calloc(1, sizeof(PGresult)); }
OUTPUT:
RETVAL
int
PQgetline(conn, string, length)
PREINIT:
SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
INPUT:
PGconn * conn
int length
char * string = sv_grow(sv_buffer, length);
CODE:
RETVAL = PQgetline(conn, string, length);
OUTPUT:
RETVAL
string
int
PQendcopy(conn)
PGconn * conn
void
PQputline(conn, string)
PGconn * conn
char * string
void
PQnotifies(conn)
PGconn * conn
PREINIT:
PGnotify *notify;
PPCODE:
notify = PQnotifies(conn);
if (notify) {
XPUSHs(sv_2mortal(newSVpv((char *)notify->relname, 0)));
XPUSHs(sv_2mortal(newSViv(notify->be_pid)));
free(notify);
}
ExecStatusType
PQresultStatus(res)
PGresult * res
int
PQntuples(res)
PGresult * res
int
PQnfields(res)
PGresult * res
char *
PQfname(res, field_num)
PGresult * res
int field_num
int
PQfnumber(res, field_name)
PGresult * res
char * field_name
Oid
PQftype(res, field_num)
PGresult * res
int field_num
int2
PQfsize(res, field_num)
PGresult * res
int field_num
char *
PQcmdStatus(res)
PGresult * res
char *
PQoidStatus(res)
PGresult * res
PREINIT:
const char *GAGA;
CODE:
GAGA = PQoidStatus(res);
RETVAL = (char *)GAGA;
OUTPUT:
RETVAL
char *
PQgetvalue(res, tup_num, field_num)
PGresult * res
int tup_num
int field_num
int
PQgetlength(res, tup_num, field_num)
PGresult * res
int tup_num
int field_num
int
PQgetisnull(res, tup_num, field_num)
PGresult * res
int tup_num
int field_num
void
PQclear(res)
PGresult * res
void
PQprintTuples(res, fout, printAttName, terseOutput, width)
PGresult * res
FILE * fout
int printAttName
int terseOutput
int width
void
PQprint(fout, res, header, align, standard, html3, expanded, pager, fieldSep, tableOpt, caption, ...)
FILE * fout
PGresult * res
bool header
bool align
bool standard
bool html3
bool expanded
bool pager
char * fieldSep
char * tableOpt
char * caption
PREINIT:
PQprintOpt ps;
int i;
CODE:
ps.header = header;
ps.align = align;
ps.standard = standard;
ps.html3 = html3;
ps.expanded = expanded;
ps.pager = pager;
ps.fieldSep = fieldSep;
ps.tableOpt = tableOpt;
ps.caption = caption;
Newz(0, ps.fieldName, items + 1 - 11, char*);
for (i = 11; i < items; i++) {
ps.fieldName[i - 11] = (char *)SvPV(ST(i), na);
}
PQprint(fout, res, &ps);
Safefree(ps.fieldName);
int
lo_open(conn, lobjId, mode)
PGconn * conn
Oid lobjId
int mode
ALIAS:
PQlo_open = 1
int
lo_close(conn, fd)
PGconn * conn
int fd
ALIAS:
PQlo_close = 1
int
lo_read(conn, fd, buf, len)
ALIAS:
PQlo_read = 1
PREINIT:
SV *sv_buffer = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2);
INPUT:
PGconn * conn
int fd
int len
char * buf = sv_grow(sv_buffer, len + 1);
CLEANUP:
if (RETVAL >= 0) {
SvCUR(sv_buffer) = RETVAL;
SvPOK_only(sv_buffer);
*SvEND(sv_buffer) = '\0';
if (tainting) {
sv_magic(sv_buffer, 0, 't', 0, 0);
}
}
int
lo_write(conn, fd, buf, len)
PGconn * conn
int fd
char * buf
int len
ALIAS:
PQlo_write = 1
int
lo_lseek(conn, fd, offset, whence)
PGconn * conn
int fd
int offset
int whence
ALIAS:
PQlo_lseek = 1
Oid
lo_creat(conn, mode)
PGconn * conn
int mode
ALIAS:
PQlo_creat = 1
int
lo_tell(conn, fd)
PGconn * conn
int fd
ALIAS:
PQlo_tell = 1
int
lo_unlink(conn, lobjId)
PGconn * conn
Oid lobjId
ALIAS:
PQlo_unlink = 1
Oid
lo_import(conn, filename)
PGconn * conn
char * filename
ALIAS:
PQlo_import = 1
int
lo_export(conn, lobjId, filename)
PGconn * conn
Oid lobjId
char * filename
ALIAS:
PQlo_export = 1
PG_conn
connectdb(conninfo)
char * conninfo
CODE:
RETVAL = PQconnectdb((const char *)conninfo);
OUTPUT:
RETVAL
HV *
conndefaults()
CODE:
PQconninfoOption *infoOption;
RETVAL = newHV();
if (infoOption = PQconndefaults()) {
while (infoOption->keyword != NULL) {
hv_store(RETVAL, infoOption->keyword, strlen(infoOption->keyword), newSVpv(infoOption->val, 0), 0);
infoOption++;
}
}
OUTPUT:
RETVAL
PG_conn
setdb(pghost, pgport, pgoptions, pgtty, dbname)
char * pghost
char * pgport
char * pgoptions
char * pgtty
char * dbname
CODE:
RETVAL = PQsetdb(pghost, pgport, pgoptions, pgtty, dbname);
OUTPUT:
RETVAL
MODULE = Pg PACKAGE = PG_conn PREFIX = PQ
PROTOTYPES: DISABLE
void
DESTROY(conn)
PG_conn conn
CODE:
/* printf("DESTROY connection\n"); */
PQfinish(conn);
void
PQreset(conn)
PG_conn conn
char *
PQdb(conn)
PG_conn conn
char *
PQuser(conn)
PG_conn conn
char *
PQhost(conn)
PG_conn conn
char *
PQoptions(conn)
PG_conn conn
char *
PQport(conn)
PG_conn conn
char *
PQtty(conn)
PG_conn conn
ConnStatusType
PQstatus(conn)
PG_conn conn
char *
PQerrorMessage(conn)
PG_conn conn
void
PQtrace(conn, debug_port)
PG_conn conn
FILE * debug_port
void
PQuntrace(conn)
PG_conn conn
PG_result
PQexec(conn, query)
PG_conn conn
char * query
CODE:
RETVAL = PQexec(conn, query);
if (! RETVAL) { RETVAL = (PGresult *)calloc(1, sizeof(PGresult)); }
OUTPUT:
RETVAL
int
PQgetline(conn, string, length)
PREINIT:
SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
INPUT:
PG_conn conn
int length
char * string = sv_grow(sv_buffer, length);
CODE:
RETVAL = PQgetline(conn, string, length);
OUTPUT:
RETVAL
string
int
PQendcopy(conn)
PG_conn conn
void
PQputline(conn, string)
PG_conn conn
char * string
void
PQnotifies(conn)
PG_conn conn
PREINIT:
PGnotify *notify;
PPCODE:
notify = PQnotifies(conn);
if (notify) {
XPUSHs(sv_2mortal(newSVpv((char *)notify->relname, 0)));
XPUSHs(sv_2mortal(newSViv(notify->be_pid)));
free(notify);
}
int
lo_open(conn, lobjId, mode)
PG_conn conn
Oid lobjId
int mode
int
lo_close(conn, fd)
PG_conn conn
int fd
int
lo_read(conn, fd, buf, len)
PREINIT:
SV *sv_buffer = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2);
INPUT:
PG_conn conn
int fd
int len
char * buf = sv_grow(sv_buffer, len + 1);
CLEANUP:
if (RETVAL >= 0) {
SvCUR(sv_buffer) = RETVAL;
SvPOK_only(sv_buffer);
*SvEND(sv_buffer) = '\0';
if (tainting) {
sv_magic(sv_buffer, 0, 't', 0, 0);
}
}
int
lo_write(conn, fd, buf, len)
PG_conn conn
int fd
char * buf
int len
int
lo_lseek(conn, fd, offset, whence)
PG_conn conn
int fd
int offset
int whence
Oid
lo_creat(conn, mode)
PG_conn conn
int mode
int
lo_tell(conn, fd)
PG_conn conn
int fd
int
lo_unlink(conn, lobjId)
PG_conn conn
Oid lobjId
Oid
lo_import(conn, filename)
PG_conn conn
char * filename
int
lo_export(conn, lobjId, filename)
PG_conn conn
Oid lobjId
char * filename
MODULE = Pg PACKAGE = PG_result PREFIX = PQ
PROTOTYPES: DISABLE
void
DESTROY(res)
PG_result res
CODE:
/* printf("DESTROY result\n"); */
PQclear(res);
ExecStatusType
PQresultStatus(res)
PG_result res
int
PQntuples(res)
PG_result res
int
PQnfields(res)
PG_result res
char *
PQfname(res, field_num)
PG_result res
int field_num
int
PQfnumber(res, field_name)
PG_result res
char * field_name
Oid
PQftype(res, field_num)
PG_result res
int field_num
int2
PQfsize(res, field_num)
PG_result res
int field_num
char *
PQcmdStatus(res)
PG_result res
char *
PQoidStatus(res)
PG_result res
PREINIT:
const char *GAGA;
CODE:
GAGA = PQoidStatus(res);
RETVAL = (char *)GAGA;
OUTPUT:
RETVAL
char *
PQgetvalue(res, tup_num, field_num)
PG_result res
int tup_num
int field_num
int
PQgetlength(res, tup_num, field_num)
PG_result res
int tup_num
int field_num
int
PQgetisnull(res, tup_num, field_num)
PG_result res
int tup_num
int field_num
void
PQprintTuples(res, fout, printAttName, terseOutput, width)
PG_result res
FILE * fout
int printAttName
int terseOutput
int width
void
PQprint(res, fout, header, align, standard, html3, expanded, pager, fieldSep, tableOpt, caption, ...)
FILE * fout
PG_result res
bool header
bool align
bool standard
bool html3
bool expanded
bool pager
char * fieldSep
char * tableOpt
char * caption
PREINIT:
PQprintOpt ps;
int i;
CODE:
ps.header = header;
ps.align = align;
ps.standard = standard;
ps.html3 = html3;
ps.expanded = expanded;
ps.pager = pager;
ps.fieldSep = fieldSep;
ps.tableOpt = tableOpt;
ps.caption = caption;
Newz(0, ps.fieldName, items + 1 - 11, char*);
for (i = 11; i < items; i++) {
ps.fieldName[i - 11] = (char *)SvPV(ST(i), na);
}
PQprint(fout, res, &ps);
Safefree(ps.fieldName);

105
src/interfaces/perl5/README Normal file
View File

@ -0,0 +1,105 @@
#-------------------------------------------------------
#
# $Id: README,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
DESCRIPTION:
------------
This is version 1.6 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 LIBQ. 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.
COPYRIGHT INFO
--------------
This Postgres-Perl interface is copyright 1996, 1997 Edmund Mergl. You are
free to use it for any purpose, commercial or noncommercial, provided
that if you redistribute the source code, this statement of copyright
remains attached.
IF YOU HAVE PROBLEMS:
---------------------
Please send comments and bug-reports to <E.Mergl@bawue.de>
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:
-------------
- perl5.003
- PostgreSQL-6.1
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:
-------------
Using dynamic loading for perl extensions, the preferred method is to unpack
the tar file outside the perl source tree. This assumes, that you already
have installed perl5.
The Makefile checks the environment variable POSTGRESHOME as well some
standard locations, to find the root directory of your Postgres installation.
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 you are using the shared library libpq.so, make sure, your dynamic loader
is able to find libpq.so. With Linux the command /sbin/ldconfig -v should tell
you, where it finds libpq.so. If not, you need to add an appropriate entry to
/etc/ld.so.conf or to the environment variable LD_LIBRARY_PATH.
Some linux distributions (eg slackware) have an incomplete perl installation.
If you have compile errors like "XS_VERSION_BOOTCHECK undeclared", make a
'find /usr/lib/perl5 -name XSUB.h -print'
If this file is not present, you need to recompile and reinstall perl.
---------------------------------------------------------------------------
Edmund Mergl <E.Mergl@bawue.de> April 29, 1997
---------------------------------------------------------------------------

260
src/interfaces/perl5/test.pl Normal file
View File

@ -0,0 +1,260 @@
#-------------------------------------------------------
#
# $Id: test.pl,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
# 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; print "1..49\n"; }
END {print "not ok 1\n" unless $loaded;}
use Pg;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.
$dbmain = 'template1';
$dbname = 'pgperltest';
$trace = '/tmp/pgtrace.out';
$cnt = 2;
$DEBUG = 0; # set this to 1 for traces
$| = 1;
######################### the following methods will be tested
# connectdb
# db
# user
# host
# port
# finish
# status
# errorMessage
# trace
# untrace
# exec
# getline
# endcopy
# putline
# resultStatus
# ntuples
# nfields
# fname
# fnumber
# ftype
# fsize
# cmdStatus
# oidStatus
# getvalue
######################### the following methods will not be tested
# setdb
# conndefaults
# reset
# options
# tty
# getlength
# getisnull
# print
# notifies
# 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
# 2-4
$conn = Pg::connectdb("dbname = $dbmain");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
# might fail if $dbname doesn't exist => don't check resultStatus
$result = $conn->exec("DROP DATABASE $dbname");
$result = $conn->exec("CREATE DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
$conn = Pg::connectdb("dbname = $dbname");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
######################### debug, PQtrace
if ($DEBUG) {
open(TRACE, ">$trace") || die "can not open $trace: $!";
$conn->trace(TRACE);
}
######################### check PGconn
# 5-8
$db = $conn->db;
cmp_eq($dbname, $db);
$user = $conn->user;
cmp_ne("", $user);
$host = $conn->host;
cmp_ne("", $host);
$port = $conn->port;
cmp_ne("", $port);
######################### create and insert into table
# 9-20
$result = $conn->exec("CREATE TABLE person (id int4, name char16)");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_eq("CREATE", $result->cmdStatus);
for ($i = 1; $i <= 5; $i++) {
$result = $conn->exec("INSERT INTO person VALUES ($i, 'Edmund Mergl')");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_ne(0, $result->oidStatus);
}
######################### copy to stdout, PQgetline
# 21-27
$result = $conn->exec("COPY person TO STDOUT");
cmp_eq(PGRES_COPY_OUT, $result->resultStatus);
$i = 1;
while (-1 != $ret) {
$ret = $conn->getline($string, 256);
last if $string eq "\\.";
cmp_eq("$i Edmund Mergl", $string);
$i ++;
}
cmp_eq(0, $conn->endcopy);
######################### delete and copy from stdin, PQputline
# 28-33
$result = $conn->exec("BEGIN");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
$result = $conn->exec("DELETE FROM person");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_eq("DELETE", $result->cmdStatus);
$result = $conn->exec("COPY person FROM STDIN");
cmp_eq(PGRES_COPY_IN, $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");
cmp_eq(0, $conn->endcopy);
$result = $conn->exec("END");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
######################### select from person, PQgetvalue
# 34-47
$result = $conn->exec("SELECT * FROM person");
cmp_eq(PGRES_TUPLES_OK, $result->resultStatus);
for ($k = 0; $k < $result->nfields; $k++) {
$fname = $result->fname($k);
$ftype = $result->ftype($k);
$fsize = $result->fsize($k);
if (0 == $k) {
cmp_eq("id", $fname);
cmp_eq(23, $ftype);
cmp_eq(4, $fsize);
} else {
cmp_eq("name", $fname);
cmp_eq(20, $ftype);
cmp_eq(16, $fsize);
}
$fnumber = $result->fnumber($fname);
cmp_eq($k, $fnumber);
}
for ($k = 0; $k < $result->ntuples; $k++) {
$string = "";
for ($l = 0; $l < $result->nfields; $l++) {
$string .= $result->getvalue($k, $l) . " ";
}
$i = $k + 1;
cmp_eq("$i Edmund Mergl ", $string);
}
######################### debug, PQuntrace
if ($DEBUG) {
close(TRACE) || die "bad TRACE: $!";
$conn->untrace;
}
######################### disconnect and drop test database
# 48-49
$conn = Pg::connectdb("dbname = $dbmain");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
$result = $conn->exec("DROP DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
######################### hopefully
print "all tests passed.\n" if 50 == $cnt;
######################### utility functions
sub cmp_eq {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" eq "$ret") {
print "ok $cnt\n";
} else {
$msg = $conn->errorMessage;
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
sub cmp_ne {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" ne "$ret") {
print "ok $cnt\n";
} else {
$msg = $conn->errorMessage;
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
######################### EOF

319
src/interfaces/perl5/test.pl.newstyle Normal file
View File

@ -0,0 +1,319 @@
#-------------------------------------------------------
#
# $Id: test.pl.newstyle,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
# 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; print "1..60\n"; }
END {print "not ok 1\n" unless $loaded;}
use Pg;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.
$dbmain = 'template1';
$dbname = 'pgperltest';
$trace = '/tmp/pgtrace.out';
$cnt = 2;
$DEBUG = 0; # set this to 1 for traces
$| = 1;
######################### the following methods will be tested
# connectdb
# db
# user
# host
# port
# finish
# status
# errorMessage
# trace
# untrace
# exec
# getline
# endcopy
# putline
# resultStatus
# ntuples
# nfields
# fname
# fnumber
# ftype
# fsize
# cmdStatus
# oidStatus
# getvalue
# print
# notifies
# lo_import
# lo_export
# lo_unlink
######################### the following methods will not be tested
# setdb
# conndefaults
# reset
# options
# tty
# getlength
# getisnull
# 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
# 2-4
$conn = Pg::connectdb("dbname = $dbmain");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
# might fail if $dbname doesn't exist => don't check resultStatus
$result = $conn->exec("DROP DATABASE $dbname");
$result = $conn->exec("CREATE DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
$conn = Pg::connectdb("dbname = $dbname");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
######################### debug, PQtrace
if ($DEBUG) {
open(TRACE, ">$trace") || die "can not open $trace: $!";
$conn->trace(TRACE);
}
######################### check PGconn
# 5-8
$db = $conn->db;
cmp_eq($dbname, $db);
$user = $conn->user;
cmp_ne("", $user);
$host = $conn->host;
cmp_ne("", $host);
$port = $conn->port;
cmp_ne("", $port);
######################### create and insert into table
# 9-20
$result = $conn->exec("CREATE TABLE person (id int4, name char16)");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_eq("CREATE", $result->cmdStatus);
for ($i = 1; $i <= 5; $i++) {
$result = $conn->exec("INSERT INTO person VALUES ($i, 'Edmund Mergl')");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_ne(0, $result->oidStatus);
}
######################### copy to stdout, PQgetline
# 21-27
$result = $conn->exec("COPY person TO STDOUT");
cmp_eq(PGRES_COPY_OUT, $result->resultStatus);
$i = 1;
while (-1 != $ret) {
$ret = $conn->getline($string, 256);
last if $string eq "\\.";
cmp_eq("$i Edmund Mergl", $string);
$i ++;
}
cmp_eq(0, $conn->endcopy);
######################### delete and copy from stdin, PQputline
# 28-33
$result = $conn->exec("BEGIN");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
$result = $conn->exec("DELETE FROM person");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_eq("DELETE", $result->cmdStatus);
$result = $conn->exec("COPY person FROM STDIN");
cmp_eq(PGRES_COPY_IN, $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");
cmp_eq(0, $conn->endcopy);
$result = $conn->exec("END");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
######################### select from person, PQgetvalue
# 34-47
$result = $conn->exec("SELECT * FROM person");
cmp_eq(PGRES_TUPLES_OK, $result->resultStatus);
for ($k = 0; $k < $result->nfields; $k++) {
$fname = $result->fname($k);
$ftype = $result->ftype($k);
$fsize = $result->fsize($k);
if (0 == $k) {
cmp_eq("id", $fname);
cmp_eq(23, $ftype);
cmp_eq(4, $fsize);
} else {
cmp_eq("name", $fname);
cmp_eq(20, $ftype);
cmp_eq(16, $fsize);
}
$fnumber = $result->fnumber($fname);
cmp_eq($k, $fnumber);
}
for ($k = 0; $k < $result->ntuples; $k++) {
$string = "";
for ($l = 0; $l < $result->nfields; $l++) {
$string .= $result->getvalue($k, $l) . " ";
}
$i = $k + 1;
cmp_eq("$i Edmund Mergl ", $string);
}
######################### PQnotifies
# 48-50
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");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_eq("LISTEN", $result->cmdStatus);
while (1) {
$result = $conn->exec(" ");
($table, $pid) = $conn->notifies;
last if $pid;
}
cmp_eq("person", $table);
######################### PQprint
# 51-52
$result = $conn->exec("SELECT name FROM person WHERE id = 2");
cmp_eq(PGRES_TUPLES_OK, $result->resultStatus);
open(PRINT, "| read IN; read IN; if [ \"\$IN\" = \"myName Edmund Mergl\" ]; then echo \"ok $cnt\"; else echo \"not ok $cnt\"; fi ") || die "can not fork: $|";
$cnt ++;
$result->print(PRINT, 0, 0, 0, 0, 1, 0, " ", "", "", "myName");
close(PRINT) || die "bad PRINT: $!";
######################### PQlo_import, PQlo_export, PQlo_unlink
# 53-58
$filename = 'typemap';
$cwd = `pwd`;
chop $cwd;
$result = $conn->exec("BEGIN");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
$lobjOid = $conn->lo_import("$cwd/$filename");
cmp_ne(0, $lobjOid);
cmp_ne(-1, $conn->lo_export($lobjOid, "/tmp/$filename"));
cmp_eq(-s "$cwd/$filename", -s "/tmp/$filename");
$result = $conn->exec("END");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
cmp_ne(-1, $conn->lo_unlink($lobjOid));
unlink "/tmp/$filename";
######################### debug, PQuntrace
if ($DEBUG) {
close(TRACE) || die "bad TRACE: $!";
$conn->untrace;
}
######################### disconnect and drop test database
# 59-60
$conn = Pg::connectdb("dbname = $dbmain");
cmp_eq(PGRES_CONNECTION_OK, $conn->status);
$result = $conn->exec("DROP DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, $result->resultStatus);
######################### hopefully
print "all tests passed.\n" if 61 == $cnt;
######################### utility functions
sub cmp_eq {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" eq "$ret") {
print "ok $cnt\n";
} else {
$msg = $conn->errorMessage;
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
sub cmp_ne {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" ne "$ret") {
print "ok $cnt\n";
} else {
$msg = $conn->errorMessage;
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
######################### EOF

343
src/interfaces/perl5/test.pl.oldstyle Normal file
View File

@ -0,0 +1,343 @@
#-------------------------------------------------------
#
# $Id: test.pl.oldstyle,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
# 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; print "1..60\n"; }
END {print "not ok 1\n" unless $loaded;}
use Pg;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.
$dbmain = 'template1';
$dbname = 'pgperltest';
$trace = '/tmp/pgtrace.out';
$cnt = 2;
$DEBUG = 0; # set this to 1 for traces
$| = 1;
######################### the following functions will be tested
# PQsetdb()
# PQdb()
# PQhost()
# PQport()
# PQfinish()
# PQstatus()
# PQerrorMessage()
# PQtrace()
# PQuntrace()
# PQexec()
# PQgetline()
# PQendcopy()
# PQputline()
# PQresultStatus()
# PQntuples()
# PQnfields()
# PQfname()
# PQfnumber()
# PQftype()
# PQfsize()
# PQcmdStatus()
# PQoidStatus()
# PQgetvalue()
# PQclear()
# PQprint()
# PQnotifies()
# PQlo_import()
# PQlo_export()
# PQlo_unlink()
######################### the following functions will not be tested
# PQconnectdb()
# PQconndefaults()
# PQreset()
# PQoptions()
# PQtty()
# PQgetlength()
# PQgetisnull()
# 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
# 2-4
$conn = PQsetdb('', '', '', '', $dbmain);
cmp_eq(PGRES_CONNECTION_OK, PQstatus($conn));
# might fail if $dbname doesn't exist => don't check resultStatus
$result = PQexec($conn, "DROP DATABASE $dbname");
PQclear($result);
$result = PQexec($conn, "CREATE DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
PQfinish($conn);
$conn = PQsetdb('', '', '', '', $dbname);
cmp_eq(PGRES_CONNECTION_OK, PQstatus($conn));
######################### debug, PQtrace
if ($DEBUG) {
open(TRACE, ">$trace") || die "can not open $trace: $!";
PQtrace($conn, TRACE);
}
######################### check PGconn
# 5-8
$db = PQdb($conn);
cmp_eq($dbname, $db);
$user = PQuser($conn);
cmp_ne("", $user);
$host = PQhost($conn);
cmp_ne("", $host);
$port = PQport($conn);
cmp_ne("", $port);
######################### create and insert into table
# 9-20
$result = PQexec($conn, "CREATE TABLE person (id int4, name char16)");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
cmp_eq("CREATE", PQcmdStatus($result));
PQclear($result);
for ($i = 1; $i <= 5; $i++) {
$result = PQexec($conn, "INSERT INTO person VALUES ($i, 'Edmund Mergl')");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
cmp_ne(0, PQoidStatus($result));
PQclear($result);
}
######################### copy to stdout, PQgetline
# 21-27
$result = PQexec($conn, "COPY person TO STDOUT");
cmp_eq(PGRES_COPY_OUT, PQresultStatus($result));
PQclear($result);
$i = 1;
while (-1 != $ret) {
$ret = PQgetline($conn, $string, 256);
last if $string eq "\\.";
cmp_eq("$i Edmund Mergl", $string);
$i++;
}
cmp_eq(0, PQendcopy($conn));
######################### delete and copy from stdin, PQputline
# 28-33
$result = PQexec($conn, "BEGIN");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
$result = PQexec($conn, "DELETE FROM person");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
cmp_eq("DELETE", PQcmdStatus($result));
PQclear($result);
$result = PQexec($conn, "COPY person FROM STDIN");
cmp_eq(PGRES_COPY_IN, PQresultStatus($result));
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");
cmp_eq(0, PQendcopy($conn));
$result = PQexec($conn, "END");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
######################### select from person, PQgetvalue
# 34-47
$result = PQexec($conn, "SELECT * FROM person");
cmp_eq(PGRES_TUPLES_OK, PQresultStatus($result));
for ($k = 0; $k < PQnfields($result); $k++) {
$fname = PQfname($result, $k);
$ftype = PQftype($result, $k);
$fsize = PQfsize($result, $k);
if (0 == $k) {
cmp_eq("id", $fname);
cmp_eq(23, $ftype);
cmp_eq(4, $fsize);
} else {
cmp_eq("name", $fname);
cmp_eq(20, $ftype);
cmp_eq(16, $fsize);
}
$fnumber = PQfnumber($result, $fname);
cmp_eq($k, $fnumber);
}
for ($k = 0; $k < PQntuples($result); $k++) {
$string = "";
for ($l = 0; $l < PQnfields($result); $l++) {
$string .= PQgetvalue($result, $k, $l) . " ";
}
$i = $k + 1;
cmp_eq("$i Edmund Mergl ", $string);
}
PQclear($result);
######################### PQnotifies
# 48-50
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");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
cmp_eq("LISTEN", PQcmdStatus($result));
PQclear($result);
while (1) {
$result = PQexec($conn, " ");
($table, $pid) = PQnotifies($conn);
PQclear($result);
last if $pid;
}
cmp_eq("person", $table);
######################### PQprint
# 51-52
$result = PQexec($conn, "SELECT name FROM person WHERE id = 2");
cmp_eq(PGRES_TUPLES_OK, PQresultStatus($result));
open(PRINT, "| read IN; read IN; if [ \"\$IN\" = \"myName Edmund Mergl\" ]; then echo \"ok $cnt\"; else echo \"not ok $cnt\"; fi ") || die "can not fork: $|";
$cnt ++;
PQprint(PRINT, $result, 0, 0, 0, 0, 1, 0, " ", "", "", "myName");
PQclear($result);
close(PRINT) || die "bad PRINT: $!";
######################### PQlo_import, PQlo_export, PQlo_unlink
# 53-59
$filename = 'typemap';
$cwd = `pwd`;
chop $cwd;
$result = PQexec($conn, "BEGIN");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
$lobjOid = PQlo_import($conn, "$cwd/$filename");
cmp_ne( 0, $lobjOid);
cmp_ne(-1, PQlo_export($conn, $lobjOid, "/tmp/$filename"));
cmp_eq(-s "$cwd/$filename", -s "/tmp/$filename");
$result = PQexec($conn, "END");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
cmp_ne(-1, PQlo_unlink($conn, $lobjOid));
unlink "/tmp/$filename";
######################### debug, PQuntrace
if ($DEBUG) {
close(TRACE) || die "bad TRACE: $!";
PQuntrace($conn);
}
######################### disconnect and drop test database
# 59-60
PQfinish($conn);
$conn = PQsetdb('', '', '', '', $dbmain);
cmp_eq(PGRES_CONNECTION_OK, PQstatus($conn));
$result = PQexec($conn, "DROP DATABASE $dbname");
cmp_eq(PGRES_COMMAND_OK, PQresultStatus($result));
PQclear($result);
PQfinish($conn);
######################### hopefully
print "all tests passed.\n" if 61 == $cnt;
######################### utility functions
sub cmp_eq {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" eq "$ret") {
print "ok $cnt\n";
} else {
$msg = PQerrorMessage($conn);
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
sub cmp_ne {
my $cmp = shift;
my $ret = shift;
my $msg;
if ("$cmp" ne "$ret") {
print "ok $cnt\n";
} else {
$msg = PQerrorMessage($conn);
print "not ok $cnt: $cmp, $ret\n$msg\n";
exit;
}
$cnt++;
}
######################### EOF

18
src/interfaces/perl5/typemap Normal file
View File

@ -0,0 +1,18 @@
#-------------------------------------------------------
#
# $Id: typemap,v 1.1.1.1 1997/04/29 19:37:10 mergl Exp $
#
# Copyright (c) 1997 Edmund Mergl
#
#-------------------------------------------------------
TYPEMAP
PGconn * T_PTRREF
PGresult * T_PTRREF
PG_conn T_PTROBJ
PG_result T_PTROBJ
ConnStatusType T_IV
ExecStatusType T_IV
Oid T_IV
int2 T_IV
bool T_IV