Re: plperl patch - Mailing list pgsql-patches

Andrew Dunstan wrote:

>
> Quick head up - I have a fix for the count hash keys 'fix' I reverted
> yesterday, and also a patch from Joe Coway to allow returning record
> and setof record.
>
> Revised patch will be forthcoming after some testing.


The attached patch (and 2 new files incorporating previous eloglvl.[ch]
as before) has the following changes in plperl.c over previously sent patch:
 - fixed optimization for counting hash keys (Abhijit Menon-Sen)
 - allow return of 'record' and 'setof record' - removed previously
advisied limitation (Joe Conway)
 - fix off by 1 errors in SRF code that caused memory errors (Joe Conway)
 - minor cleanup (me)

There is a new known issue which will be addressed quickly:
 - empty string is interpreted as NULL - only undef should translate as NULL

enjoy

andrew


#include "postgres.h"
#include "executor/spi.h"
#include "utils/syscache.h"
/*
 * This kludge is necessary because of the conflicting
 * definitions of 'DEBUG' between postgres and perl.
 * we'll live.
 */

#include "spi_internal.h"

static char* plperl_spi_status_string(int);

static HV* plperl_spi_execute_fetch_result(SPITupleTable*, int, int );

int
spi_DEBUG(void)
{
    return DEBUG2;
}

int
spi_LOG(void)
{
    return LOG;
}

int
spi_INFO(void)
{
    return INFO;
}

int
spi_NOTICE(void)
{
    return NOTICE;
}

int
spi_WARNING(void)
{
    return WARNING;
}

int
spi_ERROR(void)
{
    return ERROR;
}

HV*
plperl_spi_exec(char* query, int limit)
{
    HV *ret_hv;
    int spi_rv;

    spi_rv = SPI_exec(query, limit);
    ret_hv=plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, spi_rv);

    return ret_hv;
}

static HV*
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
{
    int    i;
    char    *attname;
    char    *attdata;

    HV *array;

    array = newHV();

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

        /************************************************************
        * Get the attributes value
        ************************************************************/
        attdata = SPI_getvalue(tuple, tupdesc, i+1);
        hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
    }
    return array;
}

static HV*
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int rows, int status)
{

    HV *result;
    int i;

    result = newHV();

    if (status == SPI_OK_UTILITY)
    {
        hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
        hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
    }
    else if (status != SPI_OK_SELECT)
    {
        hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
        hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
    }
    else
    {
        if (rows)
        {
            char* key=palloc(sizeof(int));
            HV *row;
            for (i = 0; i < rows; i++)
            {
                row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
                sprintf(key, "%i", i);
                hv_store(result, key, strlen(key), newRV_noinc((SV*)row), 0);
            }
            SPI_freetuptable(tuptable);
        }
    }
    return result;
}

static char*
plperl_spi_status_string(int status)
{
    switch(status){
        /*errors*/
        case SPI_ERROR_TYPUNKNOWN:
            return "SPI_ERROR_TYPUNKNOWN";
        case SPI_ERROR_NOOUTFUNC:
            return "SPI_ERROR_NOOUTFUNC";
        case SPI_ERROR_NOATTRIBUTE:
            return "SPI_ERROR_NOATTRIBUTE";
        case SPI_ERROR_TRANSACTION:
            return "SPI_ERROR_TRANSACTION";
        case SPI_ERROR_PARAM:
            return "SPI_ERROR_PARAM";
        case SPI_ERROR_ARGUMENT:
            return "SPI_ERROR_ARGUMENT";
        case SPI_ERROR_CURSOR:
            return "SPI_ERROR_CURSOR";
        case SPI_ERROR_UNCONNECTED:
            return "SPI_ERROR_UNCONNECTED";
        case SPI_ERROR_OPUNKNOWN:
            return "SPI_ERROR_OPUNKNOWN";
        case SPI_ERROR_COPY:
            return "SPI_ERROR_COPY";
        case SPI_ERROR_CONNECT:
            return "SPI_ERROR_CONNECT";
        /*ok*/
        case SPI_OK_CONNECT:
            return "SPI_OK_CONNECT";
        case SPI_OK_FINISH:
            return "SPI_OK_FINISH";
        case SPI_OK_FETCH:
            return "SPI_OK_FETCH";
        case SPI_OK_UTILITY:
            return "SPI_OK_UTILITY";
        case SPI_OK_SELECT:
            return "SPI_OK_SELECT";
        case SPI_OK_SELINTO:
            return "SPI_OK_SELINTO";
        case SPI_OK_INSERT:
            return "SPI_OK_INSERT";
        case SPI_OK_DELETE:
            return "SPI_OK_DELETE";
        case SPI_OK_UPDATE:
            return "SPI_OK_UPDATE";
        case SPI_OK_CURSOR:
            return "SPI_OK_CURSOR";
    }

    return "Unknown or Invalid code";
}
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

int            spi_DEBUG(void);

int            spi_LOG(void);

int            spi_INFO(void);

int            spi_NOTICE(void);

int            spi_WARNING(void);

int            spi_ERROR(void);

HV*        plperl_spi_exec(char*, int);


Index: src/pl/plperl/GNUmakefile
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -w -r1.12 GNUmakefile
*** src/pl/plperl/GNUmakefile    21 Jan 2004 19:04:11 -0000    1.12
--- src/pl/plperl/GNUmakefile    29 Jun 2004 16:35:55 -0000
***************
*** 15,21 ****

  # The code isn't clean with regard to these warnings.
  ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes, $(CFLAGS))
  endif

  override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
--- 15,21 ----

  # The code isn't clean with regard to these warnings.
  ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes, $(CFLAGS),
-Wl,-rpath,$(perl_archlibexp)/CORE)
  endif

  override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
***************
*** 25,31 ****
  SO_MAJOR_VERSION = 0
  SO_MINOR_VERSION = 0

! OBJS = plperl.o eloglvl.o SPI.o
  SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)

  include $(top_srcdir)/src/Makefile.shlib
--- 25,31 ----
  SO_MAJOR_VERSION = 0
  SO_MINOR_VERSION = 0

! OBJS = plperl.o spi_internal.o SPI.o
  SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)

  include $(top_srcdir)/src/Makefile.shlib
Index: src/pl/plperl/SPI.xs
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/SPI.xs,v
retrieving revision 1.5
diff -c -w -r1.5 SPI.xs
*** src/pl/plperl/SPI.xs    4 Sep 2002 22:49:37 -0000    1.5
--- src/pl/plperl/SPI.xs    29 Jun 2004 16:35:55 -0000
***************
*** 6,22 ****
  #include "perl.h"
  #include "XSUB.h"

! #include "eloglvl.h"



! MODULE = SPI PREFIX = elog_

  PROTOTYPES: ENABLE
  VERSIONCHECK: DISABLE

  void
! elog_elog(level, message)
      int level
      char* message
      CODE:
--- 6,22 ----
  #include "perl.h"
  #include "XSUB.h"

! #include "spi_internal.h"



! MODULE = SPI PREFIX = spi_

  PROTOTYPES: ENABLE
  VERSIONCHECK: DISABLE

  void
! spi_elog(level, message)
      int level
      char* message
      CODE:
***************
*** 24,44 ****


  int
! elog_DEBUG()

  int
! elog_LOG()

  int
! elog_INFO()

  int
! elog_NOTICE()

  int
! elog_WARNING()

  int
! elog_ERROR()
!

--- 24,56 ----


  int
! spi_DEBUG()

  int
! spi_LOG()

  int
! spi_INFO()

  int
! spi_NOTICE()

  int
! spi_WARNING()

  int
! spi_ERROR()

+ SV*
+ spi_spi_exec_query(query, ...)
+     char* query;
+     PREINIT:
+         HV *ret_hash;
+         int limit=0;
+     CODE:
+             if (items>2) Perl_croak(aTHX_ "Usage: spi_exec_query(query, limit) or spi_exec_query(query)");
+             if (items == 2) limit = SvIV(ST(1));
+             ret_hash=plperl_spi_exec(query, limit);
+         RETVAL = newRV_noinc((SV*)ret_hash);
+     OUTPUT:
+         RETVAL
Index: src/pl/plperl/plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.44
diff -c -w -r1.44 plperl.c
*** src/pl/plperl/plperl.c    6 Jun 2004 00:41:28 -0000    1.44
--- src/pl/plperl/plperl.c    29 Jun 2004 16:35:55 -0000
***************
*** 49,54 ****
--- 49,55 ----
  #include "catalog/pg_language.h"
  #include "catalog/pg_proc.h"
  #include "catalog/pg_type.h"
+ #include "funcapi.h"            /* need for SRF support */
  #include "commands/trigger.h"
  #include "executor/spi.h"
  #include "fmgr.h"
***************
*** 78,83 ****
--- 79,86 ----
      TransactionId fn_xmin;
      CommandId    fn_cmin;
      bool        lanpltrusted;
+     bool        fn_retistuple;    /* true, if function returns tuple */
+     Oid            ret_oid;        /* Oid of returning type */
      FmgrInfo    result_in_func;
      Oid            result_typioparam;
      int            nargs;
***************
*** 94,99 ****
--- 97,105 ----
  static int    plperl_firstcall = 1;
  static PerlInterpreter *plperl_interp = NULL;
  static HV  *plperl_proc_hash = NULL;
+ AV           *g_row_keys = NULL;
+ AV           *g_column_keys = NULL;
+ int            g_attr_num = 0;

  /**********************************************************************
   * Forward declarations
***************
*** 106,111 ****
--- 112,118 ----

  static Datum plperl_func_handler(PG_FUNCTION_ARGS);

+ static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
  static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);

  static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
***************
*** 205,218 ****
          "", "-e",

          /*
!          * no commas between the next 5 please. They are supposed to be
           * one string
           */
!         "require Safe; SPI::bootstrap();"
!         "sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
!         "$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
!         " return $x->reval(qq[sub { $_[0] }]); }"
!         "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
      };

      plperl_interp = perl_alloc();
--- 212,226 ----
          "", "-e",

          /*
!          * no commas between the next lines please. They are supposed to be
           * one string
           */
!         "require Safe; SPI::bootstrap(); use vars qw(%_SHARED);"
!         "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
!         "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
!         "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
!         "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
!         "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
      };

      plperl_interp = perl_alloc();
***************
*** 230,235 ****
--- 238,576 ----

  }

+ /**********************************************************************
+  * turn a tuple into a hash expression and add it to a list
+  **********************************************************************/
+ static void
+ plperl_sv_add_tuple_value(SV * rv, HeapTuple tuple, TupleDesc tupdesc)
+ {
+     int            i;
+     char       *value;
+     char       *key;
+
+     sv_catpvf(rv, "{ ");
+
+     for (i = 0; i < tupdesc->natts; i++)
+     {
+         key = SPI_fname(tupdesc, i + 1);
+         value = SPI_getvalue(tuple, tupdesc, i + 1);
+         if (value)
+             sv_catpvf(rv, "%s => '%s'", key, value);
+         else
+             sv_catpvf(rv, "%s => undef", key);
+         if (i != tupdesc->natts - 1)
+             sv_catpvf(rv, ", ");
+     }
+
+     sv_catpvf(rv, " }");
+ }
+
+ /**********************************************************************
+  * set up arguments for a trigger call
+  **********************************************************************/
+ static SV  *
+ plperl_trigger_build_args(FunctionCallInfo fcinfo)
+ {
+     TriggerData *tdata;
+     TupleDesc    tupdesc;
+     int            i = 0;
+
+     SV           *rv;
+     char       *tmp;
+
+     tmp = (char *) malloc(sizeof(int));
+
+     rv = newSVpv("{ ", 0);
+
+     tdata = (TriggerData *) fcinfo->context;
+
+     tupdesc = tdata->tg_relation->rd_att;
+
+     sv_catpvf(rv, "name => '%s'", tdata->tg_trigger->tgname);
+     sv_catpvf(rv, ", relid => '%s'", DatumGetCString(DirectFunctionCall1(oidout,
ObjectIdGetDatum(tdata->tg_relation->rd_id))));
+
+     if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
+     {
+         sv_catpvf(rv, ", event => 'INSERT'");
+         sv_catpvf(rv, ", new =>");
+         plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+     }
+     else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
+     {
+         sv_catpvf(rv, ", event => 'DELETE'");
+         sv_catpvf(rv, ", old => ");
+         plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+     }
+     else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
+     {
+         sv_catpvf(rv, ", event => 'UPDATE'");
+
+         sv_catpvf(rv, ", new =>");
+         plperl_sv_add_tuple_value(rv, tdata->tg_newtuple, tupdesc);
+
+         sv_catpvf(rv, ", old => ");
+         plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+     }
+     else
+         sv_catpvf(rv, ", event => 'UNKNOWN'");
+
+     sprintf(tmp, "%d", tdata->tg_trigger->tgnargs);
+     sv_catpvf(rv, ", argc => %s", tmp);
+
+     if (tdata->tg_trigger->tgnargs != 0)
+     {
+         sv_catpvf(rv, ", args => [ ");
+         for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
+         {
+             sv_catpvf(rv, "%s", tdata->tg_trigger->tgargs[i]);
+             if (i != tdata->tg_trigger->tgnargs - 1)
+                 sv_catpvf(rv, ", ");
+         }
+         sv_catpvf(rv, " ]");
+     }
+     sv_catpvf(rv, ", relname => '%s'", SPI_getrelname(tdata->tg_relation));
+
+     if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
+         sv_catpvf(rv, ", when => 'BEFORE'");
+     else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
+         sv_catpvf(rv, ", when => 'AFTER'");
+     else
+         sv_catpvf(rv, ", when => 'UNKNOWN'");
+
+     if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+         sv_catpvf(rv, ", level => 'ROW'");
+     else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
+         sv_catpvf(rv, ", level => 'STATEMENT'");
+     else
+         sv_catpvf(rv, ", level => 'UNKNOWN'");
+
+     sv_catpvf(rv, " }");
+
+     rv = perl_eval_pv(SvPV(rv, PL_na), TRUE);
+
+     free(tmp);
+
+     return rv;
+ }
+
+
+ /**********************************************************************
+  * check return value from plperl function
+  **********************************************************************/
+ static int
+ plperl_is_set(SV * sv)
+ {
+     int            i = 0;
+     int            len = 0;
+     int            set = 0;
+     int            other = 0;
+     AV           *input_av;
+     SV          **val;
+
+     if (SvTYPE(sv) != SVt_RV)
+         return 0;
+
+     if (SvTYPE(SvRV(sv)) == SVt_PVHV)
+         return 0;
+
+     if (SvTYPE(SvRV(sv)) == SVt_PVAV)
+     {
+         input_av = (AV *) SvRV(sv);
+         len = av_len(input_av) + 1;
+
+         for (i = 0; i < len; i++)
+         {
+             val = av_fetch(input_av, i, FALSE);
+             if (SvTYPE(*val) == SVt_RV)
+                 set = 1;
+             else
+                 other = 1;
+         }
+     }
+
+     if (len == 0)
+         return 1;
+     if (set && !other)
+         return 1;
+     if (!set && other)
+         return 0;
+     if (set && other)
+         elog(ERROR, "plperl: check your return value structure");
+     if (!set && !other)
+         elog(ERROR, "plperl: check your return value structure");
+
+     return 0;                    /* for compiler */
+ }
+
+ /**********************************************************************
+  * extract a list of keys from a hash
+  **********************************************************************/
+ static AV *
+ plperl_get_keys(HV * hv)
+ {
+     AV           *ret;
+     SV          **svp;
+     int            key_count;
+     SV           *val;
+     char       *key;
+     I32            klen;
+
+     key_count = 0;
+     ret = newAV();
+
+     hv_iterinit(hv);
+     while (val = hv_iternextsv(hv, (char **) &key, &klen))
+     {
+         av_store(ret, key_count, eval_pv(key, TRUE));
+         key_count++;
+     }
+     hv_iterinit(hv);
+     return ret;
+ }
+
+ /**********************************************************************
+  * extract a given key (by index) from a list of keys
+  **********************************************************************/
+ static char *
+ plperl_get_key(AV * keys, int index)
+ {
+     SV          **svp;
+     int            len;
+
+     len = av_len(keys) + 1;
+     if (index < len)
+         svp = av_fetch(keys, index, FALSE);
+     else
+         return NULL;
+     return SvPV(*svp, PL_na);
+ }
+
+ /**********************************************************************
+  * extract a value for a given key from a hash
+  **********************************************************************/
+ static char *
+ plperl_get_elem(HV * hash, char *key)
+ {
+     SV          **svp;
+
+     if (hv_exists_ent(hash, eval_pv(key, TRUE), FALSE))
+         svp = hv_fetch(hash, key, strlen(key), FALSE);
+     else
+     {
+         elog(ERROR, "plperl: key '%s' not found", key);
+         return NULL;
+     }
+     return SvPV(*svp, PL_na);
+ }
+
+ /**********************************************************************
+  * set up the new tuple returned from a trigger
+  **********************************************************************/
+ static HeapTuple
+ plperl_modify_tuple(HV * hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
+ {
+     SV          **svp;
+     HV           *hvNew;
+     AV           *plkeys;
+     char       *platt;
+     char       *plval;
+     HeapTuple    rtup;
+     int            natts,
+                 i,
+                 j,
+                 attn,
+                 atti;
+     int           *volatile modattrs;
+     Datum       *volatile modvalues;
+     char       *volatile modnulls;
+     TupleDesc    tupdesc;
+     HeapTuple    typetup;
+
+     modattrs = NULL;
+     modvalues = NULL;
+     modnulls = NULL;
+     tupdesc = tdata->tg_relation->rd_att;
+
+     svp = hv_fetch(hvTD, "new", 3, FALSE);
+     hvNew = (HV *) SvRV(*svp);
+
+     if (SvTYPE(hvNew) != SVt_PVHV)
+         elog(ERROR, "plperl: $_TD->{new} is not a hash");
+
+     plkeys = plperl_get_keys(hvNew);
+     natts = av_len(plkeys)+1;
+     if (natts != tupdesc->natts)
+         elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
+
+     modattrs = palloc(natts * sizeof(int));
+     modvalues = palloc(natts * sizeof(Datum));
+
+     for (i = 0; i < natts; i++)
+     {
+         modattrs[i] = i + 1;
+         modvalues[i] = (Datum) NULL;
+     }
+     modnulls = palloc(natts + 1);
+     memset(modnulls, 'n', natts);
+     modnulls[natts] = '\0';
+
+     tupdesc = tdata->tg_relation->rd_att;
+
+     for (j = 0; j < natts; j++)
+     {
+         char       *src;
+         FmgrInfo    finfo;
+         Oid            typinput;
+         Oid            typelem;
+
+
+         platt = plperl_get_key(plkeys, j);
+
+         attn = modattrs[j] = SPI_fnumber(tupdesc, platt);
+
+         if (attn == SPI_ERROR_NOATTRIBUTE)
+             elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
+         atti = attn - 1;
+
+         plval = plperl_get_elem(hvNew, platt);
+         if (plval == NULL)
+             elog(FATAL, "plperl: interpreter is probably corrupted");
+
+         typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[attn - 1]->atttypid), 0, 0, 0);
+         typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput;
+         typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem;
+         ReleaseSysCache(typetup);
+         fmgr_info(typinput, &finfo);
+
+         if (plval)
+         {
+             src = plval;
+             if (strlen(plval))
+             {
+                 modvalues[j] = FunctionCall3(&finfo,
+                                              CStringGetDatum(src),
+                                              ObjectIdGetDatum(typelem),
+                          Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
+                 modnulls[j] = ' ';
+             }
+             else
+             {
+                 modvalues[i] = (Datum) 0;
+                 modnulls[j] = 'n';
+             }
+         }
+         plval = NULL;
+     }
+     rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls);
+
+     pfree(modattrs);
+     pfree(modvalues);
+     pfree(modnulls);
+     if (rtup == NULL)
+         elog(ERROR, "plperl: SPI_modifytuple failed -- error:  %d", SPI_result);
+
+     return rtup;
+ }

  /**********************************************************************
   * plperl_call_handler        - This is the only visible function
***************
*** 262,278 ****
       * call appropriate subhandler
       ************************************************************/
      if (CALLED_AS_TRIGGER(fcinfo))
!     {
!         ereport(ERROR,
!                 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
!                  errmsg("cannot use perl in triggers yet")));
!
!         /*
!          * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
!          */
!         /* make the compiler happy */
!         retval = (Datum) 0;
!     }
      else
          retval = plperl_func_handler(fcinfo);

--- 603,609 ----
       * call appropriate subhandler
       ************************************************************/
      if (CALLED_AS_TRIGGER(fcinfo))
!         retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
      else
          retval = plperl_func_handler(fcinfo);

***************
*** 295,300 ****
--- 626,632 ----
      ENTER;
      SAVETMPS;
      PUSHMARK(SP);
+     XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
      XPUSHs(sv_2mortal(newSVpv(s, 0)));
      PUTBACK;

***************
*** 387,392 ****
--- 719,725 ----
      SAVETMPS;

      PUSHMARK(SP);
+     XPUSHs(sv_2mortal(newSVpv("undef", 0)));
      for (i = 0; i < desc->nargs; i++)
      {
          if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 801,857 ----
      return retval;
  }

+ /**********************************************************************
+  * plperl_call_perl_trigger_func()    - calls a perl function affected by trigger
+  * through the RV stored in the prodesc structure. massages the input parms properly
+  **********************************************************************/
+ static SV  *
+ plperl_call_perl_trigger_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo, SV * td)
+ {
+     dSP;
+     SV           *retval;
+     int            i;
+     int            count;
+     char       *ret_test;
+
+     ENTER;
+     SAVETMPS;
+
+     PUSHMARK(sp);
+     XPUSHs(td);
+     for (i = 0; i < ((TriggerData *) fcinfo->context)->tg_trigger->tgnargs; i++)
+         XPUSHs(sv_2mortal(newSVpv(((TriggerData *) fcinfo->context)->tg_trigger->tgargs[i], 0)));
+     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(ERRSV, PL_na));
+     }
+
+     retval = newSVsv(POPs);
+
+     PUTBACK;
+     FREETMPS;
+     LEAVE;
+
+     return retval;
+ }

  /**********************************************************************
   * plperl_func_handler()        - Handler for regular function calls
***************
*** 481,491 ****

      /* Find or compile the function */
      prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
-
      /************************************************************
       * Call the Perl function
       ************************************************************/
      perlret = plperl_call_perl_func(prodesc, fcinfo);

      /************************************************************
       * Disconnect from SPI manager and then create the return
--- 865,881 ----

      /* Find or compile the function */
      prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
      /************************************************************
       * Call the Perl function
       ************************************************************/
      perlret = plperl_call_perl_func(prodesc, fcinfo);
+     if (prodesc->fn_retistuple && SRF_IS_FIRSTCALL())
+     {
+
+         if (SvTYPE(perlret) != SVt_RV)
+             elog(ERROR, "plperl: this function must return a reference");
+         g_column_keys = newAV();
+     }

      /************************************************************
       * Disconnect from SPI manager and then create the return
***************
*** 502,507 ****
--- 892,1030 ----
          retval = (Datum) 0;
          fcinfo->isnull = true;
      }
+
+     if (prodesc->fn_retistuple)
+     {
+         /* SRF support */
+         HV           *ret_hv;
+         AV           *ret_av;
+
+         FuncCallContext *funcctx;
+         int            call_cntr;
+         int            max_calls;
+         TupleDesc    tupdesc;
+         TupleTableSlot *slot;
+         AttInMetadata *attinmeta;
+         bool        isset = 0;
+         char      **values = NULL;
+         ReturnSetInfo  *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
+
+         if (!rsinfo)
+             ereport(ERROR,
+                     (errcode(ERRCODE_SYNTAX_ERROR),
+                     errmsg("returning a composite type is not allowed in this context"),
+                     errhint("This function is intended for use in the FROM clause.")));
+
+         if (SvTYPE(perlret) != SVt_RV)
+             elog(ERROR, "plperl: this function must return a reference");
+
+         isset = plperl_is_set(perlret);
+
+         if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
+             ret_hv = (HV *) SvRV(perlret);
+         else
+             ret_av = (AV *) SvRV(perlret);
+
+         if (SRF_IS_FIRSTCALL())
+         {
+             MemoryContext oldcontext;
+             int            i;
+
+             funcctx = SRF_FIRSTCALL_INIT();
+
+             oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
+
+             if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
+             {
+                 if (isset)
+                     funcctx->max_calls = hv_iterinit(ret_hv);
+                 else
+                     funcctx->max_calls = 1;
+             }
+             else
+             {
+                 if (isset)
+                     funcctx->max_calls = av_len(ret_av) + 1;
+                 else
+                     funcctx->max_calls = 1;
+             }
+
+
+             tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc);
+
+             g_attr_num = tupdesc->natts;
+
+             for (i = 0; i < tupdesc->natts; i++)
+                 av_store(g_column_keys, i + 1, eval_pv(SPI_fname(tupdesc, i + 1), TRUE));
+
+             slot = TupleDescGetSlot(tupdesc);
+             funcctx->slot = slot;
+             attinmeta = TupleDescGetAttInMetadata(tupdesc);
+             funcctx->attinmeta = attinmeta;
+             MemoryContextSwitchTo(oldcontext);
+         }
+
+         funcctx = SRF_PERCALL_SETUP();
+         call_cntr = funcctx->call_cntr;
+         max_calls = funcctx->max_calls;
+         slot = funcctx->slot;
+         attinmeta = funcctx->attinmeta;
+
+         if (call_cntr < max_calls)
+         {
+             HeapTuple    tuple;
+             Datum        result;
+             int            i;
+             char       *column_key;
+             char       *elem;
+
+             if (isset)
+             {
+                 HV           *row_hv;
+                 SV          **svp;
+                 char       *row_key;
+
+                 svp = av_fetch(ret_av, call_cntr, FALSE);
+
+                 row_hv = (HV *) SvRV(*svp);
+
+                 values = (char **) palloc(g_attr_num * sizeof(char *));
+
+                 for (i = 0; i < g_attr_num; i++)
+                 {
+                     column_key = plperl_get_key(g_column_keys, i + 1);
+                     elem = plperl_get_elem(row_hv, column_key);
+                     if (strlen(elem))
+                         values[i] = elem;
+                     else
+                         values[i] = NULL;
+                 }
+             }
+             else
+             {
+                 int            i;
+
+                 values = (char **) palloc(g_attr_num * sizeof(char *));
+                 for (i = 0; i < g_attr_num; i++)
+                 {
+                     column_key = SPI_fname(tupdesc, i + 1);
+                     elem = plperl_get_elem(ret_hv, column_key);
+                     if (strlen(elem))
+                         values[i] = elem;
+                     else
+                         values[i] = NULL;
+                 }
+             }
+             tuple = BuildTupleFromCStrings(attinmeta, values);
+             result = TupleGetDatum(slot, tuple);
+             SRF_RETURN_NEXT(funcctx, result);
+         }
+         else
+         {
+             SvREFCNT_dec(perlret);
+             SRF_RETURN_DONE(funcctx);
+         }
+     }
      else
      {
          retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 511,520 ****
      }

      SvREFCNT_dec(perlret);
-
      return retval;
  }


  /**********************************************************************
   * compile_plperl_function    - compile (or hopefully just look up) function
--- 1034,1134 ----
      }

      SvREFCNT_dec(perlret);
      return retval;
  }

+ /**********************************************************************
+  * plperl_trigger_handler()        - Handler for trigger function calls
+  **********************************************************************/
+ static Datum
+ plperl_trigger_handler(PG_FUNCTION_ARGS)
+ {
+     plperl_proc_desc *prodesc;
+     SV           *perlret;
+     Datum        retval;
+     char       *tmp;
+     SV           *svTD;
+     HV           *hvTD;
+
+     /* Find or compile the function */
+     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
+
+     /************************************************************
+     * Call the Perl function
+     ************************************************************/
+     /*
+     * call perl trigger function and build TD hash
+     */
+     svTD = plperl_trigger_build_args(fcinfo);
+     perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
+
+     hvTD = (HV *) SvRV(svTD);    /* convert SV TD structure to Perl Hash
+                                  * structure */
+
+     tmp = SvPV(perlret, PL_na);
+
+     /************************************************************
+     * 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");
+
+     if (!(perlret && SvOK(perlret)))
+     {
+         TriggerData *trigdata = ((TriggerData *) fcinfo->context);
+
+         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+             retval = (Datum) trigdata->tg_trigtuple;
+         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+             retval = (Datum) trigdata->tg_newtuple;
+         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
+             retval = (Datum) trigdata->tg_trigtuple;
+     }
+     else
+     {
+         if (!fcinfo->isnull)
+         {
+
+             HeapTuple    trv;
+
+             if (strcasecmp(tmp, "SKIP") == 0)
+                 trv = NULL;
+             else if (strcasecmp(tmp, "MODIFY") == 0)
+             {
+                 TriggerData *trigdata = (TriggerData *) fcinfo->context;
+
+                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+                     trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid);
+                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+                     trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid);
+                 else
+                 {
+                     trv = NULL;
+                     elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger");
+                 }
+             }
+             else if (strcasecmp(tmp, "OK"))
+             {
+                 trv = NULL;
+                 elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
+             }
+             else
+             {
+                 trv = NULL;
+                 elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
+             }
+             retval = PointerGetDatum(trv);
+         }
+     }
+
+     SvREFCNT_dec(perlret);
+
+     fcinfo->isnull = false;
+     return retval;
+ }

  /**********************************************************************
   * compile_plperl_function    - compile (or hopefully just look up) function
***************
*** 544,549 ****
--- 1158,1164 ----
          sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
      else
          sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
      proname_len = strlen(internal_proname);

      /************************************************************
***************
*** 640,646 ****
              /* Disallow pseudotype result, except VOID */
              if (typeStruct->typtype == 'p')
              {
!                 if (procStruct->prorettype == VOIDOID)
                       /* okay */ ;
                  else if (procStruct->prorettype == TRIGGEROID)
                  {
--- 1255,1262 ----
              /* Disallow pseudotype result, except VOID */
              if (typeStruct->typtype == 'p')
              {
!                 if (procStruct->prorettype == VOIDOID ||
!                     procStruct->prorettype == RECORDOID)
                       /* okay */ ;
                  else if (procStruct->prorettype == TRIGGEROID)
                  {
***************
*** 661,673 ****
                  }
              }

!             if (typeStruct->typtype == 'c')
              {
!                 free(prodesc->proname);
!                 free(prodesc);
!                 ereport(ERROR,
!                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
!                    errmsg("plperl functions cannot return tuples yet")));
              }

              perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
--- 1277,1286 ----
                  }
              }

!             if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
              {
!                 prodesc->fn_retistuple = true;
!                 prodesc->ret_oid = typeStruct->typrelid;
              }

              perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));