Hi,

I have just installed Perl 5.6.0 and PostgreSQL 7.0.2. After successfull installation of both these
programs I tried to make PL/Perl support. After running the commands from Postgres manual I have
received the following errors


[root@eaccess plperl]# perl Makefile.PL
Writing Makefile for plperl
[root@eaccess plperl]# make
cc -c -I../../../src/include -I../../../src/backend  -fno-strict-aliasing -D_LAR
GEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2     -DVERSION=\"0.10\" -DXS_VERSION=\"0
.10\" -fpic -I/usr/local/lib/perl5/5.6.0/i686-linux/CORE  plperl.c
In file included from plperl.c:76:
/usr/local/lib/perl5/5.6.0/i686-linux/CORE/perl.h:467: warning: `USE_LOCALE' red
efined
../../../src/include/config.h:213: warning: this is the location of the previous
 definition
In file included from plperl.c:76:
/usr/local/lib/perl5/5.6.0/i686-linux/CORE/perl.h:2027: warning: `DEBUG' redefin
ed
../../../src/include/utils/elog.h:22: warning: this is the location of the previ
ous definition
plperl.c: In function `plperl_create_sub':
plperl.c:328: `errgv' undeclared (first use in this function)
plperl.c:328: (Each undeclared identifier is reported only once
plperl.c:328: for each function it appears in.)
plperl.c:334: `na' undeclared (first use in this function)
plperl.c: In function `plperl_call_perl_func':
plperl.c:444: `errgv' undeclared (first use in this function)
plperl.c:450: `na' undeclared (first use in this function)
plperl.c: In function `plperl_func_handler':
plperl.c:654: `na' undeclared (first use in this function)
plperl.c: In function `plperl_build_tuple_argument':
plperl.c:2192: `na' undeclared (first use in this function)
make: *** [plperl.o] Error 1
[root@eaccess plperl]#

What I'm doing wrong?

Regards,
Alex



Sat, 2 Sep 2000 12:47:58 +0400
Alex Guryanow <gav@nlr.ru>
PL/Perl compilation error
Alex Guryanow <gav@nlr.ru> writes:
> [root@eaccess plperl]# perl Makefile.PL

For recent Perl versions you need to do
		perl Makefile.PL POLLUTE=1
instead.  The src/pl Makefile would've done it that way for you,
but it looks like that code patch didn't make it to the docs...

Someone needs to update our Perl code so that it will compile cleanly
against both newer and not-so-new Perls.  There are notes in our mail
archives about how to do this (basically "use Devel::PPPort" is the
long-term answer) but it hasn't gotten to the top of anyone's to-do
list.

			regards, tom lane

Sat, 02 Sep 2000 12:48:46 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
Jan Wieck <janwieck@Yahoo.com> writes:
>  [ why hasn't plperl been fixed yet? ]

IMHO, the portability problems with plperl will need a Perl guru to fix.
Specifically somebody who knows the ins and outs of embedding Perl into
other applications, which is not such a commonly done thing.  pltcl was
a simpler project because Tcl has always been designed to be embedded as
a library into other applications.  Perl is still in process of being
redesigned from a standalone program into an embeddable library, and
most everyday Perl programmers don't know much about the pitfalls that
still remain in using it that way.

Just to give you one example of the ways in which Perl is not designed
to be embeddable: last I checked, libperl was not built as PIC code by
default.  On machines where that makes a difference (like HPUX) that
means that plperl cannot work with a default Perl installation. Period.
Not one damn thing you can do about it except reconfigure/rebuild/
reinstall Perl, which is a tad outside the charter of our build process.

The cross-version compatibility issues could be fixed more easily, but
probably not with just an hour or two's work (has anyone here actually
done anything with Devel::PPPort? how hard is it?).  When working around
them just takes "add POLLUTE=1 to Makefile build", I can see why people
aren't eager to invest the work for a cleaner solution.

Perl is getting better over time (indeed 5.6.0 may do the right thing
already on the PIC front; I haven't installed it yet) but I think in
the near term it's going to be difficult to have a really robust
portability solution for plperl.

			regards, tom lane

Sat, 02 Sep 2000 19:33:42 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
Tom Lane wrote:
> Alex Guryanow <gav@nlr.ru> writes:
> > [root@eaccess plperl]# perl Makefile.PL
>
> For recent Perl versions you need to do
>         perl Makefile.PL POLLUTE=1
> instead.  The src/pl Makefile would've done it that way for you,
> but it looks like that code patch didn't make it to the docs...
>
> Someone needs to update our Perl code so that it will compile cleanly
> against both newer and not-so-new Perls.  There are notes in our mail
> archives about how to do this (basically "use Devel::PPPort" is the
> long-term answer) but it hasn't gotten to the top of anyone's to-do
> list.

    Can someone eventually enlighten me a little?

    We've    had   problems   like   platform/version   dependant
    compilation errors with PL/Tcl in the past too, but they  got
    fixed  pretty  quick and a reasonable number of people worked
    on that all together.

    We have frequent compilation error reports with  PL/perl  but
    nobody seems to be able/willing to do anything about it.

    PL/perl  was  once  highly  requested feature. Now there is a
    code base and lesser experienced programmers  could  continue
    the work, but nobody does.

    What  is  the problem with perl? Are there only alot of users
    but no hackers? The frequent fail reports suggest that  there
    are  folks  who  want  to  have  that  thing running. I can't
    believe that a piece of open  source  software,  that  is  so
    popular, is implemented in such an ugly way that nobody has a
    clue how to fix that damned thing.

    So please tell me why people spend their time  writing  error
    reports  again  and  again  instead  of  simply fixing it and
    submitting a patch.


Jan

--

#======================================================================#
# It's easier to get forgiveness for being wrong than for being right. #
# Let's break this rule - forgive me.                                  #
#================================================== JanWieck@Yahoo.com #



Sat, 2 Sep 2000 18:53:48 -0500 (EST)
Jan Wieck <janwieck@Yahoo.com>
Re: PL/Perl compilation error
Tom Lane wrote:
> Alex Guryanow <gav@nlr.ru> writes:
> > [root@eaccess plperl]# perl Makefile.PL
>
> For recent Perl versions you need to do
>         perl Makefile.PL POLLUTE=1
> instead.  The src/pl Makefile would've done it that way for you,
> but it looks like that code patch didn't make it to the docs...
>
> Someone needs to update our Perl code so that it will compile cleanly
> against both newer and not-so-new Perls.  There are notes in our mail
> archives about how to do this (basically "use Devel::PPPort" is the
> long-term answer) but it hasn't gotten to the top of anyone's to-do
> list.

    Can someone eventually enlighten me a little?

    We've    had   problems   like   platform/version   dependant
    compilation errors with PL/Tcl in the past too, but they  got
    fixed  pretty  quick and a reasonable number of people worked
    on that all together.

    We have frequent compilation error reports with  PL/perl  but
    nobody seems to be able/willing to do anything about it.

    PL/perl  was  once  highly  requested feature. Now there is a
    code base and lesser experienced programmers  could  continue
    the work, but nobody does.

    What  is  the problem with perl? Are there only alot of users
    but no hackers? The frequent fail reports suggest that  there
    are  folks  who  want  to  have  that  thing running. I can't
    believe that a piece of open  source  software,  that  is  so
    popular, is implemented in such an ugly way that nobody has a
    clue how to fix that damned thing.

    So please tell me why people spend their time  writing  error
    reports  again  and  again  instead  of  simply fixing it and
    submitting a patch.


Jan

--

#======================================================================#
# It's easier to get forgiveness for being wrong than for being right. #
# Let's break this rule - forgive me.                                  #
#================================================== JanWieck@Yahoo.com #





Sun, 3 Sep 2000 10:04:04 -0400
Jan Wieck <janwieck@Yahoo.com>
Re: PL/Perl compilation error
Hi,

I have take a look to the source code concerning PL/Perl, it seems that 2 variables
have a bad call : errgv and na.

If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
success to compile the lib plperl.so.

Also in Perl documentation you will find the answer for backward compatibility :

> The API function perl_get_sv("@",FALSE) should be used instead of directly accessing
> perl globals as GvSV(errgv). The API call is backward compatible with existing perls and
> provides source compatibility with threading is enabled.

It seems to be easily repared. I have no time yet but I will take a look as soon as possible.

Regards
Gilles

Alex Guryanow wrote:

> Hi,
>
> I have just installed Perl 5.6.0 and PostgreSQL 7.0.2. After successfull installation of both these
> programs I tried to make PL/Perl support. After running the commands from Postgres manual I have
> received the following errors
>


Mon, 04 Sep 2000 14:29:33 +0200
Gilles DAROLD <gilles@darold.net>
Re: PL/Perl compilation error

   This week, I had the opportunity to compare the performance of PostgreSQL
on an Alpha and an Intel server, and the results kind of surprised me.  I'd
love to hear if this has been the case for others as well...

-------------
Intel Machine

SuperMicro 8050 quad Xeon server
512 MB RAM
4 x PII Xeon 400 MHz (secondary cache disabled)
RAID array w/ 5 9-gig drives

Approximate cost:  $6000
--------------
Alpha Machine
AlphaServer DS20E
2 x CPU (500 MHz or 667 MHz)
2 GB RAM
9-gig SCSI drive

Approximate cost:  $20,000 - $25,000
-----------------------

General System notes

    I'm not sure which chips the Alpha uses, the 500 MHz or the 667 MHz.
Also, because the SuperMicro board is meant for the newer Xeons, the
secondary cache had to be completely disabled on the PII 400 Xeons, so that
machine was definitely not running up to potential.

-------------------------
Test method

   This wasn't exactly the ANSI tests, but it accurately reflected what we
need out of a machine.  A while back we logged 87,000 individual queries on
our production machine, and I selected one thousand distinct queries from
that.

   On each machine I spawned 20 parallel processes, each performing the
1,000 queries, and timed how long it took for all processes to finish.

   To try and keep the disk subsystem from being a factor, this used only
selects, no updates or deletes.  Also, the database is small enough that the
entire thing was easily in the disk cache at all times.
--------------------------
Test results

  The Alpha finished in just over 60 minutes, the Xeon finished in just over
90.

-----------------------------
Test interpretation

  Once I started looking at the numbers, I was suprised.  On a
processor-for-processor basis, the Alpha was three times as fast as the
Intels.  However, the Intels that it was pitted against were only 400 MHz
chips, only PII (not the PIII), *and* had the external cache completely
disabled.

   So, the Alpha provided three times the performance for four times the
cost - but if the megabyte of cache had been enabled on the Xeons, I think
that the results would have been significantly different.  Also, if the
chips had been even relatively recent chips (say, some 700 or 800 MHz Xeons)
with the cache enabled, it's possible that it could have come close to the
performance of the Alpha, at a much lower cost.

  Overall, I was expecting the Alpha to give the Intel a better trouncing,
especially considering the difference in cost, but I guess it's hard to beat
Intel for transactions/dollar.  If sheer server capacity is the only
relevant factor, forget Intel (You won't find Intels with 64 processors, and
I don't think you'll see them even with the Itaniums).  If your needs are
more down-to-Earth, they're the best you can get for the money.

steve



Tue, 5 Sep 2000 11:14:27 -0600
"Steve Wolfe" <steve@iboats.com>
Report of performance on Alpha vs. Intel
I'm curious, what OS did you perform these test under?

-Mitch

----- Original Message -----
From: "Steve Wolfe" <steve@iboats.com>
To: <pgsql-general@postgresql.org>
Sent: Tuesday, September 05, 2000 10:14 AM
Subject: [GENERAL] Report of performance on Alpha vs. Intel


>
>    This week, I had the opportunity to compare the performance of
PostgreSQL
> on an Alpha and an Intel server, and the results kind of surprised me.
I'd
> love to hear if this has been the case for others as well...
>
> -------------
> Intel Machine
>
> SuperMicro 8050 quad Xeon server
> 512 MB RAM
> 4 x PII Xeon 400 MHz (secondary cache disabled)
> RAID array w/ 5 9-gig drives
>
> Approximate cost:  $6000
> --------------
> Alpha Machine
> AlphaServer DS20E
> 2 x CPU (500 MHz or 667 MHz)
> 2 GB RAM
> 9-gig SCSI drive
>
> Approximate cost:  $20,000 - $25,000
> -----------------------
>
> General System notes
>
>     I'm not sure which chips the Alpha uses, the 500 MHz or the 667 MHz.
> Also, because the SuperMicro board is meant for the newer Xeons, the
> secondary cache had to be completely disabled on the PII 400 Xeons, so
that
> machine was definitely not running up to potential.
>
> -------------------------
> Test method
>
>    This wasn't exactly the ANSI tests, but it accurately reflected what we
> need out of a machine.  A while back we logged 87,000 individual queries
on
> our production machine, and I selected one thousand distinct queries from
> that.
>
>    On each machine I spawned 20 parallel processes, each performing the
> 1,000 queries, and timed how long it took for all processes to finish.
>
>    To try and keep the disk subsystem from being a factor, this used only
> selects, no updates or deletes.  Also, the database is small enough that
the
> entire thing was easily in the disk cache at all times.
> --------------------------
> Test results
>
>   The Alpha finished in just over 60 minutes, the Xeon finished in just
over
> 90.
>
> -----------------------------
> Test interpretation
>
>   Once I started looking at the numbers, I was suprised.  On a
> processor-for-processor basis, the Alpha was three times as fast as the
> Intels.  However, the Intels that it was pitted against were only 400 MHz
> chips, only PII (not the PIII), *and* had the external cache completely
> disabled.
>
>    So, the Alpha provided three times the performance for four times the
> cost - but if the megabyte of cache had been enabled on the Xeons, I think
> that the results would have been significantly different.  Also, if the
> chips had been even relatively recent chips (say, some 700 or 800 MHz
Xeons)
> with the cache enabled, it's possible that it could have come close to the
> performance of the Alpha, at a much lower cost.
>
>   Overall, I was expecting the Alpha to give the Intel a better trouncing,
> especially considering the difference in cost, but I guess it's hard to
beat
> Intel for transactions/dollar.  If sheer server capacity is the only
> relevant factor, forget Intel (You won't find Intels with 64 processors,
and
> I don't think you'll see them even with the Itaniums).  If your needs are
> more down-to-Earth, they're the best you can get for the money.
>
> steve
>
>
>


Tue, 5 Sep 2000 10:35:57 -0700
"Mitch Vincent" <mitch@venux.net>
Re: Report of performance on Alpha vs. Intel

> I'm curious, what OS did you perform these test under?

  Doh!  Silly me.

  The Xeon ran a Linux 2.2.16 kernel, and the Alpha ran "Tru64".

Steve


Tue, 5 Sep 2000 11:42:09 -0600
"Steve Wolfe" <steve@iboats.com>
Re: Report of performance on Alpha vs. Intel
Memory and cache are the most important parameters for db server, and PC
lacks both.

At 19:14 5.9.2000 , Steve Wolfe wrote:
>
>   This week, I had the opportunity to compare the performance of PostgreSQL
>on an Alpha and an Intel server, and the results kind of surprised me.  I'd
>love to hear if this has been the case for others as well...
>
>-------------
>Intel Machine
>
>SuperMicro 8050 quad Xeon server
>512 MB RAM
>4 x PII Xeon 400 MHz (secondary cache disabled)
>RAID array w/ 5 9-gig drives
>
>Approximate cost:  $6000
>--------------
>Alpha Machine
>AlphaServer DS20E
>2 x CPU (500 MHz or 667 MHz)
>2 GB RAM
>9-gig SCSI drive
>
>Approximate cost:  $20,000 - $25,000
>-----------------------
>
>General System notes
>
>    I'm not sure which chips the Alpha uses, the 500 MHz or the 667 MHz.
>Also, because the SuperMicro board is meant for the newer Xeons, the
>secondary cache had to be completely disabled on the PII 400 Xeons, so that
>machine was definitely not running up to potential.
>
>-------------------------
>Test method
>
>   This wasn't exactly the ANSI tests, but it accurately reflected what we
>need out of a machine.  A while back we logged 87,000 individual queries on
>our production machine, and I selected one thousand distinct queries from
>that.
>
>   On each machine I spawned 20 parallel processes, each performing the
>1,000 queries, and timed how long it took for all processes to finish.
>
>   To try and keep the disk subsystem from being a factor, this used only
>selects, no updates or deletes.  Also, the database is small enough that the
>entire thing was easily in the disk cache at all times.
>--------------------------
>Test results
>
>  The Alpha finished in just over 60 minutes, the Xeon finished in just over
>90.
>
>-----------------------------
>Test interpretation
>
>  Once I started looking at the numbers, I was suprised.  On a
>processor-for-processor basis, the Alpha was three times as fast as the
>Intels.  However, the Intels that it was pitted against were only 400 MHz
>chips, only PII (not the PIII), *and* had the external cache completely
>disabled.
>
>   So, the Alpha provided three times the performance for four times the
>cost - but if the megabyte of cache had been enabled on the Xeons, I think
>that the results would have been significantly different.  Also, if the
>chips had been even relatively recent chips (say, some 700 or 800 MHz Xeons)
>with the cache enabled, it's possible that it could have come close to the
>performance of the Alpha, at a much lower cost.
>
>  Overall, I was expecting the Alpha to give the Intel a better trouncing,
>especially considering the difference in cost, but I guess it's hard to beat
>Intel for transactions/dollar.  If sheer server capacity is the only
>relevant factor, forget Intel (You won't find Intels with 64 processors, and
>I don't think you'll see them even with the Itaniums).  If your needs are
>more down-to-Earth, they're the best you can get for the money.
>
>steve
>
>
v
Zeljko Trogrlic
____________________________________________________________

Aeris d.o.o.
Sv. Petka 60 b, HR-31000 Osijek, Croatia
Tel: +385 (31) 53 00 15
Email: mailto:zeljko@post.hinet.hr

Tue, 05 Sep 2000 21:00:46 +0200
Zeljko Trogrlic <zeljko@post.hinet.hr>
Re: Report of performance on Alpha vs. Intel
Can you send me a patch?


> Hi,
> 
> I have take a look to the source code concerning PL/Perl, it seems that 2 variables
> have a bad call : errgv and na.
> 
> If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
> success to compile the lib plperl.so.
> 
> Also in Perl documentation you will find the answer for backward compatibility :
> 
> > The API function perl_get_sv("@",FALSE) should be used instead of directly accessing
> > perl globals as GvSV(errgv). The API call is backward compatible with existing perls and
> > provides source compatibility with threading is enabled.
> 
> It seems to be easily repared. I have no time yet but I will take a look as soon as possible.
> 
> Regards
> Gilles
> 
> Alex Guryanow wrote:
> 
> > Hi,
> >
> > I have just installed Perl 5.6.0 and PostgreSQL 7.0.2. After successfull installation of both these
> > programs I tried to make PL/Perl support. After running the commands from Postgres manual I have
> > received the following errors
> >
> 
> 


-- 
  Bruce Momjian                        |  http://candle.pha.pa.us
  pgman@candle.pha.pa.us               |  (610) 853-3000
  +  If your life is a hard drive,     |  830 Blythe Avenue
  +  Christ can be your backup.        |  Drexel Hill, Pennsylvania 19026

Mon, 16 Oct 2000 12:50:47 -0400 (EDT)
Bruce Momjian <pgman@candle.pha.pa.us>
Re: PL/Perl compilation error
Bruce Momjian wrote:

> Can you send me a patch?
>
> > Hi,
> >
> > I have take a look to the source code concerning PL/Perl, it seems that 2 variables
> > have a bad call : errgv and na.
> >
> > If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
> > success to compile the lib plperl.so.
> >

This patch (simple diff) applies to postgresql-7.0.2.
See attachment...

Regards

Gilles DAROLD
Mon, 16 Oct 2000 19:34:41 +0200
Gilles DAROLD <gilles@darold.net>
Re: PL/Perl compilation error
I can not apply this.  Seems it has changed in the current tree.  Here
is the current plperl.c file.  

> Bruce Momjian wrote:
> 
> > Can you send me a patch?
> >
> > > Hi,
> > >
> > > I have take a look to the source code concerning PL/Perl, it seems that 2 variables
> > > have a bad call : errgv and na.
> > >
> > > If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
> > > success to compile the lib plperl.so.
> > >
> 
> This patch (simple diff) applies to postgresql-7.0.2.
> See attachment...
> 
> Regards
> 
> Gilles DAROLD
> 
> 
> 

> 328c328
> < 	if (SvTRUE(GvSV(PL_errgv)))
> ---
> > 	if (SvTRUE(GvSV(errgv)))
> 334c334
> < 		elog(ERROR, "creation of function failed : %s", SvPV(GvSV(PL_errgv), PL_na));
> ---
> > 		elog(ERROR, "creation of function failed : %s", SvPV(GvSV(errgv), na));
> 444c444
> < 	if (SvTRUE(GvSV(PL_errgv)))
> ---
> > 	if (SvTRUE(GvSV(errgv)))
> 450c450
> < 		elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(PL_errgv), PL_na));
> ---
> > 		elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(errgv), na));
> 654c654
> < 		(SvPV(perlret, PL_na),
> ---
> > 		(SvPV(perlret, na),
> 2192c2192
> < 	output = perl_eval_pv(SvPV(output, PL_na), TRUE);
> ---
> > 	output = perl_eval_pv(SvPV(output, na), TRUE);


-- 
  Bruce Momjian                        |  http://candle.pha.pa.us
  pgman@candle.pha.pa.us               |  (610) 853-3000
  +  If your life is a hard drive,     |  830 Blythe Avenue
  +  Christ can be your backup.        |  Drexel Hill, Pennsylvania 19026

/**********************************************************************
 * plperl.c - perl as a procedural language for PostgreSQL
 *
 * IDENTIFICATION
 *
 *	  This software is copyrighted by Mark Hollomon
 *	 but is shameless cribbed from pltcl.c by Jan Weick.
 *
 *	  The author hereby grants permission  to  use,  copy,	modify,
 *	  distribute,  and	license this software and its documentation
 *	  for any purpose, provided that existing copyright notices are
 *	  retained	in	all  copies  and  that	this notice is included
 *	  verbatim in any distributions. No written agreement, license,
 *	  or  royalty  fee	is required for any of the authorized uses.
 *	  Modifications to this software may be  copyrighted  by  their
 *	  author  and  need  not  follow  the licensing terms described
 *	  here, provided that the new terms are  clearly  indicated  on
 *	  the first page of each file where they apply.
 *
 *	  IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
 *	  PARTY  FOR  DIRECT,	INDIRECT,	SPECIAL,   INCIDENTAL,	 OR
 *	  CONSEQUENTIAL   DAMAGES  ARISING	OUT  OF  THE  USE  OF  THIS
 *	  SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
 *	  IF  THE  AUTHOR  HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
 *	  DAMAGE.
 *
 *	  THE  AUTHOR  AND	DISTRIBUTORS  SPECIFICALLY	 DISCLAIM	ANY
 *	  WARRANTIES,  INCLUDING,  BUT	NOT  LIMITED  TO,  THE	IMPLIED
 *	  WARRANTIES  OF  MERCHANTABILITY,	FITNESS  FOR  A  PARTICULAR
 *	  PURPOSE,	AND NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON
 *	  AN "AS IS" BASIS, AND THE AUTHOR	AND  DISTRIBUTORS  HAVE  NO
 *	  OBLIGATION   TO	PROVIDE   MAINTENANCE,	 SUPPORT,  UPDATES,
 *	  ENHANCEMENTS, OR MODIFICATIONS.
 *
 * IDENTIFICATION
 *	  $Header: /home/projects/pgsql/cvsroot/pgsql/src/pl/plperl/plperl.c,v 1.13 2000/09/12 04:28:30 momjian Exp $
 *
 **********************************************************************/


/* system stuff */
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <unistd.h>
#include <fcntl.h>
#include <string.h>
#include <setjmp.h>

/* postgreSQL stuff */
#include "executor/spi.h"
#include "commands/trigger.h"
#include "utils/elog.h"
#include "fmgr.h"
#include "access/heapam.h"

#include "tcop/tcopprot.h"
#include "utils/syscache.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"

/* perl stuff */
/*
 * Evil Code Alert
 *
 * both posgreSQL and perl try to do 'the right thing'
 * and provide union semun if the platform doesn't define
 * it in a system header.
 * psql uses HAVE_UNION_SEMUN
 * perl uses HAS_UNION_SEMUN
 * together, they cause compile errors.
 * If we need it, the psql headers above will provide it.
 * So we tell perl that we have it.
 */
#ifndef HAS_UNION_SEMUN
#define HAS_UNION_SEMUN
#endif
#include "EXTERN.h"
#include "perl.h"


/**********************************************************************
 * The information we cache about loaded procedures
 **********************************************************************/
typedef struct plperl_proc_desc
{
	char	   *proname;
	FmgrInfo	result_in_func;
	Oid			result_in_elem;
	int			result_in_len;
	int			nargs;
	FmgrInfo	arg_out_func[FUNC_MAX_ARGS];
	Oid			arg_out_elem[FUNC_MAX_ARGS];
	int			arg_out_len[FUNC_MAX_ARGS];
	int			arg_is_rel[FUNC_MAX_ARGS];
	SV		   *reference;
}			plperl_proc_desc;


/**********************************************************************
 * The information we cache about prepared and saved plans
 **********************************************************************/
typedef struct plperl_query_desc
{
	char		qname[20];
	void	   *plan;
	int			nargs;
	Oid		   *argtypes;
	FmgrInfo   *arginfuncs;
	Oid		   *argtypelems;
	Datum	   *argvalues;
	int		   *arglen;
}			plperl_query_desc;


/**********************************************************************
 * Global data
 **********************************************************************/
static int	plperl_firstcall = 1;
static int	plperl_call_level = 0;
static int	plperl_restart_in_progress = 0;
static PerlInterpreter *plperl_safe_interp = NULL;
static HV  *plperl_proc_hash = NULL;

#if REALLYHAVEITONTHEBALL
static Tcl_HashTable *plperl_query_hash = NULL;

#endif

/**********************************************************************
 * Forward declarations
 **********************************************************************/
static void plperl_init_all(void);
static void plperl_init_safe_interp(void);

Datum plperl_call_handler(PG_FUNCTION_ARGS);

static Datum plperl_func_handler(PG_FUNCTION_ARGS);

static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(void);

#ifdef REALLYHAVEITONTHEBALL
static HeapTuple plperl_trigger_handler(PG_FUNCTION_ARGS);

static int plperl_elog(ClientData cdata, Tcl_Interp *interp,
			int argc, char *argv[]);
static int plperl_quote(ClientData cdata, Tcl_Interp *interp,
			 int argc, char *argv[]);

static int plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
				int argc, char *argv[]);
static int plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
				   int argc, char *argv[]);
static int plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
				 int argc, char *argv[]);

static void plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
						int tupno, HeapTuple tuple, TupleDesc tupdesc);

#endif


/**********************************************************************
 * plperl_init_all()		- Initialize all
 **********************************************************************/
static void
plperl_init_all(void)
{

	/************************************************************
	 * Do initialization only once
	 ************************************************************/
	if (!plperl_firstcall)
		return;


	/************************************************************
	 * Destroy the existing safe interpreter
	 ************************************************************/
	if (plperl_safe_interp != NULL)
	{
		perl_destruct(plperl_safe_interp);
		perl_free(plperl_safe_interp);
		plperl_safe_interp = NULL;
	}

	/************************************************************
	 * Free the proc hash table
	 ************************************************************/
	if (plperl_proc_hash != NULL)
	{
		hv_undef(plperl_proc_hash);
		SvREFCNT_dec((SV *) plperl_proc_hash);
		plperl_proc_hash = NULL;
	}

	/************************************************************
	 * Free the prepared query hash table
	 ************************************************************/

	/*
	 * if (plperl_query_hash != NULL) { }
	 */

	/************************************************************
	 * Now recreate a new safe interpreter
	 ************************************************************/
	plperl_init_safe_interp();

	plperl_firstcall = 0;
	return;
}


/**********************************************************************
 * plperl_init_safe_interp() - Create the safe Perl interpreter
 **********************************************************************/
static void
plperl_init_safe_interp(void)
{

	char	   *embedding[3] = {
		"", "-e", 
		/* no commas between the next 4 please. They are supposed to be one string
		 */
		"require Safe; SPI::bootstrap();"
		"sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');"
		"$x->share(qw[&elog &DEBUG &NOTICE &NOIND &ERROR]);"
		" return $x->reval(qq[sub { $_[0] }]); }"
		};

	plperl_safe_interp = perl_alloc();
	if (!plperl_safe_interp)
		elog(ERROR, "plperl_init_safe_interp(): could not allocate perl interpreter");

	perl_construct(plperl_safe_interp);
	perl_parse(plperl_safe_interp, plperl_init_shared_libs, 3, embedding, NULL);
	perl_run(plperl_safe_interp);



	/************************************************************
	 * Initialize the proc and query hash tables
	 ************************* ***********************************/
	plperl_proc_hash = newHV();

}



/**********************************************************************
 * plperl_call_handler		- This is the only visible function
 *				  of the PL interpreter. The PostgreSQL
 *				  function manager and trigger manager
 *				  call this function for execution of
 *				  perl procedures.
 **********************************************************************/

/* keep non-static */
Datum
plperl_call_handler(PG_FUNCTION_ARGS)
{
	Datum		retval;

	/************************************************************
	 * Initialize interpreters on first call
	 ************************************************************/
	if (plperl_firstcall)
		plperl_init_all();

	/************************************************************
	 * Connect to SPI manager
	 ************************************************************/
	if (SPI_connect() != SPI_OK_CONNECT)
		elog(ERROR, "plperl: cannot connect to SPI manager");
	/************************************************************
	 * Keep track about the nesting of Tcl-SPI-Tcl-... calls
	 ************************************************************/
	plperl_call_level++;

	/************************************************************
	 * Determine if called as function or trigger and
	 * call appropriate subhandler
	 ************************************************************/
	if (CALLED_AS_TRIGGER(fcinfo))
	{
		elog(ERROR, "plperl: can't use perl in triggers yet.");

		/*
		 * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
		 */
		/* make the compiler happy */
		retval = (Datum) 0;
	}
	else
		retval = plperl_func_handler(fcinfo);

	plperl_call_level--;

	return retval;
}


/**********************************************************************
 * plperl_create_sub()		- calls the perl interpreter to
 *		create the anonymous subroutine whose text is in the SV.
 *		Returns the SV containing the RV to the closure.
 **********************************************************************/
static
SV *
plperl_create_sub(char * s)
{
	dSP;

	SV		   *subref = NULL;
	int count;

	ENTER;
	SAVETMPS;
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(s,0)));
	PUTBACK;
	count = perl_call_pv("mksafefunc", G_SCALAR | G_EVAL | G_KEEPERR);
	SPAGAIN;

	if (SvTRUE(ERRSV))
	{
		POPs;
		PUTBACK;
		FREETMPS;
		LEAVE;
		elog(ERROR, "creation of function failed : %s", SvPV_nolen(ERRSV));
	}

	if (count != 1) {
		elog(ERROR, "creation of function failed - no return from mksafefunc");
	}

	/*
	 * need to make a deep copy of the return. it comes off the stack as a
	 * temporary.
	 */
	subref = newSVsv(POPs);

	if (!SvROK(subref))
	{
		PUTBACK;
		FREETMPS;
		LEAVE;

		/*
		 * subref is our responsibility because it is not mortal
		 */
		SvREFCNT_dec(subref);
		elog(ERROR, "plperl_create_sub: didn't get a code ref");
	}

	PUTBACK;
	FREETMPS;
	LEAVE;
	return subref;
}

/**********************************************************************
 * plperl_init_shared_libs()		-
 *
 * We cannot use the DynaLoader directly to get at the Opcode
 * module (used by Safe.pm). So, we link Opcode into ourselves
 * and do the initialization behind perl's back.
 *
 **********************************************************************/

extern void boot_Opcode _((CV * cv));
extern void boot_SPI _((CV * cv));

static void
plperl_init_shared_libs(void)
{
	char	   *file = __FILE__;

	newXS("Opcode::bootstrap", boot_Opcode, file);
	newXS("SPI::bootstrap", boot_SPI, file);
}

/**********************************************************************
 * plperl_call_perl_func()		- calls a perl function through the RV
 *			stored in the prodesc structure. massages the input parms properly
 **********************************************************************/
static
SV *
plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
{
	dSP;

	SV		   *retval;
	int			i;
	int			count;


	ENTER;
	SAVETMPS;

	PUSHMARK(sp);
	for (i = 0; i < desc->nargs; i++)
	{
		if (desc->arg_is_rel[i])
		{
			TupleTableSlot *slot = (TupleTableSlot *) fcinfo->arg[i];
			SV		   *hashref;

			Assert(slot != NULL && ! fcinfo->argnull[i]);
			/*
			 * plperl_build_tuple_argument better return a mortal SV.
			 */
			hashref = plperl_build_tuple_argument(slot->val,
												  slot->ttc_tupleDescriptor);
			XPUSHs(hashref);
		}
		else
		{
			if (fcinfo->argnull[i])
			{
				XPUSHs(&PL_sv_undef);
			}
			else
			{
				char	   *tmp;

				tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
									  fcinfo->arg[i],
									  ObjectIdGetDatum(desc->arg_out_elem[i]),
									  Int32GetDatum(desc->arg_out_len[i])));
				XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
				pfree(tmp);
			}
		}
	}
	PUTBACK;
	count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);

	SPAGAIN;

	if (count != 1)
	{
		PUTBACK;
		FREETMPS;
		LEAVE;
		elog(ERROR, "plperl : didn't get a return item from function");
	}

	if (SvTRUE(ERRSV))
	{
		POPs;
		PUTBACK;
		FREETMPS;
		LEAVE;
		elog(ERROR, "plperl : error from function : %s", SvPV_nolen(ERRSV));
	}

	retval = newSVsv(POPs);


	PUTBACK;
	FREETMPS;
	LEAVE;

	return retval;


}

/**********************************************************************
 * plperl_func_handler()		- Handler for regular function calls
 **********************************************************************/
static Datum
plperl_func_handler(PG_FUNCTION_ARGS)
{
	int			i;
	char		internal_proname[512];
	int			proname_len;
	plperl_proc_desc *prodesc;
	SV		   *perlret;
	Datum		retval;
	sigjmp_buf	save_restart;

	/************************************************************
	 * Build our internal proc name from the functions Oid
	 ************************************************************/
	sprintf(internal_proname, "__PLPerl_proc_%u", fcinfo->flinfo->fn_oid);
	proname_len = strlen(internal_proname);

	/************************************************************
	 * Lookup the internal proc name in the hashtable
	 ************************************************************/
	if (!hv_exists(plperl_proc_hash, internal_proname, proname_len))
	{
		/************************************************************
		 * If we haven't found it in the hashtable, we analyze
		 * the functions arguments and returntype and store
		 * the in-/out-functions in the prodesc block and create
		 * a new hashtable entry for it.
		 *
		 * Then we load the procedure into the safe interpreter.
		 ************************************************************/
		HeapTuple	procTup;
		HeapTuple	typeTup;
		Form_pg_proc procStruct;
		Form_pg_type typeStruct;
		char	   *proc_source;

		/************************************************************
		 * Allocate a new procedure description block
		 ************************************************************/
		prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
		prodesc->proname = malloc(strlen(internal_proname) + 1);
		strcpy(prodesc->proname, internal_proname);

		/************************************************************
		 * Lookup the pg_proc tuple by Oid
		 ************************************************************/
		procTup = SearchSysCacheTuple(PROCOID,
									  ObjectIdGetDatum(fcinfo->flinfo->fn_oid),
									  0, 0, 0);
		if (!HeapTupleIsValid(procTup))
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: cache lookup for proc %u failed",
				 fcinfo->flinfo->fn_oid);
		}
		procStruct = (Form_pg_proc) GETSTRUCT(procTup);

		/************************************************************
		 * Get the required information for input conversion of the
		 * return value.
		 ************************************************************/
		typeTup = SearchSysCacheTuple(TYPEOID,
								ObjectIdGetDatum(procStruct->prorettype),
									  0, 0, 0);
		if (!HeapTupleIsValid(typeTup))
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: cache lookup for return type %u failed",
				 procStruct->prorettype);
		}
		typeStruct = (Form_pg_type) GETSTRUCT(typeTup);

		if (typeStruct->typrelid != InvalidOid)
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: return types of tuples not supported yet");
		}

		fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
		prodesc->result_in_elem = (Oid) (typeStruct->typelem);
		prodesc->result_in_len = typeStruct->typlen;

		/************************************************************
		 * Get the required information for output conversion
		 * of all procedure arguments
		 ************************************************************/
		prodesc->nargs = procStruct->pronargs;
		for (i = 0; i < prodesc->nargs; i++)
		{
			typeTup = SearchSysCacheTuple(TYPEOID,
							ObjectIdGetDatum(procStruct->proargtypes[i]),
										  0, 0, 0);
			if (!HeapTupleIsValid(typeTup))
			{
				free(prodesc->proname);
				free(prodesc);
				elog(ERROR, "plperl: cache lookup for argument type %u failed",
					 procStruct->proargtypes[i]);
			}
			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);

			if (typeStruct->typrelid != InvalidOid)
				prodesc->arg_is_rel[i] = 1;
			else
				prodesc->arg_is_rel[i] = 0;

			fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
			prodesc->arg_out_elem[i] = (Oid) (typeStruct->typelem);
			prodesc->arg_out_len[i] = typeStruct->typlen;

		}

		/************************************************************
		 * create the text of the anonymous subroutine.
		 * we do not use a named subroutine so that we can call directly
		 * through the reference.
		 *
		 ************************************************************/
		proc_source = DatumGetCString(DirectFunctionCall1(textout,
									PointerGetDatum(&procStruct->prosrc)));

		/************************************************************
		 * Create the procedure in the interpreter
		 ************************************************************/
		prodesc->reference = plperl_create_sub(proc_source);
		pfree(proc_source);
		if (!prodesc->reference)
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: cannot create internal procedure %s",
				 internal_proname);
		}

		/************************************************************
		 * Add the proc description block to the hashtable
		 ************************************************************/
		hv_store(plperl_proc_hash, internal_proname, proname_len,
				 newSViv((IV) prodesc), 0);
	}
	else
	{
		/************************************************************
		 * Found the proc description block in the hashtable
		 ************************************************************/
		prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
									  internal_proname, proname_len, 0));
	}


	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));

	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		if (--plperl_call_level == 0)
			plperl_restart_in_progress = 0;
		siglongjmp(Warn_restart, 1);
	}


	/************************************************************
	 * Call the Perl function
	 ************************************************************/
	perlret = plperl_call_perl_func(prodesc, fcinfo);

	/************************************************************
	 * Disconnect from SPI manager and then create the return
	 * values datum (if the input function does a palloc for it
	 * this must not be allocated in the SPI memory context
	 * because SPI_finish would free it).
	 ************************************************************/
	if (SPI_finish() != SPI_OK_FINISH)
		elog(ERROR, "plperl: SPI_finish() failed");

	/* XXX is this the approved way to check for an undef result? */
	if (perlret == &PL_sv_undef)
	{
		retval = (Datum) 0;
		fcinfo->isnull = true;
	}
	else
	{
		retval = FunctionCall3(&prodesc->result_in_func,
							   PointerGetDatum(SvPV_nolen(perlret)),
							   ObjectIdGetDatum(prodesc->result_in_elem),
							   Int32GetDatum(prodesc->result_in_len));
	}

	SvREFCNT_dec(perlret);

	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	if (plperl_restart_in_progress)
	{
		if (--plperl_call_level == 0)
			plperl_restart_in_progress = 0;
		siglongjmp(Warn_restart, 1);
	}

	return retval;
}


#ifdef REALLYHAVEITONTHEBALL
/**********************************************************************
 * plperl_trigger_handler() - Handler for trigger calls
 **********************************************************************/
static HeapTuple
plperl_trigger_handler(PG_FUNCTION_ARGS)
{
	TriggerData *trigdata = (TriggerData *) fcinfo->context;
	char		internal_proname[512];
	char	   *stroid;
	Tcl_HashEntry *hashent;
	int			hashnew;
	plperl_proc_desc *prodesc;
	TupleDesc	tupdesc;
	HeapTuple	rettup;
	Tcl_DString tcl_cmd;
	Tcl_DString tcl_trigtup;
	Tcl_DString tcl_newtup;
	int			tcl_rc;
	int			i;

	int		   *modattrs;
	Datum	   *modvalues;
	char	   *modnulls;

	int			ret_numvals;
	char	  **ret_values;

	sigjmp_buf	save_restart;

	/************************************************************
	 * Build our internal proc name from the functions Oid
	 ************************************************************/
	sprintf(internal_proname, "__PLPerl_proc_%u", fcinfo->flinfo->fn_oid);

	/************************************************************
	 * Lookup the internal proc name in the hashtable
	 ************************************************************/
	hashent = Tcl_FindHashEntry(plperl_proc_hash, internal_proname);
	if (hashent == NULL)
	{
		/************************************************************
		 * If we haven't found it in the hashtable,
		 * we load the procedure into the safe interpreter.
		 ************************************************************/
		Tcl_DString proc_internal_def;
		Tcl_DString proc_internal_body;
		HeapTuple	procTup;
		Form_pg_proc procStruct;
		char	   *proc_source;

		/************************************************************
		 * Allocate a new procedure description block
		 ************************************************************/
		prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
		memset(prodesc, 0, sizeof(plperl_proc_desc));
		prodesc->proname = malloc(strlen(internal_proname) + 1);
		strcpy(prodesc->proname, internal_proname);

		/************************************************************
		 * Lookup the pg_proc tuple by Oid
		 ************************************************************/
		procTup = SearchSysCacheTuple(PROCOID,
									  ObjectIdGetDatum(fcinfo->flinfo->fn_oid),
									  0, 0, 0);
		if (!HeapTupleIsValid(procTup))
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: cache lookup for proc %u failed",
				 fcinfo->flinfo->fn_oid);
		}
		procStruct = (Form_pg_proc) GETSTRUCT(procTup);

		/************************************************************
		 * Create the tcl command to define the internal
		 * procedure
		 ************************************************************/
		Tcl_DStringInit(&proc_internal_def);
		Tcl_DStringInit(&proc_internal_body);
		Tcl_DStringAppendElement(&proc_internal_def, "proc");
		Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
		Tcl_DStringAppendElement(&proc_internal_def,
								 "TG_name TG_relid TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");

		/************************************************************
		 * prefix procedure body with
		 * upvar #0 <internal_procname> GD
		 * and with appropriate setting of NEW, OLD,
		 * and the arguments as numerical variables.
		 ************************************************************/
		Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
		Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
		Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);

		Tcl_DStringAppend(&proc_internal_body,
						  "array set NEW $__PLTcl_Tup_NEW\n", -1);
		Tcl_DStringAppend(&proc_internal_body,
						  "array set OLD $__PLTcl_Tup_OLD\n", -1);

		Tcl_DStringAppend(&proc_internal_body,
						  "set i 0\n"
						  "set v 0\n"
						  "foreach v $args {\n"
						  "  incr i\n"
						  "  set $i $v\n"
						  "}\n"
						  "unset i v\n\n", -1);

		proc_source = DatumGetCString(DirectFunctionCall1(textout,
									PointerGetDatum(&procStruct->prosrc)));
		Tcl_DStringAppend(&proc_internal_body, proc_source, -1);
		pfree(proc_source);
		Tcl_DStringAppendElement(&proc_internal_def,
								 Tcl_DStringValue(&proc_internal_body));
		Tcl_DStringFree(&proc_internal_body);

		/************************************************************
		 * Create the procedure in the safe interpreter
		 ************************************************************/
		tcl_rc = Tcl_GlobalEval(plperl_safe_interp,
								Tcl_DStringValue(&proc_internal_def));
		Tcl_DStringFree(&proc_internal_def);
		if (tcl_rc != TCL_OK)
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "plperl: cannot create internal procedure %s - %s",
				 internal_proname, plperl_safe_interp->result);
		}

		/************************************************************
		 * Add the proc description block to the hashtable
		 ************************************************************/
		hashent = Tcl_CreateHashEntry(plperl_proc_hash,
									  prodesc->proname, &hashnew);
		Tcl_SetHashValue(hashent, (ClientData) prodesc);
	}
	else
	{
		/************************************************************
		 * Found the proc description block in the hashtable
		 ************************************************************/
		prodesc = (plperl_proc_desc *) Tcl_GetHashValue(hashent);
	}

	tupdesc = trigdata->tg_relation->rd_att;

	/************************************************************
	 * Create the tcl command to call the internal
	 * proc in the safe interpreter
	 ************************************************************/
	Tcl_DStringInit(&tcl_cmd);
	Tcl_DStringInit(&tcl_trigtup);
	Tcl_DStringInit(&tcl_newtup);

	/************************************************************
	 * We call external functions below - care for elog(ERROR)
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		Tcl_DStringFree(&tcl_cmd);
		Tcl_DStringFree(&tcl_trigtup);
		Tcl_DStringFree(&tcl_newtup);
		plperl_restart_in_progress = 1;
		if (--plperl_call_level == 0)
			plperl_restart_in_progress = 0;
		siglongjmp(Warn_restart, 1);
	}

	/* The procedure name */
	Tcl_DStringAppendElement(&tcl_cmd, internal_proname);

	/* The trigger name for argument TG_name */
	Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgname);

	/* The oid of the trigger relation for argument TG_relid */
	stroid = DatumGetCString(DirectFunctionCall1(oidout,
							 ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
	Tcl_DStringAppendElement(&tcl_cmd, stroid);
	pfree(stroid);

	/* A list of attribute names for argument TG_relatts */
	Tcl_DStringAppendElement(&tcl_trigtup, "");
	for (i = 0; i < tupdesc->natts; i++)
		Tcl_DStringAppendElement(&tcl_trigtup, tupdesc->attrs[i]->attname.data);
	Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
	Tcl_DStringFree(&tcl_trigtup);
	Tcl_DStringInit(&tcl_trigtup);

	/* The when part of the event for TG_when */
	if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
		Tcl_DStringAppendElement(&tcl_cmd, "BEFORE");
	else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
		Tcl_DStringAppendElement(&tcl_cmd, "AFTER");
	else
		Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");

	/* The level part of the event for TG_level */
	if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
		Tcl_DStringAppendElement(&tcl_cmd, "ROW");
	else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
		Tcl_DStringAppendElement(&tcl_cmd, "STATEMENT");
	else
		Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");

	/* Build the data list for the trigtuple */
	plperl_build_tuple_argument(trigdata->tg_trigtuple,
								tupdesc, &tcl_trigtup);

	/*
	 * Now the command part of the event for TG_op and data for NEW and
	 * OLD
	 */
	if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
	{
		Tcl_DStringAppendElement(&tcl_cmd, "INSERT");

		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
		Tcl_DStringAppendElement(&tcl_cmd, "");

		rettup = trigdata->tg_trigtuple;
	}
	else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
	{
		Tcl_DStringAppendElement(&tcl_cmd, "DELETE");

		Tcl_DStringAppendElement(&tcl_cmd, "");
		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));

		rettup = trigdata->tg_trigtuple;
	}
	else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
	{
		Tcl_DStringAppendElement(&tcl_cmd, "UPDATE");

		plperl_build_tuple_argument(trigdata->tg_newtuple,
									tupdesc, &tcl_newtup);

		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_newtup));
		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));

		rettup = trigdata->tg_newtuple;
	}
	else
	{
		Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");

		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
		Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));

		rettup = trigdata->tg_trigtuple;
	}

	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	Tcl_DStringFree(&tcl_trigtup);
	Tcl_DStringFree(&tcl_newtup);

	/************************************************************
	 * Finally append the arguments from CREATE TRIGGER
	 ************************************************************/
	for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
		Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgargs[i]);

	/************************************************************
	 * Call the Tcl function
	 ************************************************************/
	tcl_rc = Tcl_GlobalEval(plperl_safe_interp, Tcl_DStringValue(&tcl_cmd));
	Tcl_DStringFree(&tcl_cmd);

	/************************************************************
	 * Check the return code from Tcl and handle
	 * our special restart mechanism to get rid
	 * of all nested call levels on transaction
	 * abort.
	 ************************************************************/
	if (tcl_rc == TCL_ERROR || plperl_restart_in_progress)
	{
		if (!plperl_restart_in_progress)
		{
			plperl_restart_in_progress = 1;
			if (--plperl_call_level == 0)
				plperl_restart_in_progress = 0;
			elog(ERROR, "plperl: %s", plperl_safe_interp->result);
		}
		if (--plperl_call_level == 0)
			plperl_restart_in_progress = 0;
		siglongjmp(Warn_restart, 1);
	}

	switch (tcl_rc)
	{
		case TCL_OK:
			break;

		default:
			elog(ERROR, "plperl: unsupported TCL return code %d", tcl_rc);
	}

	/************************************************************
	 * The return value from the procedure might be one of
	 * the magic strings OK or SKIP or a list from array get
	 ************************************************************/
	if (SPI_finish() != SPI_OK_FINISH)
		elog(ERROR, "plperl: SPI_finish() failed");

	if (strcmp(plperl_safe_interp->result, "OK") == 0)
		return rettup;
	if (strcmp(plperl_safe_interp->result, "SKIP") == 0)
	{
		return (HeapTuple) NULL;;
	}

	/************************************************************
	 * Convert the result value from the safe interpreter
	 * and setup structures for SPI_modifytuple();
	 ************************************************************/
	if (Tcl_SplitList(plperl_safe_interp, plperl_safe_interp->result,
					  &ret_numvals, &ret_values) != TCL_OK)
	{
		elog(NOTICE, "plperl: cannot split return value from trigger");
		elog(ERROR, "plperl: %s", plperl_safe_interp->result);
	}

	if (ret_numvals % 2 != 0)
	{
		ckfree(ret_values);
		elog(ERROR, "plperl: invalid return list from trigger - must have even # of elements");
	}

	modattrs = (int *) palloc(tupdesc->natts * sizeof(int));
	modvalues = (Datum *) palloc(tupdesc->natts * sizeof(Datum));
	for (i = 0; i < tupdesc->natts; i++)
	{
		modattrs[i] = i + 1;
		modvalues[i] = (Datum) NULL;
	}

	modnulls = palloc(tupdesc->natts + 1);
	memset(modnulls, 'n', tupdesc->natts);
	modnulls[tupdesc->natts] = '\0';

	/************************************************************
	 * Care for possible elog(ERROR)'s below
	 ************************************************************/
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		ckfree(ret_values);
		plperl_restart_in_progress = 1;
		if (--plperl_call_level == 0)
			plperl_restart_in_progress = 0;
		siglongjmp(Warn_restart, 1);
	}

	i = 0;
	while (i < ret_numvals)
	{
		int			attnum;
		HeapTuple	typeTup;
		Oid			typinput;
		Oid			typelem;
		FmgrInfo	finfo;

		/************************************************************
		 * Ignore pseudo elements with a dot name
		 ************************************************************/
		if (*(ret_values[i]) == '.')
		{
			i += 2;
			continue;
		}

		/************************************************************
		 * Get the attribute number
		 ************************************************************/
		attnum = SPI_fnumber(tupdesc, ret_values[i++]);
		if (attnum == SPI_ERROR_NOATTRIBUTE)
			elog(ERROR, "plperl: invalid attribute '%s'", ret_values[--i]);

		/************************************************************
		 * Lookup the attribute type in the syscache
		 * for the input function
		 ************************************************************/
		typeTup = SearchSysCacheTuple(TYPEOID,
				  ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid),
									  0, 0, 0);
		if (!HeapTupleIsValid(typeTup))
		{
			elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
				 ret_values[--i],
				 tupdesc->attrs[attnum - 1]->atttypid);
		}
		typinput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typinput);
		typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);

		/************************************************************
		 * Set the attribute to NOT NULL and convert the contents
		 ************************************************************/
		modnulls[attnum - 1] = ' ';
		fmgr_info(typinput, &finfo);
		modvalues[attnum - 1] =
			FunctionCall3(&finfo,
						  CStringGetDatum(ret_values[i++]),
						  ObjectIdGetDatum(typelem),
						  Int32GetDatum(tupdesc->attrs[attnum-1]->atttypmod));
	}


	rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts,
							 modattrs, modvalues, modnulls);

	pfree(modattrs);
	pfree(modvalues);
	pfree(modnulls);

	if (rettup == NULL)
		elog(ERROR, "plperl: SPI_modifytuple() failed - RC = %d\n", SPI_result);

	ckfree(ret_values);
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

	return rettup;
}


/**********************************************************************
 * plperl_elog()		- elog() support for PLTcl
 **********************************************************************/
static int
plperl_elog(ClientData cdata, Tcl_Interp *interp,
			int argc, char *argv[])
{
	int			level;
	sigjmp_buf	save_restart;

	/************************************************************
	 * Suppress messages during the restart process
	 ************************************************************/
	if (plperl_restart_in_progress)
		return TCL_ERROR;

	/************************************************************
	 * Catch the restart longjmp and begin a controlled
	 * return though all interpreter levels if it happens
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		return TCL_ERROR;
	}

	if (argc != 3)
	{
		Tcl_SetResult(interp, "syntax error - 'elog level msg'",
					  TCL_VOLATILE);
		return TCL_ERROR;
	}

	if (strcmp(argv[1], "NOTICE") == 0)
		level = NOTICE;
	else if (strcmp(argv[1], "WARN") == 0)
		level = ERROR;
	else if (strcmp(argv[1], "ERROR") == 0)
		level = ERROR;
	else if (strcmp(argv[1], "FATAL") == 0)
		level = FATAL;
	else if (strcmp(argv[1], "DEBUG") == 0)
		level = DEBUG;
	else if (strcmp(argv[1], "NOIND") == 0)
		level = NOIND;
	else
	{
		Tcl_AppendResult(interp, "Unknown elog level '", argv[1],
						 "'", NULL);
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		return TCL_ERROR;
	}

	/************************************************************
	 * Call elog(), restore the original restart address
	 * and return to the caller (if not catched)
	 ************************************************************/
	elog(level, argv[2]);
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	return TCL_OK;
}


/**********************************************************************
 * plperl_quote()	- quote literal strings that are to
 *			  be used in SPI_exec query strings
 **********************************************************************/
static int
plperl_quote(ClientData cdata, Tcl_Interp *interp,
			 int argc, char *argv[])
{
	char	   *tmp;
	char	   *cp1;
	char	   *cp2;

	/************************************************************
	 * Check call syntax
	 ************************************************************/
	if (argc != 2)
	{
		Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Allocate space for the maximum the string can
	 * grow to and initialize pointers
	 ************************************************************/
	tmp = palloc(strlen(argv[1]) * 2 + 1);
	cp1 = argv[1];
	cp2 = tmp;

	/************************************************************
	 * Walk through string and double every quote and backslash
	 ************************************************************/
	while (*cp1)
	{
		if (*cp1 == '\'')
			*cp2++ = '\'';
		else
		{
			if (*cp1 == '\\')
				*cp2++ = '\\';
		}
		*cp2++ = *cp1++;
	}

	/************************************************************
	 * Terminate the string and set it as result
	 ************************************************************/
	*cp2 = '\0';
	Tcl_SetResult(interp, tmp, TCL_VOLATILE);
	pfree(tmp);
	return TCL_OK;
}


/**********************************************************************
 * plperl_SPI_exec()		- The builtin SPI_exec command
 *				  for the safe interpreter
 **********************************************************************/
static int
plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
				int argc, char *argv[])
{
	int			spi_rc;
	char		buf[64];
	int			count = 0;
	char	   *arrayname = NULL;
	int			query_idx;
	int			i;
	int			loop_rc;
	int			ntuples;
	HeapTuple  *tuples;
	TupleDesc	tupdesc = NULL;
	sigjmp_buf	save_restart;

	char	   *usage = "syntax error - 'SPI_exec "
	"?-count n? "
	"?-array name? query ?loop body?";

	/************************************************************
	 * Don't do anything if we are already in restart mode
	 ************************************************************/
	if (plperl_restart_in_progress)
		return TCL_ERROR;

	/************************************************************
	 * Check the call syntax and get the count option
	 ************************************************************/
	if (argc < 2)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	i = 1;
	while (i < argc)
	{
		if (strcmp(argv[i], "-array") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			arrayname = argv[i++];
			continue;
		}

		if (strcmp(argv[i], "-count") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
				return TCL_ERROR;
			continue;
		}

		break;
	}

	query_idx = i;
	if (query_idx >= argc)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Prepare to start a controlled return through all
	 * interpreter levels on transaction abort
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Execute the query and handle return codes
	 ************************************************************/
	spi_rc = SPI_exec(argv[query_idx], count);
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

	switch (spi_rc)
	{
		case SPI_OK_UTILITY:
			Tcl_SetResult(interp, "0", TCL_VOLATILE);
			return TCL_OK;

		case SPI_OK_SELINTO:
		case SPI_OK_INSERT:
		case SPI_OK_DELETE:
		case SPI_OK_UPDATE:
			sprintf(buf, "%d", SPI_processed);
			Tcl_SetResult(interp, buf, TCL_VOLATILE);
			return TCL_OK;

		case SPI_OK_SELECT:
			break;

		case SPI_ERROR_ARGUMENT:
			Tcl_SetResult(interp,
						"plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_UNCONNECTED:
			Tcl_SetResult(interp,
					 "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_COPY:
			Tcl_SetResult(interp,
						  "plperl: SPI_exec() failed - SPI_ERROR_COPY",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_CURSOR:
			Tcl_SetResult(interp,
						  "plperl: SPI_exec() failed - SPI_ERROR_CURSOR",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_TRANSACTION:
			Tcl_SetResult(interp,
					 "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_OPUNKNOWN:
			Tcl_SetResult(interp,
					   "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
						  TCL_VOLATILE);
			return TCL_ERROR;

		default:
			sprintf(buf, "%d", spi_rc);
			Tcl_AppendResult(interp, "plperl: SPI_exec() failed - ",
							 "unknown RC ", buf, NULL);
			return TCL_ERROR;
	}

	/************************************************************
	 * Only SELECT queries fall through to here - remember the
	 * tuples we got
	 ************************************************************/

	ntuples = SPI_processed;
	if (ntuples > 0)
	{
		tuples = SPI_tuptable->vals;
		tupdesc = SPI_tuptable->tupdesc;
	}

	/************************************************************
	 * Again prepare for elog(ERROR)
	 ************************************************************/
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * If there is no loop body given, just set the variables
	 * from the first tuple (if any) and return the number of
	 * tuples selected
	 ************************************************************/
	if (argc == query_idx + 1)
	{
		if (ntuples > 0)
			plperl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
		sprintf(buf, "%d", ntuples);
		Tcl_SetResult(interp, buf, TCL_VOLATILE);
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		return TCL_OK;
	}

	/************************************************************
	 * There is a loop body - process all tuples and evaluate
	 * the body on each
	 ************************************************************/
	query_idx++;
	for (i = 0; i < ntuples; i++)
	{
		plperl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);

		loop_rc = Tcl_Eval(interp, argv[query_idx]);

		if (loop_rc == TCL_OK)
			continue;
		if (loop_rc == TCL_CONTINUE)
			continue;
		if (loop_rc == TCL_RETURN)
		{
			memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
			return TCL_RETURN;
		}
		if (loop_rc == TCL_BREAK)
			break;
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		return TCL_ERROR;
	}

	/************************************************************
	 * Finally return the number of tuples
	 ************************************************************/
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	sprintf(buf, "%d", ntuples);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
}


/**********************************************************************
 * plperl_SPI_prepare()		- Builtin support for prepared plans
 *				  The Tcl command SPI_prepare
 *				  allways saves the plan using
 *				  SPI_saveplan and returns a key for
 *				  access. There is no chance to prepare
 *				  and not save the plan currently.
 **********************************************************************/
static int
plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
				   int argc, char *argv[])
{
	int			nargs;
	char	  **args;
	plperl_query_desc *qdesc;
	void	   *plan;
	int			i;
	HeapTuple	typeTup;
	Tcl_HashEntry *hashent;
	int			hashnew;
	sigjmp_buf	save_restart;

	/************************************************************
	 * Don't do anything if we are already in restart mode
	 ************************************************************/
	if (plperl_restart_in_progress)
		return TCL_ERROR;

	/************************************************************
	 * Check the call syntax
	 ************************************************************/
	if (argc != 3)
	{
		Tcl_SetResult(interp, "syntax error - 'SPI_prepare query argtypes'",
					  TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Split the argument type list
	 ************************************************************/
	if (Tcl_SplitList(interp, argv[2], &nargs, &args) != TCL_OK)
		return TCL_ERROR;

	/************************************************************
	 * Allocate the new querydesc structure
	 ************************************************************/
	qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
	sprintf(qdesc->qname, "%lx", (long) qdesc);
	qdesc->nargs = nargs;
	qdesc->argtypes = (Oid *) malloc(nargs * sizeof(Oid));
	qdesc->arginfuncs = (FmgrInfo *) malloc(nargs * sizeof(FmgrInfo));
	qdesc->argtypelems = (Oid *) malloc(nargs * sizeof(Oid));
	qdesc->argvalues = (Datum *) malloc(nargs * sizeof(Datum));
	qdesc->arglen = (int *) malloc(nargs * sizeof(int));

	/************************************************************
	 * Prepare to start a controlled return through all
	 * interpreter levels on transaction abort
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		free(qdesc->argtypes);
		free(qdesc->arginfuncs);
		free(qdesc->argtypelems);
		free(qdesc->argvalues);
		free(qdesc->arglen);
		free(qdesc);
		ckfree(args);
		return TCL_ERROR;
	}

	/************************************************************
	 * Lookup the argument types by name in the system cache
	 * and remember the required information for input conversion
	 ************************************************************/
	for (i = 0; i < nargs; i++)
	{
		typeTup = SearchSysCacheTuple(TYPNAME,
									  PointerGetDatum(args[i]),
									  0, 0, 0);
		if (!HeapTupleIsValid(typeTup))
			elog(ERROR, "plperl: Cache lookup of type %s failed", args[i]);
		qdesc->argtypes[i] = typeTup->t_data->t_oid;
		fmgr_info(((Form_pg_type) GETSTRUCT(typeTup))->typinput,
				  &(qdesc->arginfuncs[i]));
		qdesc->argtypelems[i] = ((Form_pg_type) GETSTRUCT(typeTup))->typelem;
		qdesc->argvalues[i] = (Datum) NULL;
		qdesc->arglen[i] = (int) (((Form_pg_type) GETSTRUCT(typeTup))->typlen);
	}

	/************************************************************
	 * Prepare the plan and check for errors
	 ************************************************************/
	plan = SPI_prepare(argv[1], nargs, qdesc->argtypes);

	if (plan == NULL)
	{
		char		buf[128];
		char	   *reason;

		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

		switch (SPI_result)
		{
			case SPI_ERROR_ARGUMENT:
				reason = "SPI_ERROR_ARGUMENT";
				break;

			case SPI_ERROR_UNCONNECTED:
				reason = "SPI_ERROR_UNCONNECTED";
				break;

			case SPI_ERROR_COPY:
				reason = "SPI_ERROR_COPY";
				break;

			case SPI_ERROR_CURSOR:
				reason = "SPI_ERROR_CURSOR";
				break;

			case SPI_ERROR_TRANSACTION:
				reason = "SPI_ERROR_TRANSACTION";
				break;

			case SPI_ERROR_OPUNKNOWN:
				reason = "SPI_ERROR_OPUNKNOWN";
				break;

			default:
				sprintf(buf, "unknown RC %d", SPI_result);
				reason = buf;
				break;

		}

		elog(ERROR, "plperl: SPI_prepare() failed - %s", reason);
	}

	/************************************************************
	 * Save the plan
	 ************************************************************/
	qdesc->plan = SPI_saveplan(plan);
	if (qdesc->plan == NULL)
	{
		char		buf[128];
		char	   *reason;

		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

		switch (SPI_result)
		{
			case SPI_ERROR_ARGUMENT:
				reason = "SPI_ERROR_ARGUMENT";
				break;

			case SPI_ERROR_UNCONNECTED:
				reason = "SPI_ERROR_UNCONNECTED";
				break;

			default:
				sprintf(buf, "unknown RC %d", SPI_result);
				reason = buf;
				break;

		}

		elog(ERROR, "plperl: SPI_saveplan() failed - %s", reason);
	}

	/************************************************************
	 * Insert a hashtable entry for the plan and return
	 * the key to the caller
	 ************************************************************/
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	hashent = Tcl_CreateHashEntry(plperl_query_hash, qdesc->qname, &hashnew);
	Tcl_SetHashValue(hashent, (ClientData) qdesc);

	Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE);
	return TCL_OK;
}


/**********************************************************************
 * plperl_SPI_execp()		- Execute a prepared plan
 **********************************************************************/
static int
plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
				 int argc, char *argv[])
{
	int			spi_rc;
	char		buf[64];
	int			i,
				j;
	int			loop_body;
	Tcl_HashEntry *hashent;
	plperl_query_desc *qdesc;
	char	   *nulls = NULL;
	char	   *arrayname = NULL;
	int			count = 0;
	int			callnargs;
	static char **callargs = NULL;
	int			loop_rc;
	int			ntuples;
	HeapTuple  *tuples = NULL;
	TupleDesc	tupdesc = NULL;
	sigjmp_buf	save_restart;

	char	   *usage = "syntax error - 'SPI_execp "
	"?-nulls string? ?-count n? "
	"?-array name? query ?args? ?loop body?";

	/************************************************************
	 * Tidy up from an earlier abort
	 ************************************************************/
	if (callargs != NULL)
	{
		ckfree(callargs);
		callargs = NULL;
	}

	/************************************************************
	 * Don't do anything if we are already in restart mode
	 ************************************************************/
	if (plperl_restart_in_progress)
		return TCL_ERROR;

	/************************************************************
	 * Get the options and check syntax
	 ************************************************************/
	i = 1;
	while (i < argc)
	{
		if (strcmp(argv[i], "-array") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			arrayname = argv[i++];
			continue;
		}
		if (strcmp(argv[i], "-nulls") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			nulls = argv[i++];
			continue;
		}
		if (strcmp(argv[i], "-count") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
				return TCL_ERROR;
			continue;
		}

		break;
	}

	/************************************************************
	 * Check minimum call arguments
	 ************************************************************/
	if (i >= argc)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Get the prepared plan descriptor by it's key
	 ************************************************************/
	hashent = Tcl_FindHashEntry(plperl_query_hash, argv[i++]);
	if (hashent == NULL)
	{
		Tcl_AppendResult(interp, "invalid queryid '", argv[--i], "'", NULL);
		return TCL_ERROR;
	}
	qdesc = (plperl_query_desc *) Tcl_GetHashValue(hashent);

	/************************************************************
	 * If a nulls string is given, check for correct length
	 ************************************************************/
	if (nulls != NULL)
	{
		if (strlen(nulls) != qdesc->nargs)
		{
			Tcl_SetResult(interp,
				   "length of nulls string doesn't match # of arguments",
						  TCL_VOLATILE);
			return TCL_ERROR;
		}
	}

	/************************************************************
	 * If there was a argtype list on preparation, we need
	 * an argument value list now
	 ************************************************************/
	if (qdesc->nargs > 0)
	{
		if (i >= argc)
		{
			Tcl_SetResult(interp, "missing argument list", TCL_VOLATILE);
			return TCL_ERROR;
		}

		/************************************************************
		 * Split the argument values
		 ************************************************************/
		if (Tcl_SplitList(interp, argv[i++], &callnargs, &callargs) != TCL_OK)
			return TCL_ERROR;

		/************************************************************
		 * Check that the # of arguments matches
		 ************************************************************/
		if (callnargs != qdesc->nargs)
		{
			Tcl_SetResult(interp,
			"argument list length doesn't match # of arguments for query",
						  TCL_VOLATILE);
			if (callargs != NULL)
			{
				ckfree(callargs);
				callargs = NULL;
			}
			return TCL_ERROR;
		}

		/************************************************************
		 * Prepare to start a controlled return through all
		 * interpreter levels on transaction abort during the
		 * parse of the arguments
		 ************************************************************/
		memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
		if (sigsetjmp(Warn_restart, 1) != 0)
		{
			memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
			for (j = 0; j < callnargs; j++)
			{
				if (qdesc->arglen[j] < 0 &&
					qdesc->argvalues[j] != (Datum) NULL)
				{
					pfree((char *) (qdesc->argvalues[j]));
					qdesc->argvalues[j] = (Datum) NULL;
				}
			}
			ckfree(callargs);
			callargs = NULL;
			plperl_restart_in_progress = 1;
			Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
			return TCL_ERROR;
		}

		/************************************************************
		 * Setup the value array for the SPI_execp() using
		 * the type specific input functions
		 ************************************************************/
		for (j = 0; j < callnargs; j++)
		{
			qdesc->argvalues[j] =
				FunctionCall3(&qdesc->arginfuncs[j],
							  CStringGetDatum(callargs[j]),
							  ObjectIdGetDatum(qdesc->argtypelems[j]),
							  Int32GetDatum(qdesc->arglen[j]));
		}

		/************************************************************
		 * Free the splitted argument value list
		 ************************************************************/
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		ckfree(callargs);
		callargs = NULL;
	}
	else
		callnargs = 0;

	/************************************************************
	 * Remember the index of the last processed call
	 * argument - a loop body for SELECT might follow
	 ************************************************************/
	loop_body = i;

	/************************************************************
	 * Prepare to start a controlled return through all
	 * interpreter levels on transaction abort
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		for (j = 0; j < callnargs; j++)
		{
			if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
			{
				pfree((char *) (qdesc->argvalues[j]));
				qdesc->argvalues[j] = (Datum) NULL;
			}
		}
		plperl_restart_in_progress = 1;
		Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Execute the plan
	 ************************************************************/
	spi_rc = SPI_execp(qdesc->plan, qdesc->argvalues, nulls, count);
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

	/************************************************************
	 * For varlena data types, free the argument values
	 ************************************************************/
	for (j = 0; j < callnargs; j++)
	{
		if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
		{
			pfree((char *) (qdesc->argvalues[j]));
			qdesc->argvalues[j] = (Datum) NULL;
		}
	}

	/************************************************************
	 * Check the return code from SPI_execp()
	 ************************************************************/
	switch (spi_rc)
	{
		case SPI_OK_UTILITY:
			Tcl_SetResult(interp, "0", TCL_VOLATILE);
			return TCL_OK;

		case SPI_OK_SELINTO:
		case SPI_OK_INSERT:
		case SPI_OK_DELETE:
		case SPI_OK_UPDATE:
			sprintf(buf, "%d", SPI_processed);
			Tcl_SetResult(interp, buf, TCL_VOLATILE);
			return TCL_OK;

		case SPI_OK_SELECT:
			break;

		case SPI_ERROR_ARGUMENT:
			Tcl_SetResult(interp,
						"plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_UNCONNECTED:
			Tcl_SetResult(interp,
					 "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_COPY:
			Tcl_SetResult(interp,
						  "plperl: SPI_exec() failed - SPI_ERROR_COPY",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_CURSOR:
			Tcl_SetResult(interp,
						  "plperl: SPI_exec() failed - SPI_ERROR_CURSOR",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_TRANSACTION:
			Tcl_SetResult(interp,
					 "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_OPUNKNOWN:
			Tcl_SetResult(interp,
					   "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
						  TCL_VOLATILE);
			return TCL_ERROR;

		default:
			sprintf(buf, "%d", spi_rc);
			Tcl_AppendResult(interp, "plperl: SPI_exec() failed - ",
							 "unknown RC ", buf, NULL);
			return TCL_ERROR;
	}

	/************************************************************
	 * Only SELECT queries fall through to here - remember the
	 * tuples we got
	 ************************************************************/

	ntuples = SPI_processed;
	if (ntuples > 0)
	{
		tuples = SPI_tuptable->vals;
		tupdesc = SPI_tuptable->tupdesc;
	}

	/************************************************************
	 * Prepare to start a controlled return through all
	 * interpreter levels on transaction abort during
	 * the ouput conversions of the results
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		plperl_restart_in_progress = 1;
		Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * If there is no loop body given, just set the variables
	 * from the first tuple (if any) and return the number of
	 * tuples selected
	 ************************************************************/
	if (loop_body >= argc)
	{
		if (ntuples > 0)
			plperl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		sprintf(buf, "%d", ntuples);
		Tcl_SetResult(interp, buf, TCL_VOLATILE);
		return TCL_OK;
	}

	/************************************************************
	 * There is a loop body - process all tuples and evaluate
	 * the body on each
	 ************************************************************/
	for (i = 0; i < ntuples; i++)
	{
		plperl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);

		loop_rc = Tcl_Eval(interp, argv[loop_body]);

		if (loop_rc == TCL_OK)
			continue;
		if (loop_rc == TCL_CONTINUE)
			continue;
		if (loop_rc == TCL_RETURN)
		{
			memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
			return TCL_RETURN;
		}
		if (loop_rc == TCL_BREAK)
			break;
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		return TCL_ERROR;
	}

	/************************************************************
	 * Finally return the number of tuples
	 ************************************************************/
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	sprintf(buf, "%d", ntuples);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	return TCL_OK;
}


/**********************************************************************
 * plperl_set_tuple_values() - Set variables for all attributes
 *				  of a given tuple
 **********************************************************************/
static void
plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
						int tupno, HeapTuple tuple, TupleDesc tupdesc)
{
	int			i;
	char	   *outputstr;
	char		buf[64];
	Datum		attr;
	bool		isnull;

	char	   *attname;
	HeapTuple	typeTup;
	Oid			typoutput;
	Oid			typelem;

	char	  **arrptr;
	char	  **nameptr;
	char	   *nullname = NULL;

	/************************************************************
	 * Prepare pointers for Tcl_SetVar2() below and in array
	 * mode set the .tupno element
	 ************************************************************/
	if (arrayname == NULL)
	{
		arrptr = &attname;
		nameptr = &nullname;
	}
	else
	{
		arrptr = &arrayname;
		nameptr = &attname;
		sprintf(buf, "%d", tupno);
		Tcl_SetVar2(interp, arrayname, ".tupno", buf, 0);
	}

	for (i = 0; i < tupdesc->natts; i++)
	{
		/************************************************************
		 * Get the attribute name
		 ************************************************************/
		attname = tupdesc->attrs[i]->attname.data;

		/************************************************************
		 * Get the attributes value
		 ************************************************************/
		attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);

		/************************************************************
		 * Lookup the attribute type in the syscache
		 * for the output function
		 ************************************************************/
		typeTup = SearchSysCacheTuple(TYPEOID,
						   ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
									  0, 0, 0);
		if (!HeapTupleIsValid(typeTup))
		{
			elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
				 attname, tupdesc->attrs[i]->atttypid);
		}

		typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
		typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);

		/************************************************************
		 * If there is a value, set the variable
		 * If not, unset it
		 *
		 * Hmmm - Null attributes will cause functions to
		 *		  crash if they don't expect them - need something
		 *		  smarter here.
		 ************************************************************/
		if (!isnull && OidIsValid(typoutput))
		{
			outputstr = DatumGetCString(OidFunctionCall3(typoutput,
										attr,
										ObjectIdGetDatum(typelem),
										Int32GetDatum(tupdesc->attrs[i]->attlen)));
			Tcl_SetVar2(interp, *arrptr, *nameptr, outputstr, 0);
			pfree(outputstr);
		}
		else
			Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
	}
}


#endif
/**********************************************************************
 * plperl_build_tuple_argument() - Build a string for a ref to a hash
 *				  from all attributes of a given tuple
 **********************************************************************/
static SV  *
plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
{
	int			i;
	SV		   *output;
	Datum		attr;
	bool		isnull;

	char	   *attname;
	char	   *outputstr;
	HeapTuple	typeTup;
	Oid			typoutput;
	Oid			typelem;

	output = sv_2mortal(newSVpv("{", 0));

	for (i = 0; i < tupdesc->natts; i++)
	{
		/************************************************************
		 * Get the attribute name
		 ************************************************************/
		attname = tupdesc->attrs[i]->attname.data;

		/************************************************************
		 * Get the attributes value
		 ************************************************************/
		attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);

		/************************************************************
		 * Lookup the attribute type in the syscache
		 * for the output function
		 ************************************************************/
		typeTup = SearchSysCacheTuple(TYPEOID,
						   ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
									  0, 0, 0);
		if (!HeapTupleIsValid(typeTup))
		{
			elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
				 attname, tupdesc->attrs[i]->atttypid);
		}

		typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
		typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);

		/************************************************************
		 * If there is a value, append the attribute name and the
		 * value to the list.
		 *	If it is null it will be set to undef.
		 ************************************************************/
		if (!isnull && OidIsValid(typoutput))
		{
			outputstr = DatumGetCString(OidFunctionCall3(typoutput,
										attr,
										ObjectIdGetDatum(typelem),
										Int32GetDatum(tupdesc->attrs[i]->attlen)));
			sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
			pfree(outputstr);
		}
		else
			sv_catpvf(output, "'%s' => undef,", attname);
	}
	sv_catpv(output, "}");
	output = perl_eval_pv(SvPV_nolen(output), TRUE);
	return output;
}
Mon, 16 Oct 2000 14:36:45 -0400 (EDT)
Bruce Momjian <pgman@candle.pha.pa.us>
Re: [GENERAL] PL/Perl compilation error
Gilles DAROLD <gilles@darold.net> writes:
>>>> I have take a look to the source code concerning PL/Perl, it seems that 2 variables
>>>> have a bad call : errgv and na.
>>>> 
>>>> If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
>>>> success to compile the lib plperl.so.
>>>> 

> This patch (simple diff) applies to postgresql-7.0.2.


The problem is this will break on older copies of Perl.

			regards, tom lane

Mon, 16 Oct 2000 16:07:17 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
Tom Lane wrote:

> Gilles DAROLD <gilles@darold.net> writes:
> >>>> I have take a look to the source code concerning PL/Perl, it seems that 2 variables
> >>>> have a bad call : errgv and na.
> >>>>
> >>>> If you replace them by their normal call (in 5.6.0) PL_errgv and PL_na you will get
> >>>> success to compile the lib plperl.so.
> >>>>
>
> > This patch (simple diff) applies to postgresql-7.0.2.
>
> The problem is this will break on older copies of Perl.
>
>                         regards, tom lane

This problem is solved by perl itself !

I know it work under perl > 5.005_3 and certainly all versions after perl 5.004.
Give me a reason to keep buggy perl versions compatibility ! People still
running version prior of 5.005_3 does not really want perl running well so
why plperl :-)

If you are not agree with my last comment, just take a look to the change log
of the perl version history and you will understand what I mean (security, memory,
etc.) ...

Regards

Gilles DAROLD


Tue, 17 Oct 2000 12:52:58 +0200
Gilles DAROLD <gilles@darold.net>
Re: PL/Perl compilation error
Bruce Momjian wrote:

> I can not apply this.  Seems it has changed in the current tree.  Here
> is the current plperl.c file.
>

It seems that the current file has been fixed. There's no more call to the
buggy variables in it. I don't know what you want me to do ?
Do you still have problem to compiling this code ? If so send me an url
where i can find the complete PG distribution you want to see working.
I will check if it works for me and try to fix if there is problems.
Not sure of what I can do...

Regards

Gilles DAROLD


Tue, 17 Oct 2000 13:12:51 +0200
Gilles DAROLD <gilles@darold.net>
Re: [GENERAL] PL/Perl compilation error
hello.

i have the following trigger:

CREATE TRIGGER trig_person_accessorclass BEFORE INSERT ON Person FOR EACH
ROW EXECUTE PROCEDURE sp_person_accessorclass();

the corresponding function inserts a row into the accessor_class table.

the issue is that when i insert a row into person and immediately query the
accessor_class table, i don't find anything.  does it take some amount of
time for the trigger/sp to run?  is it just placed in a queue or something?
can i speed this up or is it best to not count on the performance of the
function?

thanks

chris



Tue, 17 Oct 2000 07:37:33 -0400
"chris markiewicz" <cmarkiew@commnav.com>
do triggers/procedures run instantly?
Gilles DAROLD <gilles@darold.net> writes:
>> The problem is this will break on older copies of Perl.

> This problem is solved by perl itself !

Yeah, it is: there is a module called Devel::PPPort that isolates
user C code from the incompatibilities of different Perl APIs.  Until
someone gets around to submitting a proper fix using PPPort, we'll stick
with the POLLUTE=1 solution we have now.  I see no reason to install an
incomplete solution that will fail on older Perls --- we are not in the
business of forcing people to update their Perls.

I was going to point you to the pgsql-bugs archive for 3/25/00, but
there seems to be a gap in the archive in March, so attached are the
relevant messages.

			regards, tom lane


------- Forwarded Messages

Date:    Sat, 25 Mar 2000 13:15:28 +0100
From:    Marc Lehmann <pcg@goof.com>
To:      pgsql-bugs@postgresql.org
Subject: [BUGS] perl5 interface won't compile

============================================================================
                        POSTGRESQL BUG REPORT TEMPLATE
============================================================================


Your name		:	Marc Lehmann
Your email address	:	pcg@goof.com


System Configuration
---------------------
  Architecture (example: Intel Pentium)  	: 

  Operating System (example: Linux 2.0.26 ELF) 	:

  PostgreSQL version (example: PostgreSQL-6.5.1):   PostgreSQL-7.0beta3

  Compiler used (example:  gcc 2.8.0)		:


Please enter a FULL description of your problem:
------------------------------------------------

the perl interface does not compile with newer perl versions (5.006 and
probably 5.005 without options).

Please describe a way to repeat the problem.   Please try to provide a

(sorry, just found out that plperl also won't compile, so I have "re-added"
another, a second diff against plperl ;)

concise reproducible example, if at all possible: 
----------------------------------------------------------------------

"make"




If you know how this problem might be fixed, list the solution below:
---------------------------------------------------------------------

A diff against Pg.xs is attached, however, it will not compile with older
perl versions (it is the prefered long-term solution).

So, for the forseeable future, it might be a better to create the Makefile
using

   perl Makefile.PL POLLUTE=1

which will enable some kind of compatibility mode.

A preferable but better solution would be to use the Devel::PPPort module
(on CPAN) to get rid of versiondependonitis (in which case you will need
to apply both diffs and additionally include ppport.h, preferably after
renaming it to something else.

===PATCH 1===================================================================

diff -r -u perl5o/Pg.c perl5/Pg.c
--- perl5o/Pg.c	Sat Mar 25 13:09:05 2000
+++ perl5/Pg.c	Sat Mar 25 13:10:38 2000
@@ -1407,7 +1407,7 @@
 		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);
+			ps.fieldName[i - 11] = (char *)SvPV_nolen(ST(i));
 		}
 		PQprint(fout, res, &ps);
 		Safefree(ps.fieldName);
@@ -3182,7 +3182,7 @@
 				EXTEND(sp, cols);
 				while (col < cols) {
 					if (PQgetisnull(res->result, res->row, col)) {
-						PUSHs(&sv_undef);
+						PUSHs(&PL_sv_undef);
 					} else {
 						char *val = PQgetvalue(res->result, res->row, col);
 						PUSHs(sv_2mortal((SV*)newSVpv(val, 0)));
@@ -3238,7 +3238,7 @@
 		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);
+			ps.fieldName[i - 11] = (char *)SvPV_nolen(ST(i));
 		}
 		PQprint(fout, res->result, &ps);
 		Safefree(ps.fieldName);
diff -r -u perl5o/Pg.xs perl5/Pg.xs
--- perl5o/Pg.xs	Sat Mar 11 04:08:37 2000
+++ perl5/Pg.xs	Sat Mar 25 13:10:36 2000
@@ -581,7 +581,7 @@
 		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);
+			ps.fieldName[i - 11] = (char *)SvPV_nolen(ST(i));
 		}
 		PQprint(fout, res, &ps);
 		Safefree(ps.fieldName);
@@ -1252,7 +1252,7 @@
 				EXTEND(sp, cols);
 				while (col < cols) {
 					if (PQgetisnull(res->result, res->row, col)) {
-						PUSHs(&sv_undef);
+						PUSHs(&PL_sv_undef);
 					} else {
 						char *val = PQgetvalue(res->result, res->row, col);
 						PUSHs(sv_2mortal((SV*)newSVpv(val, 0)));
@@ -1292,7 +1292,7 @@
 		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);
+			ps.fieldName[i - 11] = (char *)SvPV_nolen(ST(i));
 		}
 		PQprint(fout, res->result, &ps);
 		Safefree(ps.fieldName);

===PATCH 2===================================================================

diff -u -r plperlo/plperl.c plperl/plperl.c
--- plperlo/plperl.c	Sat Mar 25 13:17:31 2000
+++ plperl/plperl.c	Sat Mar 25 13:18:32 2000
@@ -309,12 +309,12 @@
 	perl_eval_sv(s, G_SCALAR | G_EVAL | G_KEEPERR);
 	SPAGAIN;
 
-	if (SvTRUE(GvSV(errgv))) {
+	if (SvTRUE(GvSV(PL_errgv))) {
 		POPs;
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
-		elog(ERROR, "creation of function failed : %s", SvPV(GvSV(errgv), na));
+		elog(ERROR, "creation of function failed : %s", SvPV_nolen(GvSV(PL_errgv)));
 	}
 
 	/*
@@ -413,12 +413,12 @@
 		elog(ERROR, "plperl : didn't get a return item from function");
 	}
 
-	if (SvTRUE(GvSV(errgv))) {
+	if (SvTRUE(GvSV(PL_errgv))) {
 		POPs;
 		PUTBACK ;
 		FREETMPS ;
 		LEAVE;
-		elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(errgv), na));
+		elog(ERROR, "plperl : error from function : %s", SvPV_nolen(GvSV(PL_errgv)));
 	}
 
 	retval = newSVsv(POPs);
@@ -632,7 +632,7 @@
 		elog(ERROR, "plperl: SPI_finish() failed");
 
 	retval = (Datum) (*fmgr_faddr(&prodesc->result_in_func))
-			(SvPV(perlret, na),
+			(SvPV_nolen(perlret),
 			 prodesc->result_in_elem,
 		    prodesc->result_in_len);
 
@@ -2168,6 +2168,6 @@
 		}
 	}
 	sv_catpv(output, "}");
-	output = perl_eval_pv(SvPV(output, na), TRUE);
+	output = perl_eval_pv(SvPV_nolen(output), TRUE);
 	return output;
 }

=============================================================================

-- 
      -----==-                                             |
      ----==-- _                                           |
      ---==---(_)__  __ ____  __       Marc Lehmann      +--
      --==---/ / _ \/ // /\ \/ /       pcg@opengroup.org |e|
      -=====/_/_//_/\_,_/ /_/\_\       XX11-RIPE         --+
    The choice of a GNU generation                       |
                                                         |

------- Message 2

Date:    Sat, 25 Mar 2000 11:49:09 -0500
From:    Tom Lane <tgl@sss.pgh.pa.us>
To:      Marc Lehmann <pcg@goof.com>
cc:      pgsql-bugs@postgresql.org, pgsql-hackers@postgreSQL.org
Subject: Re: [BUGS] perl5 interface won't compile 

Marc Lehmann <pcg@goof.com> writes:
> the perl interface does not compile with newer perl versions (5.006 and
> probably 5.005 without options).

We've seen this reported a few times, but in fact the perl code *does*
compile against 5.005_03 --- without options --- and AFAICT that is
still considered the current stable release of Perl.  I'm pretty
hesitant to break backwards compatibility with pre-5.005 versions
just yet.

However, you are the first complainant who has suggested approaches
other than a non-backward-compatible source patch, so I'm all ears.

> So, for the forseeable future, it might be a better to create the Makefile
> using
>    perl Makefile.PL POLLUTE=1
> which will enable some kind of compatibility mode.

Interesting.  I could not find anything about POLLUTE at www.perl.com.
What does it do, and will it cause problems on pre-5.005 perls?

> A preferable but better solution would be to use the Devel::PPPort module
> (on CPAN) to get rid of versiondependonitis (in which case you will need
> to apply both diffs and additionally include ppport.h, preferably after
> renaming it to something else.

This looks like it could be the Right Thing To Do.  Anyone have time to
make it happen (and perhaps even access to a few different perl versions
to test it)?

			regards, tom lane

------- Message 3

Date:    Sat, 25 Mar 2000 15:27:17 -0500
From:    Tom Lane <tgl@sss.pgh.pa.us>
To:      Bruce Momjian <pgman@candle.pha.pa.us>, Marc Lehmann <pcg@goof.com>,
	 pgsql-bugs@postgresql.org
Subject: Re: [BUGS] perl5 interface won't compile 

I said
> Bruce Momjian <pgman@candle.pha.pa.us> writes:
>> I have added your POLLUTE=1 solution to interfaces/perl5 and
>> plperl.  Please try tomorrow's snapshot to see if this works for you.

> I think the more interesting question is whether that breaks older
> Perls...

I have now tried it with perl 5.004_04 (which was current about two
years ago), and I get

$ make plperl/Makefile
cd plperl && perl Makefile.PL POLLUTE=1
'POLLUTE' is not a known MakeMaker parameter name.
Writing Makefile for plperl

after which it seems to be happy.  Assuming this fixes the problem
for bleeding-edge perls, this looks like a good stopgap answer until
someone feels like doing something with Devel::PPPort.

			regards, tom lane

------- End of Forwarded Messages

Tue, 17 Oct 2000 10:32:49 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
On Tue, 17 Oct 2000, Tom Lane wrote:

> Gilles DAROLD <gilles@darold.net> writes:
> >> The problem is this will break on older copies of Perl.
> 
> > This problem is solved by perl itself !
> 
> Yeah, it is: there is a module called Devel::PPPort that isolates
> user C code from the incompatibilities of different Perl APIs.  Until
> someone gets around to submitting a proper fix using PPPort, we'll stick
> with the POLLUTE=1 solution we have now.  I see no reason to install an
> incomplete solution that will fail on older Perls --- we are not in the
> business of forcing people to update their Perls.
I believe that POLLUTE should be a default. People who are using perl5.004
are definitely a minority now. 5.004 is 3 years old now...

-alex


Tue, 17 Oct 2000 11:11:32 -0400 (EDT)
Alex Pilosov <alex@pilosoft.com>
Re: PL/Perl compilation error 
Alex Pilosov <alex@pilosoft.com> writes:
> I believe that POLLUTE should be a default.

It is --- the src/pl and src/interfaces Makefiles will create the
sub-makefiles with POLLUTE=1.  Unfortunately it's easy to miss that
fine point when you're building the Perl modules by hand.  Not sure
if there's a good way to remind people about it.

			regards, tom lane

Tue, 17 Oct 2000 11:28:46 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
Hi,

I have done a little work concerning the famous PL/Perl compilation Error and
also into Interfaces/Perl5.

The confusing POLLUTE option is no more used to see these parts compiled.
I thinks it's now fully compatible with all Perl versions, yes Tom I use PPPort :-)

The way to put it into the distribution package is very simple.

1) Replace the current GNUmakefile in these directories src/interface/perl5 and src/pl/plperl

by those given in the attachment.
2) Copy the lastest version of the ppport.h file into the same directories (latest can be
found
on CPAN) I provide one in the attachment (the latest at this day Version 1.0007)

That done, just compile postgresql exactly as before (with ./configure --with-perl at least).

What I have done is very simple :

    -  cp Devel-PPPort-1.0007/ppport.h postgresql-snapshotsrc/pl/plperl/
    -  cp Devel-PPPort-1.0007/ppport.h postgresql-snapshot/src/interfaces/perl5/

And in the 2 GNUmakefile in the "Makefile: Makefile.PL" section:

    - I have remove the call to the POLLUTE option
    - Added the following lines at the begining of the section:
            $(PERL) -x ppport.h *.c *.h *.xs > ppport.patch
            patch < ppport.patch
            rm ppport.patch

Thanks to Kenneth Albanowski for his PPPort.pm usefull package and to Tom Lane
for his ligth.

Note: the attachment is a tar of all modified and added files in the source tree.

Regards,

Gilles DAROLD
Tue, 24 Oct 2000 12:51:24 +0200
Gilles DAROLD <gilles@darold.net>
PL/Perl compilation error
Gilles DAROLD <gilles@darold.net> writes:
> The confusing POLLUTE option is no more used to see these parts compiled.
> I thinks it's now fully compatible with all Perl versions,
> yes Tom I use PPPort :-)

Excellent!  I'll check it over and put it in the tree.  Thank you.

			regards, tom lane

Tue, 24 Oct 2000 08:39:44 -0400
Tom Lane <tgl@sss.pgh.pa.us>
Re: PL/Perl compilation error 
Broke my build on UnixWare 7.1.1...  May be perl version confusion...

See my post to -hackers.

Larry
* Tom Lane <tgl@sss.pgh.pa.us> [001024 18:38]:
> Gilles DAROLD <gilles@darold.net> writes:
> > The confusing POLLUTE option is no more used to see these parts compiled.
> > I thinks it's now fully compatible with all Perl versions,
> > yes Tom I use PPPort :-)
> 
> Excellent!  I'll check it over and put it in the tree.  Thank you.
> 
> 			regards, tom lane
-- 
Larry Rosenman                      http://www.lerctr.org/~ler
Phone: +1 972-414-9812 (voice) Internet: ler@lerctr.org
US Mail: 1905 Steamboat Springs Drive, Garland, TX 75044-6749

Tue, 24 Oct 2000 20:17:22 -0500
Larry Rosenman <ler@lerctr.org>
Re: Re: PL/Perl compilation error
Hi,

Do you use the file GNUmakefile and ppport.h I recently send to the list ?
What is your version of Perl ?
Could you send me output of your build ?

Regards,

Gilles DAROLD

Larry Rosenman wrote:

> Broke my build on UnixWare 7.1.1...  May be perl version confusion...
>
> See my post to -hackers.
>
> Larry
> * Tom Lane <tgl@sss.pgh.pa.us> [001024 18:38]:
> > Gilles DAROLD <gilles@darold.net> writes:
> > > The confusing POLLUTE option is no more used to see these parts compiled.
> > > I thinks it's now fully compatible with all Perl versions,
> > > yes Tom I use PPPort :-)
> >
> > Excellent!  I'll check it over and put it in the tree.  Thank you.
> >
> >                       regards, tom lane
> --
> Larry Rosenman                      http://www.lerctr.org/~ler
> Phone: +1 972-414-9812 (voice) Internet: ler@lerctr.org
> US Mail: 1905 Steamboat Springs Drive, Garland, TX 75044-6749


Wed, 25 Oct 2000 10:30:42 +0200
Gilles DAROLD <gilles@darold.net>
Re: Re: PL/Perl compilation error