granicus.if.org Git - postgresql/blob - src/pl/plperl/plperl.c

   1 /**********************************************************************
   2  * plperl.c - perl as a procedural language for PostgreSQL
   3  *
   4  * IDENTIFICATION
   5  *
   6  *        This software is copyrighted by Mark Hollomon
   7  *       but is shameless cribbed from pltcl.c by Jan Weick.
   8  *
   9  *        The author hereby grants permission  to  use,  copy,  modify,
  10  *        distribute,  and      license this software and its documentation
  11  *        for any purpose, provided that existing copyright notices are
  12  *        retained      in      all  copies  and  that  this notice is included
  13  *        verbatim in any distributions. No written agreement, license,
  14  *        or  royalty  fee      is required for any of the authorized uses.
  15  *        Modifications to this software may be  copyrighted  by  their
  16  *        author  and  need  not  follow  the licensing terms described
  17  *        here, provided that the new terms are  clearly  indicated  on
  18  *        the first page of each file where they apply.
  19  *
  20  *        IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
  21  *        PARTY  FOR  DIRECT,   INDIRECT,       SPECIAL,   INCIDENTAL,   OR
  22  *        CONSEQUENTIAL   DAMAGES  ARISING      OUT  OF  THE  USE  OF  THIS
  23  *        SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
  24  *        IF  THE  AUTHOR  HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
  25  *        DAMAGE.
  26  *
  27  *        THE  AUTHOR  AND      DISTRIBUTORS  SPECIFICALLY       DISCLAIM       ANY
  28  *        WARRANTIES,  INCLUDING,  BUT  NOT  LIMITED  TO,  THE  IMPLIED
  29  *        WARRANTIES  OF  MERCHANTABILITY,      FITNESS  FOR  A  PARTICULAR
  30  *        PURPOSE,      AND NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON
  31  *        AN "AS IS" BASIS, AND THE AUTHOR      AND  DISTRIBUTORS  HAVE  NO
  32  *        OBLIGATION   TO       PROVIDE   MAINTENANCE,   SUPPORT,  UPDATES,
  33  *        ENHANCEMENTS, OR MODIFICATIONS.
  34  *
  35  * IDENTIFICATION
  36  *        $Header: /cvsroot/pgsql/src/pl/plperl/plperl.c,v 1.11 2000/06/05 07:29:11 tgl Exp $
  37  *
  38  **********************************************************************/
  39
  40
  41 /* system stuff */
  42 #include <stdio.h>
  43 #include <stdlib.h>
  44 #include <stdarg.h>
  45 #include <unistd.h>
  46 #include <fcntl.h>
  47 #include <string.h>
  48 #include <setjmp.h>
  49
  50 /* postgreSQL stuff */
  51 #include "executor/spi.h"
  52 #include "commands/trigger.h"
  53 #include "utils/elog.h"
  54 #include "fmgr.h"
  55 #include "access/heapam.h"
  56
  57 #include "tcop/tcopprot.h"
  58 #include "utils/syscache.h"
  59 #include "catalog/pg_proc.h"
  60 #include "catalog/pg_type.h"
  61
  62 /* perl stuff */
  63 /*
  64  * Evil Code Alert
  65  *
  66  * both posgreSQL and perl try to do 'the right thing'
  67  * and provide union semun if the platform doesn't define
  68  * it in a system header.
  69  * psql uses HAVE_UNION_SEMUN
  70  * perl uses HAS_UNION_SEMUN
  71  * together, they cause compile errors.
  72  * If we need it, the psql headers above will provide it.
  73  * So we tell perl that we have it.
  74  */
  75 #ifndef HAS_UNION_SEMUN
  76 #define HAS_UNION_SEMUN
  77 #endif
  78 #include "EXTERN.h"
  79 #include "perl.h"
  80
  81
  82 /**********************************************************************
  83  * The information we cache about loaded procedures
  84  **********************************************************************/
  85 typedef struct plperl_proc_desc
  86 {
  87         char       *proname;
  88         FmgrInfo        result_in_func;
  89         Oid                     result_in_elem;
  90         int                     result_in_len;
  91         int                     nargs;
  92         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  93         Oid                     arg_out_elem[FUNC_MAX_ARGS];
  94         int                     arg_out_len[FUNC_MAX_ARGS];
  95         int                     arg_is_rel[FUNC_MAX_ARGS];
  96         SV                 *reference;
  97 }                       plperl_proc_desc;
  98
  99
 100 /**********************************************************************
 101  * The information we cache about prepared and saved plans
 102  **********************************************************************/
 103 typedef struct plperl_query_desc
 104 {
 105         char            qname[20];
 106         void       *plan;
 107         int                     nargs;
 108         Oid                *argtypes;
 109         FmgrInfo   *arginfuncs;
 110         Oid                *argtypelems;
 111         Datum      *argvalues;
 112         int                *arglen;
 113 }                       plperl_query_desc;
 114
 115
 116 /**********************************************************************
 117  * Global data
 118  **********************************************************************/
 119 static int      plperl_firstcall = 1;
 120 static int      plperl_call_level = 0;
 121 static int      plperl_restart_in_progress = 0;
 122 static PerlInterpreter *plperl_safe_interp = NULL;
 123 static HV  *plperl_proc_hash = NULL;
 124
 125 #if REALLYHAVEITONTHEBALL
 126 static Tcl_HashTable *plperl_query_hash = NULL;
 127
 128 #endif
 129
 130 /**********************************************************************
 131  * Forward declarations
 132  **********************************************************************/
 133 static void plperl_init_all(void);
 134 static void plperl_init_safe_interp(void);
 135
 136 Datum plperl_call_handler(PG_FUNCTION_ARGS);
 137
 138 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 139
 140 static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
 141 static void plperl_init_shared_libs(void);
 142
 143 #ifdef REALLYHAVEITONTHEBALL
 144 static HeapTuple plperl_trigger_handler(PG_FUNCTION_ARGS);
 145
 146 static int plperl_elog(ClientData cdata, Tcl_Interp *interp,
 147                         int argc, char *argv[]);
 148 static int plperl_quote(ClientData cdata, Tcl_Interp *interp,
 149                          int argc, char *argv[]);
 150
 151 static int plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
 152                                 int argc, char *argv[]);
 153 static int plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
 154                                    int argc, char *argv[]);
 155 static int plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
 156                                  int argc, char *argv[]);
 157
 158 static void plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
 159                                                 int tupno, HeapTuple tuple, TupleDesc tupdesc);
 160
 161 #endif
 162
 163
 164 /**********************************************************************
 165  * plperl_init_all()            - Initialize all
 166  **********************************************************************/
 167 static void
 168 plperl_init_all(void)
 169 {
 170
 171         /************************************************************
 172          * Do initialization only once
 173          ************************************************************/
 174         if (!plperl_firstcall)
 175                 return;
 176
 177
 178         /************************************************************
 179          * Destroy the existing safe interpreter
 180          ************************************************************/
 181         if (plperl_safe_interp != NULL)
 182         {
 183                 perl_destruct(plperl_safe_interp);
 184                 perl_free(plperl_safe_interp);
 185                 plperl_safe_interp = NULL;
 186         }
 187
 188         /************************************************************
 189          * Free the proc hash table
 190          ************************************************************/
 191         if (plperl_proc_hash != NULL)
 192         {
 193                 hv_undef(plperl_proc_hash);
 194                 SvREFCNT_dec((SV *) plperl_proc_hash);
 195                 plperl_proc_hash = NULL;
 196         }
 197
 198         /************************************************************
 199          * Free the prepared query hash table
 200          ************************************************************/
 201
 202         /*
 203          * if (plperl_query_hash != NULL) { }
 204          */
 205
 206         /************************************************************
 207          * Now recreate a new safe interpreter
 208          ************************************************************/
 209         plperl_init_safe_interp();
 210
 211         plperl_firstcall = 0;
 212         return;
 213 }
 214
 215
 216 /**********************************************************************
 217  * plperl_init_safe_interp() - Create the safe Perl interpreter
 218  **********************************************************************/
 219 static void
 220 plperl_init_safe_interp(void)
 221 {
 222
 223         char       *embedding[3] = {
 224                 "", "-e",
 225                 /* no commas between the next 4 please. They are supposed to be one string
 226                  */
 227                 "require Safe; SPI::bootstrap();"
 228                 "sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');"
 229                 "$x->share(qw[&elog &DEBUG &NOTICE &NOIND &ERROR]);"
 230                 " return $x->reval(qq[sub { $_[0] }]); }"
 231                 };
 232
 233         plperl_safe_interp = perl_alloc();
 234         if (!plperl_safe_interp)
 235                 elog(ERROR, "plperl_init_safe_interp(): could not allocate perl interpreter");
 236
 237         perl_construct(plperl_safe_interp);
 238         perl_parse(plperl_safe_interp, plperl_init_shared_libs, 3, embedding, NULL);
 239         perl_run(plperl_safe_interp);
 240
 241
 242
 243         /************************************************************
 244          * Initialize the proc and query hash tables
 245          ************************* ***********************************/
 246         plperl_proc_hash = newHV();
 247
 248 }
 249
 250
 251
 252 /**********************************************************************
 253  * plperl_call_handler          - This is the only visible function
 254  *                                of the PL interpreter. The PostgreSQL
 255  *                                function manager and trigger manager
 256  *                                call this function for execution of
 257  *                                perl procedures.
 258  **********************************************************************/
 259
 260 /* keep non-static */
 261 Datum
 262 plperl_call_handler(PG_FUNCTION_ARGS)
 263 {
 264         Datum           retval;
 265
 266         /************************************************************
 267          * Initialize interpreters on first call
 268          ************************************************************/
 269         if (plperl_firstcall)
 270                 plperl_init_all();
 271
 272         /************************************************************
 273          * Connect to SPI manager
 274          ************************************************************/
 275         if (SPI_connect() != SPI_OK_CONNECT)
 276                 elog(ERROR, "plperl: cannot connect to SPI manager");
 277         /************************************************************
 278          * Keep track about the nesting of Tcl-SPI-Tcl-... calls
 279          ************************************************************/
 280         plperl_call_level++;
 281
 282         /************************************************************
 283          * Determine if called as function or trigger and
 284          * call appropriate subhandler
 285          ************************************************************/
 286         if (CALLED_AS_TRIGGER(fcinfo))
 287         {
 288                 elog(ERROR, "plperl: can't use perl in triggers yet.");
 289
 290                 /*
 291                  * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
 292                  */
 293                 /* make the compiler happy */
 294                 retval = (Datum) 0;
 295         }
 296         else
 297                 retval = plperl_func_handler(fcinfo);
 298
 299         plperl_call_level--;
 300
 301         return retval;
 302 }
 303
 304
 305 /**********************************************************************
 306  * plperl_create_sub()          - calls the perl interpreter to
 307  *              create the anonymous subroutine whose text is in the SV.
 308  *              Returns the SV containing the RV to the closure.
 309  **********************************************************************/
 310 static
 311 SV *
 312 plperl_create_sub(char * s)
 313 {
 314         dSP;
 315
 316         SV                 *subref = NULL;
 317         int count;
 318
 319         ENTER;
 320         SAVETMPS;
 321         PUSHMARK(SP);
 322         XPUSHs(sv_2mortal(newSVpv(s,0)));
 323         PUTBACK;
 324         count = perl_call_pv("mksafefunc", G_SCALAR | G_EVAL | G_KEEPERR);
 325         SPAGAIN;
 326
 327         if (SvTRUE(GvSV(errgv)))
 328         {
 329                 POPs;
 330                 PUTBACK;
 331                 FREETMPS;
 332                 LEAVE;
 333                 elog(ERROR, "creation of function failed : %s", SvPV(GvSV(errgv), na));
 334         }
 335
 336         if (count != 1) {
 337                 elog(ERROR, "creation of function failed - no return from mksafefunc");
 338         }
 339
 340         /*
 341          * need to make a deep copy of the return. it comes off the stack as a
 342          * temporary.
 343          */
 344         subref = newSVsv(POPs);
 345
 346         if (!SvROK(subref))
 347         {
 348                 PUTBACK;
 349                 FREETMPS;
 350                 LEAVE;
 351
 352                 /*
 353                  * subref is our responsibility because it is not mortal
 354                  */
 355                 SvREFCNT_dec(subref);
 356                 elog(ERROR, "plperl_create_sub: didn't get a code ref");
 357         }
 358
 359         PUTBACK;
 360         FREETMPS;
 361         LEAVE;
 362         return subref;
 363 }
 364
 365 /**********************************************************************
 366  * plperl_init_shared_libs()            -
 367  *
 368  * We cannot use the DynaLoader directly to get at the Opcode
 369  * module (used by Safe.pm). So, we link Opcode into ourselves
 370  * and do the initialization behind perl's back.
 371  *
 372  **********************************************************************/
 373
 374 extern void boot_Opcode _((CV * cv));
 375 extern void boot_SPI _((CV * cv));
 376
 377 static void
 378 plperl_init_shared_libs(void)
 379 {
 380         char       *file = __FILE__;
 381
 382         newXS("Opcode::bootstrap", boot_Opcode, file);
 383         newXS("SPI::bootstrap", boot_SPI, file);
 384 }
 385
 386 /**********************************************************************
 387  * plperl_call_perl_func()              - calls a perl function through the RV
 388  *                      stored in the prodesc structure. massages the input parms properly
 389  **********************************************************************/
 390 static
 391 SV *
 392 plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
 393 {
 394         dSP;
 395
 396         SV                 *retval;
 397         int                     i;
 398         int                     count;
 399
 400
 401         ENTER;
 402         SAVETMPS;
 403
 404         PUSHMARK(sp);
 405         for (i = 0; i < desc->nargs; i++)
 406         {
 407                 if (desc->arg_is_rel[i])
 408                 {
 409                         TupleTableSlot *slot = (TupleTableSlot *) fcinfo->arg[i];
 410                         SV                 *hashref;
 411
 412                         Assert(slot != NULL && ! fcinfo->argnull[i]);
 413                         /*
 414                          * plperl_build_tuple_argument better return a mortal SV.
 415                          */
 416                         hashref = plperl_build_tuple_argument(slot->val,
 417                                                                                                   slot->ttc_tupleDescriptor);
 418                         XPUSHs(hashref);
 419                 }
 420                 else
 421                 {
 422                         if (fcinfo->argnull[i])
 423                         {
 424                                 XPUSHs(&PL_sv_undef);
 425                         }
 426                         else
 427                         {
 428                                 char       *tmp;
 429
 430                                 tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
 431                                                                           fcinfo->arg[i],
 432                                                                           ObjectIdGetDatum(desc->arg_out_elem[i]),
 433                                                                           Int32GetDatum(desc->arg_out_len[i])));
 434                                 XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
 435                                 pfree(tmp);
 436                         }
 437                 }
 438         }
 439         PUTBACK;
 440         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
 441
 442         SPAGAIN;
 443
 444         if (count != 1)
 445         {
 446                 PUTBACK;
 447                 FREETMPS;
 448                 LEAVE;
 449                 elog(ERROR, "plperl : didn't get a return item from function");
 450         }
 451
 452         if (SvTRUE(GvSV(errgv)))
 453         {
 454                 POPs;
 455                 PUTBACK;
 456                 FREETMPS;
 457                 LEAVE;
 458                 elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(errgv), na));
 459         }
 460
 461         retval = newSVsv(POPs);
 462
 463
 464         PUTBACK;
 465         FREETMPS;
 466         LEAVE;
 467
 468         return retval;
 469
 470
 471 }
 472
 473 /**********************************************************************
 474  * plperl_func_handler()                - Handler for regular function calls
 475  **********************************************************************/
 476 static Datum
 477 plperl_func_handler(PG_FUNCTION_ARGS)
 478 {
 479         int                     i;
 480         char            internal_proname[512];
 481         int                     proname_len;
 482         plperl_proc_desc *prodesc;
 483         SV                 *perlret;
 484         Datum           retval;
 485         sigjmp_buf      save_restart;
 486
 487         /************************************************************
 488          * Build our internal proc name from the functions Oid
 489          ************************************************************/
 490         sprintf(internal_proname, "__PLPerl_proc_%u", fcinfo->flinfo->fn_oid);
 491         proname_len = strlen(internal_proname);
 492
 493         /************************************************************
 494          * Lookup the internal proc name in the hashtable
 495          ************************************************************/
 496         if (!hv_exists(plperl_proc_hash, internal_proname, proname_len))
 497         {
 498                 /************************************************************
 499                  * If we haven't found it in the hashtable, we analyze
 500                  * the functions arguments and returntype and store
 501                  * the in-/out-functions in the prodesc block and create
 502                  * a new hashtable entry for it.
 503                  *
 504                  * Then we load the procedure into the safe interpreter.
 505                  ************************************************************/
 506                 HeapTuple       procTup;
 507                 HeapTuple       typeTup;
 508                 Form_pg_proc procStruct;
 509                 Form_pg_type typeStruct;
 510                 char       *proc_source;
 511
 512                 /************************************************************
 513                  * Allocate a new procedure description block
 514                  ************************************************************/
 515                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
 516                 prodesc->proname = malloc(strlen(internal_proname) + 1);
 517                 strcpy(prodesc->proname, internal_proname);
 518
 519                 /************************************************************
 520                  * Lookup the pg_proc tuple by Oid
 521                  ************************************************************/
 522                 procTup = SearchSysCacheTuple(PROCOID,
 523                                                                           ObjectIdGetDatum(fcinfo->flinfo->fn_oid),
 524                                                                           0, 0, 0);
 525                 if (!HeapTupleIsValid(procTup))
 526                 {
 527                         free(prodesc->proname);
 528                         free(prodesc);
 529                         elog(ERROR, "plperl: cache lookup for proc %u failed",
 530                                  fcinfo->flinfo->fn_oid);
 531                 }
 532                 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
 533
 534                 /************************************************************
 535                  * Get the required information for input conversion of the
 536                  * return value.
 537                  ************************************************************/
 538                 typeTup = SearchSysCacheTuple(TYPEOID,
 539                                                                 ObjectIdGetDatum(procStruct->prorettype),
 540                                                                           0, 0, 0);
 541                 if (!HeapTupleIsValid(typeTup))
 542                 {
 543                         free(prodesc->proname);
 544                         free(prodesc);
 545                         elog(ERROR, "plperl: cache lookup for return type %u failed",
 546                                  procStruct->prorettype);
 547                 }
 548                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 549
 550                 if (typeStruct->typrelid != InvalidOid)
 551                 {
 552                         free(prodesc->proname);
 553                         free(prodesc);
 554                         elog(ERROR, "plperl: return types of tuples not supported yet");
 555                 }
 556
 557                 fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
 558                 prodesc->result_in_elem = (Oid) (typeStruct->typelem);
 559                 prodesc->result_in_len = typeStruct->typlen;
 560
 561                 /************************************************************
 562                  * Get the required information for output conversion
 563                  * of all procedure arguments
 564                  ************************************************************/
 565                 prodesc->nargs = procStruct->pronargs;
 566                 for (i = 0; i < prodesc->nargs; i++)
 567                 {
 568                         typeTup = SearchSysCacheTuple(TYPEOID,
 569                                                         ObjectIdGetDatum(procStruct->proargtypes[i]),
 570                                                                                   0, 0, 0);
 571                         if (!HeapTupleIsValid(typeTup))
 572                         {
 573                                 free(prodesc->proname);
 574                                 free(prodesc);
 575                                 elog(ERROR, "plperl: cache lookup for argument type %u failed",
 576                                          procStruct->proargtypes[i]);
 577                         }
 578                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 579
 580                         if (typeStruct->typrelid != InvalidOid)
 581                                 prodesc->arg_is_rel[i] = 1;
 582                         else
 583                                 prodesc->arg_is_rel[i] = 0;
 584
 585                         fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
 586                         prodesc->arg_out_elem[i] = (Oid) (typeStruct->typelem);
 587                         prodesc->arg_out_len[i] = typeStruct->typlen;
 588
 589                 }
 590
 591                 /************************************************************
 592                  * create the text of the anonymous subroutine.
 593                  * we do not use a named subroutine so that we can call directly
 594                  * through the reference.
 595                  *
 596                  ************************************************************/
 597                 proc_source = textout(&(procStruct->prosrc));
 598
 599
 600                 /************************************************************
 601                  * Create the procedure in the interpreter
 602                  ************************************************************/
 603                 prodesc->reference = plperl_create_sub(proc_source);
 604                 pfree(proc_source);
 605                 if (!prodesc->reference)
 606                 {
 607                         free(prodesc->proname);
 608                         free(prodesc);
 609                         elog(ERROR, "plperl: cannot create internal procedure %s",
 610                                  internal_proname);
 611                 }
 612
 613                 /************************************************************
 614                  * Add the proc description block to the hashtable
 615                  ************************************************************/
 616                 hv_store(plperl_proc_hash, internal_proname, proname_len,
 617                                  newSViv((IV) prodesc), 0);
 618         }
 619         else
 620         {
 621                 /************************************************************
 622                  * Found the proc description block in the hashtable
 623                  ************************************************************/
 624                 prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
 625                                                                           internal_proname, proname_len, 0));
 626         }
 627
 628
 629         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
 630
 631         if (sigsetjmp(Warn_restart, 1) != 0)
 632         {
 633                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 634                 plperl_restart_in_progress = 1;
 635                 if (--plperl_call_level == 0)
 636                         plperl_restart_in_progress = 0;
 637                 siglongjmp(Warn_restart, 1);
 638         }
 639
 640
 641         /************************************************************
 642          * Call the Perl function
 643          ************************************************************/
 644         perlret = plperl_call_perl_func(prodesc, fcinfo);
 645
 646         /************************************************************
 647          * Disconnect from SPI manager and then create the return
 648          * values datum (if the input function does a palloc for it
 649          * this must not be allocated in the SPI memory context
 650          * because SPI_finish would free it).
 651          ************************************************************/
 652         if (SPI_finish() != SPI_OK_FINISH)
 653                 elog(ERROR, "plperl: SPI_finish() failed");
 654
 655         /* XXX is this the approved way to check for an undef result? */
 656         if (perlret == &PL_sv_undef)
 657         {
 658                 retval = (Datum) 0;
 659                 fcinfo->isnull = true;
 660         }
 661         else
 662         {
 663                 retval = FunctionCall3(&prodesc->result_in_func,
 664                                                            PointerGetDatum(SvPV(perlret, na)),
 665                                                            ObjectIdGetDatum(prodesc->result_in_elem),
 666                                                            Int32GetDatum(prodesc->result_in_len));
 667         }
 668
 669         SvREFCNT_dec(perlret);
 670
 671         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 672         if (plperl_restart_in_progress)
 673         {
 674                 if (--plperl_call_level == 0)
 675                         plperl_restart_in_progress = 0;
 676                 siglongjmp(Warn_restart, 1);
 677         }
 678
 679         return retval;
 680 }
 681
 682
 683 #ifdef REALLYHAVEITONTHEBALL
 684 /**********************************************************************
 685  * plperl_trigger_handler() - Handler for trigger calls
 686  **********************************************************************/
 687 static HeapTuple
 688 plperl_trigger_handler(PG_FUNCTION_ARGS)
 689 {
 690         TriggerData *trigdata = (TriggerData *) fcinfo->context;
 691         char            internal_proname[512];
 692         char       *stroid;
 693         Tcl_HashEntry *hashent;
 694         int                     hashnew;
 695         plperl_proc_desc *prodesc;
 696         TupleDesc       tupdesc;
 697         HeapTuple       rettup;
 698         Tcl_DString tcl_cmd;
 699         Tcl_DString tcl_trigtup;
 700         Tcl_DString tcl_newtup;
 701         int                     tcl_rc;
 702         int                     i;
 703
 704         int                *modattrs;
 705         Datum      *modvalues;
 706         char       *modnulls;
 707
 708         int                     ret_numvals;
 709         char      **ret_values;
 710
 711         sigjmp_buf      save_restart;
 712
 713         /************************************************************
 714          * Build our internal proc name from the functions Oid
 715          ************************************************************/
 716         sprintf(internal_proname, "__PLPerl_proc_%u", fcinfo->flinfo->fn_oid);
 717
 718         /************************************************************
 719          * Lookup the internal proc name in the hashtable
 720          ************************************************************/
 721         hashent = Tcl_FindHashEntry(plperl_proc_hash, internal_proname);
 722         if (hashent == NULL)
 723         {
 724                 /************************************************************
 725                  * If we haven't found it in the hashtable,
 726                  * we load the procedure into the safe interpreter.
 727                  ************************************************************/
 728                 Tcl_DString proc_internal_def;
 729                 Tcl_DString proc_internal_body;
 730                 HeapTuple       procTup;
 731                 Form_pg_proc procStruct;
 732                 char       *proc_source;
 733
 734                 /************************************************************
 735                  * Allocate a new procedure description block
 736                  ************************************************************/
 737                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
 738                 memset(prodesc, 0, sizeof(plperl_proc_desc));
 739                 prodesc->proname = malloc(strlen(internal_proname) + 1);
 740                 strcpy(prodesc->proname, internal_proname);
 741
 742                 /************************************************************
 743                  * Lookup the pg_proc tuple by Oid
 744                  ************************************************************/
 745                 procTup = SearchSysCacheTuple(PROCOID,
 746                                                                           ObjectIdGetDatum(fcinfo->flinfo->fn_oid),
 747                                                                           0, 0, 0);
 748                 if (!HeapTupleIsValid(procTup))
 749                 {
 750                         free(prodesc->proname);
 751                         free(prodesc);
 752                         elog(ERROR, "plperl: cache lookup for proc %u failed",
 753                                  fcinfo->flinfo->fn_oid);
 754                 }
 755                 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
 756
 757                 /************************************************************
 758                  * Create the tcl command to define the internal
 759                  * procedure
 760                  ************************************************************/
 761                 Tcl_DStringInit(&proc_internal_def);
 762                 Tcl_DStringInit(&proc_internal_body);
 763                 Tcl_DStringAppendElement(&proc_internal_def, "proc");
 764                 Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
 765                 Tcl_DStringAppendElement(&proc_internal_def,
 766                                                                  "TG_name TG_relid TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
 767
 768                 /************************************************************
 769                  * prefix procedure body with
 770                  * upvar #0 <internal_procname> GD
 771                  * and with appropriate setting of NEW, OLD,
 772                  * and the arguments as numerical variables.
 773                  ************************************************************/
 774                 Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
 775                 Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
 776                 Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
 777
 778                 Tcl_DStringAppend(&proc_internal_body,
 779                                                   "array set NEW $__PLTcl_Tup_NEW\n", -1);
 780                 Tcl_DStringAppend(&proc_internal_body,
 781                                                   "array set OLD $__PLTcl_Tup_OLD\n", -1);
 782
 783                 Tcl_DStringAppend(&proc_internal_body,
 784                                                   "set i 0\n"
 785                                                   "set v 0\n"
 786                                                   "foreach v $args {\n"
 787                                                   "  incr i\n"
 788                                                   "  set $i $v\n"
 789                                                   "}\n"
 790                                                   "unset i v\n\n", -1);
 791
 792                 proc_source = textout(&(procStruct->prosrc));
 793                 Tcl_DStringAppend(&proc_internal_body, proc_source, -1);
 794                 pfree(proc_source);
 795                 Tcl_DStringAppendElement(&proc_internal_def,
 796                                                                  Tcl_DStringValue(&proc_internal_body));
 797                 Tcl_DStringFree(&proc_internal_body);
 798
 799                 /************************************************************
 800                  * Create the procedure in the safe interpreter
 801                  ************************************************************/
 802                 tcl_rc = Tcl_GlobalEval(plperl_safe_interp,
 803                                                                 Tcl_DStringValue(&proc_internal_def));
 804                 Tcl_DStringFree(&proc_internal_def);
 805                 if (tcl_rc != TCL_OK)
 806                 {
 807                         free(prodesc->proname);
 808                         free(prodesc);
 809                         elog(ERROR, "plperl: cannot create internal procedure %s - %s",
 810                                  internal_proname, plperl_safe_interp->result);
 811                 }
 812
 813                 /************************************************************
 814                  * Add the proc description block to the hashtable
 815                  ************************************************************/
 816                 hashent = Tcl_CreateHashEntry(plperl_proc_hash,
 817                                                                           prodesc->proname, &hashnew);
 818                 Tcl_SetHashValue(hashent, (ClientData) prodesc);
 819         }
 820         else
 821         {
 822                 /************************************************************
 823                  * Found the proc description block in the hashtable
 824                  ************************************************************/
 825                 prodesc = (plperl_proc_desc *) Tcl_GetHashValue(hashent);
 826         }
 827
 828         tupdesc = trigdata->tg_relation->rd_att;
 829
 830         /************************************************************
 831          * Create the tcl command to call the internal
 832          * proc in the safe interpreter
 833          ************************************************************/
 834         Tcl_DStringInit(&tcl_cmd);
 835         Tcl_DStringInit(&tcl_trigtup);
 836         Tcl_DStringInit(&tcl_newtup);
 837
 838         /************************************************************
 839          * We call external functions below - care for elog(ERROR)
 840          ************************************************************/
 841         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
 842         if (sigsetjmp(Warn_restart, 1) != 0)
 843         {
 844                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 845                 Tcl_DStringFree(&tcl_cmd);
 846                 Tcl_DStringFree(&tcl_trigtup);
 847                 Tcl_DStringFree(&tcl_newtup);
 848                 plperl_restart_in_progress = 1;
 849                 if (--plperl_call_level == 0)
 850                         plperl_restart_in_progress = 0;
 851                 siglongjmp(Warn_restart, 1);
 852         }
 853
 854         /* The procedure name */
 855         Tcl_DStringAppendElement(&tcl_cmd, internal_proname);
 856
 857         /* The trigger name for argument TG_name */
 858         Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgname);
 859
 860         /* The oid of the trigger relation for argument TG_relid */
 861         stroid = DatumGetCString(DirectFunctionCall1(oidout,
 862                                                          ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
 863         Tcl_DStringAppendElement(&tcl_cmd, stroid);
 864         pfree(stroid);
 865
 866         /* A list of attribute names for argument TG_relatts */
 867         Tcl_DStringAppendElement(&tcl_trigtup, "");
 868         for (i = 0; i < tupdesc->natts; i++)
 869                 Tcl_DStringAppendElement(&tcl_trigtup, tupdesc->attrs[i]->attname.data);
 870         Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 871         Tcl_DStringFree(&tcl_trigtup);
 872         Tcl_DStringInit(&tcl_trigtup);
 873
 874         /* The when part of the event for TG_when */
 875         if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
 876                 Tcl_DStringAppendElement(&tcl_cmd, "BEFORE");
 877         else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
 878                 Tcl_DStringAppendElement(&tcl_cmd, "AFTER");
 879         else
 880                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 881
 882         /* The level part of the event for TG_level */
 883         if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
 884                 Tcl_DStringAppendElement(&tcl_cmd, "ROW");
 885         else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
 886                 Tcl_DStringAppendElement(&tcl_cmd, "STATEMENT");
 887         else
 888                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 889
 890         /* Build the data list for the trigtuple */
 891         plperl_build_tuple_argument(trigdata->tg_trigtuple,
 892                                                                 tupdesc, &tcl_trigtup);
 893
 894         /*
 895          * Now the command part of the event for TG_op and data for NEW and
 896          * OLD
 897          */
 898         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
 899         {
 900                 Tcl_DStringAppendElement(&tcl_cmd, "INSERT");
 901
 902                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 903                 Tcl_DStringAppendElement(&tcl_cmd, "");
 904
 905                 rettup = trigdata->tg_trigtuple;
 906         }
 907         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
 908         {
 909                 Tcl_DStringAppendElement(&tcl_cmd, "DELETE");
 910
 911                 Tcl_DStringAppendElement(&tcl_cmd, "");
 912                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 913
 914                 rettup = trigdata->tg_trigtuple;
 915         }
 916         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
 917         {
 918                 Tcl_DStringAppendElement(&tcl_cmd, "UPDATE");
 919
 920                 plperl_build_tuple_argument(trigdata->tg_newtuple,
 921                                                                         tupdesc, &tcl_newtup);
 922
 923                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_newtup));
 924                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 925
 926                 rettup = trigdata->tg_newtuple;
 927         }
 928         else
 929         {
 930                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 931
 932                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 933                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 934
 935                 rettup = trigdata->tg_trigtuple;
 936         }
 937
 938         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 939         Tcl_DStringFree(&tcl_trigtup);
 940         Tcl_DStringFree(&tcl_newtup);
 941
 942         /************************************************************
 943          * Finally append the arguments from CREATE TRIGGER
 944          ************************************************************/
 945         for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
 946                 Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgargs[i]);
 947
 948         /************************************************************
 949          * Call the Tcl function
 950          ************************************************************/
 951         tcl_rc = Tcl_GlobalEval(plperl_safe_interp, Tcl_DStringValue(&tcl_cmd));
 952         Tcl_DStringFree(&tcl_cmd);
 953
 954         /************************************************************
 955          * Check the return code from Tcl and handle
 956          * our special restart mechanism to get rid
 957          * of all nested call levels on transaction
 958          * abort.
 959          ************************************************************/
 960         if (tcl_rc == TCL_ERROR || plperl_restart_in_progress)
 961         {
 962                 if (!plperl_restart_in_progress)
 963                 {
 964                         plperl_restart_in_progress = 1;
 965                         if (--plperl_call_level == 0)
 966                                 plperl_restart_in_progress = 0;
 967                         elog(ERROR, "plperl: %s", plperl_safe_interp->result);
 968                 }
 969                 if (--plperl_call_level == 0)
 970                         plperl_restart_in_progress = 0;
 971                 siglongjmp(Warn_restart, 1);
 972         }
 973
 974         switch (tcl_rc)
 975         {
 976                 case TCL_OK:
 977                         break;
 978
 979                 default:
 980                         elog(ERROR, "plperl: unsupported TCL return code %d", tcl_rc);
 981         }
 982
 983         /************************************************************
 984          * The return value from the procedure might be one of
 985          * the magic strings OK or SKIP or a list from array get
 986          ************************************************************/
 987         if (SPI_finish() != SPI_OK_FINISH)
 988                 elog(ERROR, "plperl: SPI_finish() failed");
 989
 990         if (strcmp(plperl_safe_interp->result, "OK") == 0)
 991                 return rettup;
 992         if (strcmp(plperl_safe_interp->result, "SKIP") == 0)
 993         {
 994                 return (HeapTuple) NULL;;
 995         }
 996
 997         /************************************************************
 998          * Convert the result value from the safe interpreter
 999          * and setup structures for SPI_modifytuple();
1000          ************************************************************/
1001         if (Tcl_SplitList(plperl_safe_interp, plperl_safe_interp->result,
1002                                           &ret_numvals, &ret_values) != TCL_OK)
1003         {
1004                 elog(NOTICE, "plperl: cannot split return value from trigger");
1005                 elog(ERROR, "plperl: %s", plperl_safe_interp->result);
1006         }
1007
1008         if (ret_numvals % 2 != 0)
1009         {
1010                 ckfree(ret_values);
1011                 elog(ERROR, "plperl: invalid return list from trigger - must have even # of elements");
1012         }
1013
1014         modattrs = (int *) palloc(tupdesc->natts * sizeof(int));
1015         modvalues = (Datum *) palloc(tupdesc->natts * sizeof(Datum));
1016         for (i = 0; i < tupdesc->natts; i++)
1017         {
1018                 modattrs[i] = i + 1;
1019                 modvalues[i] = (Datum) NULL;
1020         }
1021
1022         modnulls = palloc(tupdesc->natts + 1);
1023         memset(modnulls, 'n', tupdesc->natts);
1024         modnulls[tupdesc->natts] = '\0';
1025
1026         /************************************************************
1027          * Care for possible elog(ERROR)'s below
1028          ************************************************************/
1029         if (sigsetjmp(Warn_restart, 1) != 0)
1030         {
1031                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1032                 ckfree(ret_values);
1033                 plperl_restart_in_progress = 1;
1034                 if (--plperl_call_level == 0)
1035                         plperl_restart_in_progress = 0;
1036                 siglongjmp(Warn_restart, 1);
1037         }
1038
1039         i = 0;
1040         while (i < ret_numvals)
1041         {
1042                 int                     attnum;
1043                 HeapTuple       typeTup;
1044                 Oid                     typinput;
1045                 Oid                     typelem;
1046                 FmgrInfo        finfo;
1047
1048                 /************************************************************
1049                  * Ignore pseudo elements with a dot name
1050                  ************************************************************/
1051                 if (*(ret_values[i]) == '.')
1052                 {
1053                         i += 2;
1054                         continue;
1055                 }
1056
1057                 /************************************************************
1058                  * Get the attribute number
1059                  ************************************************************/
1060                 attnum = SPI_fnumber(tupdesc, ret_values[i++]);
1061                 if (attnum == SPI_ERROR_NOATTRIBUTE)
1062                         elog(ERROR, "plperl: invalid attribute '%s'", ret_values[--i]);
1063
1064                 /************************************************************
1065                  * Lookup the attribute type in the syscache
1066                  * for the input function
1067                  ************************************************************/
1068                 typeTup = SearchSysCacheTuple(TYPEOID,
1069                                   ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid),
1070                                                                           0, 0, 0);
1071                 if (!HeapTupleIsValid(typeTup))
1072                 {
1073                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
1074                                  ret_values[--i],
1075                                  tupdesc->attrs[attnum - 1]->atttypid);
1076                 }
1077                 typinput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typinput);
1078                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
1079
1080                 /************************************************************
1081                  * Set the attribute to NOT NULL and convert the contents
1082                  ************************************************************/
1083                 modnulls[attnum - 1] = ' ';
1084                 fmgr_info(typinput, &finfo);
1085                 modvalues[attnum - 1] =
1086                         FunctionCall3(&finfo,
1087                                                   CStringGetDatum(ret_values[i++]),
1088                                                   ObjectIdGetDatum(typelem),
1089                                                   Int32GetDatum(tupdesc->attrs[attnum-1]->atttypmod));
1090         }
1091
1092
1093         rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts,
1094                                                          modattrs, modvalues, modnulls);
1095
1096         pfree(modattrs);
1097         pfree(modvalues);
1098         pfree(modnulls);
1099
1100         if (rettup == NULL)
1101                 elog(ERROR, "plperl: SPI_modifytuple() failed - RC = %d\n", SPI_result);
1102
1103         ckfree(ret_values);
1104         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1105
1106         return rettup;
1107 }
1108
1109
1110 /**********************************************************************
1111  * plperl_elog()                - elog() support for PLTcl
1112  **********************************************************************/
1113 static int
1114 plperl_elog(ClientData cdata, Tcl_Interp *interp,
1115                         int argc, char *argv[])
1116 {
1117         int                     level;
1118         sigjmp_buf      save_restart;
1119
1120         /************************************************************
1121          * Suppress messages during the restart process
1122          ************************************************************/
1123         if (plperl_restart_in_progress)
1124                 return TCL_ERROR;
1125
1126         /************************************************************
1127          * Catch the restart longjmp and begin a controlled
1128          * return though all interpreter levels if it happens
1129          ************************************************************/
1130         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1131         if (sigsetjmp(Warn_restart, 1) != 0)
1132         {
1133                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1134                 plperl_restart_in_progress = 1;
1135                 return TCL_ERROR;
1136         }
1137
1138         if (argc != 3)
1139         {
1140                 Tcl_SetResult(interp, "syntax error - 'elog level msg'",
1141                                           TCL_VOLATILE);
1142                 return TCL_ERROR;
1143         }
1144
1145         if (strcmp(argv[1], "NOTICE") == 0)
1146                 level = NOTICE;
1147         else if (strcmp(argv[1], "WARN") == 0)
1148                 level = ERROR;
1149         else if (strcmp(argv[1], "ERROR") == 0)
1150                 level = ERROR;
1151         else if (strcmp(argv[1], "FATAL") == 0)
1152                 level = FATAL;
1153         else if (strcmp(argv[1], "DEBUG") == 0)
1154                 level = DEBUG;
1155         else if (strcmp(argv[1], "NOIND") == 0)
1156                 level = NOIND;
1157         else
1158         {
1159                 Tcl_AppendResult(interp, "Unknown elog level '", argv[1],
1160                                                  "'", NULL);
1161                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1162                 return TCL_ERROR;
1163         }
1164
1165         /************************************************************
1166          * Call elog(), restore the original restart address
1167          * and return to the caller (if not catched)
1168          ************************************************************/
1169         elog(level, argv[2]);
1170         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1171         return TCL_OK;
1172 }
1173
1174
1175 /**********************************************************************
1176  * plperl_quote()       - quote literal strings that are to
1177  *                        be used in SPI_exec query strings
1178  **********************************************************************/
1179 static int
1180 plperl_quote(ClientData cdata, Tcl_Interp *interp,
1181                          int argc, char *argv[])
1182 {
1183         char       *tmp;
1184         char       *cp1;
1185         char       *cp2;
1186
1187         /************************************************************
1188          * Check call syntax
1189          ************************************************************/
1190         if (argc != 2)
1191         {
1192                 Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_VOLATILE);
1193                 return TCL_ERROR;
1194         }
1195
1196         /************************************************************
1197          * Allocate space for the maximum the string can
1198          * grow to and initialize pointers
1199          ************************************************************/
1200         tmp = palloc(strlen(argv[1]) * 2 + 1);
1201         cp1 = argv[1];
1202         cp2 = tmp;
1203
1204         /************************************************************
1205          * Walk through string and double every quote and backslash
1206          ************************************************************/
1207         while (*cp1)
1208         {
1209                 if (*cp1 == '\'')
1210                         *cp2++ = '\'';
1211                 else
1212                 {
1213                         if (*cp1 == '\\')
1214                                 *cp2++ = '\\';
1215                 }
1216                 *cp2++ = *cp1++;
1217         }
1218
1219         /************************************************************
1220          * Terminate the string and set it as result
1221          ************************************************************/
1222         *cp2 = '\0';
1223         Tcl_SetResult(interp, tmp, TCL_VOLATILE);
1224         pfree(tmp);
1225         return TCL_OK;
1226 }
1227
1228
1229 /**********************************************************************
1230  * plperl_SPI_exec()            - The builtin SPI_exec command
1231  *                                for the safe interpreter
1232  **********************************************************************/
1233 static int
1234 plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
1235                                 int argc, char *argv[])
1236 {
1237         int                     spi_rc;
1238         char            buf[64];
1239         int                     count = 0;
1240         char       *arrayname = NULL;
1241         int                     query_idx;
1242         int                     i;
1243         int                     loop_rc;
1244         int                     ntuples;
1245         HeapTuple  *tuples;
1246         TupleDesc       tupdesc = NULL;
1247         sigjmp_buf      save_restart;
1248
1249         char       *usage = "syntax error - 'SPI_exec "
1250         "?-count n? "
1251         "?-array name? query ?loop body?";
1252
1253         /************************************************************
1254          * Don't do anything if we are already in restart mode
1255          ************************************************************/
1256         if (plperl_restart_in_progress)
1257                 return TCL_ERROR;
1258
1259         /************************************************************
1260          * Check the call syntax and get the count option
1261          ************************************************************/
1262         if (argc < 2)
1263         {
1264                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1265                 return TCL_ERROR;
1266         }
1267
1268         i = 1;
1269         while (i < argc)
1270         {
1271                 if (strcmp(argv[i], "-array") == 0)
1272                 {
1273                         if (++i >= argc)
1274                         {
1275                                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1276                                 return TCL_ERROR;
1277                         }
1278                         arrayname = argv[i++];
1279                         continue;
1280                 }
1281
1282                 if (strcmp(argv[i], "-count") == 0)
1283                 {
1284                         if (++i >= argc)
1285                         {
1286                                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1287                                 return TCL_ERROR;
1288                         }
1289                         if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
1290                                 return TCL_ERROR;
1291                         continue;
1292                 }
1293
1294                 break;
1295         }
1296
1297         query_idx = i;
1298         if (query_idx >= argc)
1299         {
1300                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1301                 return TCL_ERROR;
1302         }
1303
1304         /************************************************************
1305          * Prepare to start a controlled return through all
1306          * interpreter levels on transaction abort
1307          ************************************************************/
1308         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1309         if (sigsetjmp(Warn_restart, 1) != 0)
1310         {
1311                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1312                 plperl_restart_in_progress = 1;
1313                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1314                 return TCL_ERROR;
1315         }
1316
1317         /************************************************************
1318          * Execute the query and handle return codes
1319          ************************************************************/
1320         spi_rc = SPI_exec(argv[query_idx], count);
1321         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1322
1323         switch (spi_rc)
1324         {
1325                 case SPI_OK_UTILITY:
1326                         Tcl_SetResult(interp, "0", TCL_VOLATILE);
1327                         return TCL_OK;
1328
1329                 case SPI_OK_SELINTO:
1330                 case SPI_OK_INSERT:
1331                 case SPI_OK_DELETE:
1332                 case SPI_OK_UPDATE:
1333                         sprintf(buf, "%d", SPI_processed);
1334                         Tcl_SetResult(interp, buf, TCL_VOLATILE);
1335                         return TCL_OK;
1336
1337                 case SPI_OK_SELECT:
1338                         break;
1339
1340                 case SPI_ERROR_ARGUMENT:
1341                         Tcl_SetResult(interp,
1342                                                 "plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
1343                                                   TCL_VOLATILE);
1344                         return TCL_ERROR;
1345
1346                 case SPI_ERROR_UNCONNECTED:
1347                         Tcl_SetResult(interp,
1348                                          "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
1349                                                   TCL_VOLATILE);
1350                         return TCL_ERROR;
1351
1352                 case SPI_ERROR_COPY:
1353                         Tcl_SetResult(interp,
1354                                                   "plperl: SPI_exec() failed - SPI_ERROR_COPY",
1355                                                   TCL_VOLATILE);
1356                         return TCL_ERROR;
1357
1358                 case SPI_ERROR_CURSOR:
1359                         Tcl_SetResult(interp,
1360                                                   "plperl: SPI_exec() failed - SPI_ERROR_CURSOR",
1361                                                   TCL_VOLATILE);
1362                         return TCL_ERROR;
1363
1364                 case SPI_ERROR_TRANSACTION:
1365                         Tcl_SetResult(interp,
1366                                          "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
1367                                                   TCL_VOLATILE);
1368                         return TCL_ERROR;
1369
1370                 case SPI_ERROR_OPUNKNOWN:
1371                         Tcl_SetResult(interp,
1372                                            "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
1373                                                   TCL_VOLATILE);
1374                         return TCL_ERROR;
1375
1376                 default:
1377                         sprintf(buf, "%d", spi_rc);
1378                         Tcl_AppendResult(interp, "plperl: SPI_exec() failed - ",
1379                                                          "unknown RC ", buf, NULL);
1380                         return TCL_ERROR;
1381         }
1382
1383         /************************************************************
1384          * Only SELECT queries fall through to here - remember the
1385          * tuples we got
1386          ************************************************************/
1387
1388         ntuples = SPI_processed;
1389         if (ntuples > 0)
1390         {
1391                 tuples = SPI_tuptable->vals;
1392                 tupdesc = SPI_tuptable->tupdesc;
1393         }
1394
1395         /************************************************************
1396          * Again prepare for elog(ERROR)
1397          ************************************************************/
1398         if (sigsetjmp(Warn_restart, 1) != 0)
1399         {
1400                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1401                 plperl_restart_in_progress = 1;
1402                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1403                 return TCL_ERROR;
1404         }
1405
1406         /************************************************************
1407          * If there is no loop body given, just set the variables
1408          * from the first tuple (if any) and return the number of
1409          * tuples selected
1410          ************************************************************/
1411         if (argc == query_idx + 1)
1412         {
1413                 if (ntuples > 0)
1414                         plperl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
1415                 sprintf(buf, "%d", ntuples);
1416                 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1417                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1418                 return TCL_OK;
1419         }
1420
1421         /************************************************************
1422          * There is a loop body - process all tuples and evaluate
1423          * the body on each
1424          ************************************************************/
1425         query_idx++;
1426         for (i = 0; i < ntuples; i++)
1427         {
1428                 plperl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);
1429
1430                 loop_rc = Tcl_Eval(interp, argv[query_idx]);
1431
1432                 if (loop_rc == TCL_OK)
1433                         continue;
1434                 if (loop_rc == TCL_CONTINUE)
1435                         continue;
1436                 if (loop_rc == TCL_RETURN)
1437                 {
1438                         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1439                         return TCL_RETURN;
1440                 }
1441                 if (loop_rc == TCL_BREAK)
1442                         break;
1443                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1444                 return TCL_ERROR;
1445         }
1446
1447         /************************************************************
1448          * Finally return the number of tuples
1449          ************************************************************/
1450         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1451         sprintf(buf, "%d", ntuples);
1452         Tcl_SetResult(interp, buf, TCL_VOLATILE);
1453         return TCL_OK;
1454 }
1455
1456
1457 /**********************************************************************
1458  * plperl_SPI_prepare()         - Builtin support for prepared plans
1459  *                                The Tcl command SPI_prepare
1460  *                                allways saves the plan using
1461  *                                SPI_saveplan and returns a key for
1462  *                                access. There is no chance to prepare
1463  *                                and not save the plan currently.
1464  **********************************************************************/
1465 static int
1466 plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
1467                                    int argc, char *argv[])
1468 {
1469         int                     nargs;
1470         char      **args;
1471         plperl_query_desc *qdesc;
1472         void       *plan;
1473         int                     i;
1474         HeapTuple       typeTup;
1475         Tcl_HashEntry *hashent;
1476         int                     hashnew;
1477         sigjmp_buf      save_restart;
1478
1479         /************************************************************
1480          * Don't do anything if we are already in restart mode
1481          ************************************************************/
1482         if (plperl_restart_in_progress)
1483                 return TCL_ERROR;
1484
1485         /************************************************************
1486          * Check the call syntax
1487          ************************************************************/
1488         if (argc != 3)
1489         {
1490                 Tcl_SetResult(interp, "syntax error - 'SPI_prepare query argtypes'",
1491                                           TCL_VOLATILE);
1492                 return TCL_ERROR;
1493         }
1494
1495         /************************************************************
1496          * Split the argument type list
1497          ************************************************************/
1498         if (Tcl_SplitList(interp, argv[2], &nargs, &args) != TCL_OK)
1499                 return TCL_ERROR;
1500
1501         /************************************************************
1502          * Allocate the new querydesc structure
1503          ************************************************************/
1504         qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
1505         sprintf(qdesc->qname, "%lx", (long) qdesc);
1506         qdesc->nargs = nargs;
1507         qdesc->argtypes = (Oid *) malloc(nargs * sizeof(Oid));
1508         qdesc->arginfuncs = (FmgrInfo *) malloc(nargs * sizeof(FmgrInfo));
1509         qdesc->argtypelems = (Oid *) malloc(nargs * sizeof(Oid));
1510         qdesc->argvalues = (Datum *) malloc(nargs * sizeof(Datum));
1511         qdesc->arglen = (int *) malloc(nargs * sizeof(int));
1512
1513         /************************************************************
1514          * Prepare to start a controlled return through all
1515          * interpreter levels on transaction abort
1516          ************************************************************/
1517         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1518         if (sigsetjmp(Warn_restart, 1) != 0)
1519         {
1520                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1521                 plperl_restart_in_progress = 1;
1522                 free(qdesc->argtypes);
1523                 free(qdesc->arginfuncs);
1524                 free(qdesc->argtypelems);
1525                 free(qdesc->argvalues);
1526                 free(qdesc->arglen);
1527                 free(qdesc);
1528                 ckfree(args);
1529                 return TCL_ERROR;
1530         }
1531
1532         /************************************************************
1533          * Lookup the argument types by name in the system cache
1534          * and remember the required information for input conversion
1535          ************************************************************/
1536         for (i = 0; i < nargs; i++)
1537         {
1538                 typeTup = SearchSysCacheTuple(TYPNAME,
1539                                                                           PointerGetDatum(args[i]),
1540                                                                           0, 0, 0);
1541                 if (!HeapTupleIsValid(typeTup))
1542                         elog(ERROR, "plperl: Cache lookup of type %s failed", args[i]);
1543                 qdesc->argtypes[i] = typeTup->t_data->t_oid;
1544                 fmgr_info(((Form_pg_type) GETSTRUCT(typeTup))->typinput,
1545                                   &(qdesc->arginfuncs[i]));
1546                 qdesc->argtypelems[i] = ((Form_pg_type) GETSTRUCT(typeTup))->typelem;
1547                 qdesc->argvalues[i] = (Datum) NULL;
1548                 qdesc->arglen[i] = (int) (((Form_pg_type) GETSTRUCT(typeTup))->typlen);
1549         }
1550
1551         /************************************************************
1552          * Prepare the plan and check for errors
1553          ************************************************************/
1554         plan = SPI_prepare(argv[1], nargs, qdesc->argtypes);
1555
1556         if (plan == NULL)
1557         {
1558                 char            buf[128];
1559                 char       *reason;
1560
1561                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1562
1563                 switch (SPI_result)
1564                 {
1565                         case SPI_ERROR_ARGUMENT:
1566                                 reason = "SPI_ERROR_ARGUMENT";
1567                                 break;
1568
1569                         case SPI_ERROR_UNCONNECTED:
1570                                 reason = "SPI_ERROR_UNCONNECTED";
1571                                 break;
1572
1573                         case SPI_ERROR_COPY:
1574                                 reason = "SPI_ERROR_COPY";
1575                                 break;
1576
1577                         case SPI_ERROR_CURSOR:
1578                                 reason = "SPI_ERROR_CURSOR";
1579                                 break;
1580
1581                         case SPI_ERROR_TRANSACTION:
1582                                 reason = "SPI_ERROR_TRANSACTION";
1583                                 break;
1584
1585                         case SPI_ERROR_OPUNKNOWN:
1586                                 reason = "SPI_ERROR_OPUNKNOWN";
1587                                 break;
1588
1589                         default:
1590                                 sprintf(buf, "unknown RC %d", SPI_result);
1591                                 reason = buf;
1592                                 break;
1593
1594                 }
1595
1596                 elog(ERROR, "plperl: SPI_prepare() failed - %s", reason);
1597         }
1598
1599         /************************************************************
1600          * Save the plan
1601          ************************************************************/
1602         qdesc->plan = SPI_saveplan(plan);
1603         if (qdesc->plan == NULL)
1604         {
1605                 char            buf[128];
1606                 char       *reason;
1607
1608                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1609
1610                 switch (SPI_result)
1611                 {
1612                         case SPI_ERROR_ARGUMENT:
1613                                 reason = "SPI_ERROR_ARGUMENT";
1614                                 break;
1615
1616                         case SPI_ERROR_UNCONNECTED:
1617                                 reason = "SPI_ERROR_UNCONNECTED";
1618                                 break;
1619
1620                         default:
1621                                 sprintf(buf, "unknown RC %d", SPI_result);
1622                                 reason = buf;
1623                                 break;
1624
1625                 }
1626
1627                 elog(ERROR, "plperl: SPI_saveplan() failed - %s", reason);
1628         }
1629
1630         /************************************************************
1631          * Insert a hashtable entry for the plan and return
1632          * the key to the caller
1633          ************************************************************/
1634         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1635         hashent = Tcl_CreateHashEntry(plperl_query_hash, qdesc->qname, &hashnew);
1636         Tcl_SetHashValue(hashent, (ClientData) qdesc);
1637
1638         Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE);
1639         return TCL_OK;
1640 }
1641
1642
1643 /**********************************************************************
1644  * plperl_SPI_execp()           - Execute a prepared plan
1645  **********************************************************************/
1646 static int
1647 plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
1648                                  int argc, char *argv[])
1649 {
1650         int                     spi_rc;
1651         char            buf[64];
1652         int                     i,
1653                                 j;
1654         int                     loop_body;
1655         Tcl_HashEntry *hashent;
1656         plperl_query_desc *qdesc;
1657         char       *nulls = NULL;
1658         char       *arrayname = NULL;
1659         int                     count = 0;
1660         int                     callnargs;
1661         static char **callargs = NULL;
1662         int                     loop_rc;
1663         int                     ntuples;
1664         HeapTuple  *tuples = NULL;
1665         TupleDesc       tupdesc = NULL;
1666         sigjmp_buf      save_restart;
1667
1668         char       *usage = "syntax error - 'SPI_execp "
1669         "?-nulls string? ?-count n? "
1670         "?-array name? query ?args? ?loop body?";
1671
1672         /************************************************************
1673          * Tidy up from an earlier abort
1674          ************************************************************/
1675         if (callargs != NULL)
1676         {
1677                 ckfree(callargs);
1678                 callargs = NULL;
1679         }
1680
1681         /************************************************************
1682          * Don't do anything if we are already in restart mode
1683          ************************************************************/
1684         if (plperl_restart_in_progress)
1685                 return TCL_ERROR;
1686
1687         /************************************************************
1688          * Get the options and check syntax
1689          ************************************************************/
1690         i = 1;
1691         while (i < argc)
1692         {
1693                 if (strcmp(argv[i], "-array") == 0)
1694                 {
1695                         if (++i >= argc)
1696                         {
1697                                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1698                                 return TCL_ERROR;
1699                         }
1700                         arrayname = argv[i++];
1701                         continue;
1702                 }
1703                 if (strcmp(argv[i], "-nulls") == 0)
1704                 {
1705                         if (++i >= argc)
1706                         {
1707                                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1708                                 return TCL_ERROR;
1709                         }
1710                         nulls = argv[i++];
1711                         continue;
1712                 }
1713                 if (strcmp(argv[i], "-count") == 0)
1714                 {
1715                         if (++i >= argc)
1716                         {
1717                                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1718                                 return TCL_ERROR;
1719                         }
1720                         if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
1721                                 return TCL_ERROR;
1722                         continue;
1723                 }
1724
1725                 break;
1726         }
1727
1728         /************************************************************
1729          * Check minimum call arguments
1730          ************************************************************/
1731         if (i >= argc)
1732         {
1733                 Tcl_SetResult(interp, usage, TCL_VOLATILE);
1734                 return TCL_ERROR;
1735         }
1736
1737         /************************************************************
1738          * Get the prepared plan descriptor by it's key
1739          ************************************************************/
1740         hashent = Tcl_FindHashEntry(plperl_query_hash, argv[i++]);
1741         if (hashent == NULL)
1742         {
1743                 Tcl_AppendResult(interp, "invalid queryid '", argv[--i], "'", NULL);
1744                 return TCL_ERROR;
1745         }
1746         qdesc = (plperl_query_desc *) Tcl_GetHashValue(hashent);
1747
1748         /************************************************************
1749          * If a nulls string is given, check for correct length
1750          ************************************************************/
1751         if (nulls != NULL)
1752         {
1753                 if (strlen(nulls) != qdesc->nargs)
1754                 {
1755                         Tcl_SetResult(interp,
1756                                    "length of nulls string doesn't match # of arguments",
1757                                                   TCL_VOLATILE);
1758                         return TCL_ERROR;
1759                 }
1760         }
1761
1762         /************************************************************
1763          * If there was a argtype list on preparation, we need
1764          * an argument value list now
1765          ************************************************************/
1766         if (qdesc->nargs > 0)
1767         {
1768                 if (i >= argc)
1769                 {
1770                         Tcl_SetResult(interp, "missing argument list", TCL_VOLATILE);
1771                         return TCL_ERROR;
1772                 }
1773
1774                 /************************************************************
1775                  * Split the argument values
1776                  ************************************************************/
1777                 if (Tcl_SplitList(interp, argv[i++], &callnargs, &callargs) != TCL_OK)
1778                         return TCL_ERROR;
1779
1780                 /************************************************************
1781                  * Check that the # of arguments matches
1782                  ************************************************************/
1783                 if (callnargs != qdesc->nargs)
1784                 {
1785                         Tcl_SetResult(interp,
1786                         "argument list length doesn't match # of arguments for query",
1787                                                   TCL_VOLATILE);
1788                         if (callargs != NULL)
1789                         {
1790                                 ckfree(callargs);
1791                                 callargs = NULL;
1792                         }
1793                         return TCL_ERROR;
1794                 }
1795
1796                 /************************************************************
1797                  * Prepare to start a controlled return through all
1798                  * interpreter levels on transaction abort during the
1799                  * parse of the arguments
1800                  ************************************************************/
1801                 memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1802                 if (sigsetjmp(Warn_restart, 1) != 0)
1803                 {
1804                         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1805                         for (j = 0; j < callnargs; j++)
1806                         {
1807                                 if (qdesc->arglen[j] < 0 &&
1808                                         qdesc->argvalues[j] != (Datum) NULL)
1809                                 {
1810                                         pfree((char *) (qdesc->argvalues[j]));
1811                                         qdesc->argvalues[j] = (Datum) NULL;
1812                                 }
1813                         }
1814                         ckfree(callargs);
1815                         callargs = NULL;
1816                         plperl_restart_in_progress = 1;
1817                         Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1818                         return TCL_ERROR;
1819                 }
1820
1821                 /************************************************************
1822                  * Setup the value array for the SPI_execp() using
1823                  * the type specific input functions
1824                  ************************************************************/
1825                 for (j = 0; j < callnargs; j++)
1826                 {
1827                         qdesc->argvalues[j] =
1828                                 FunctionCall3(&qdesc->arginfuncs[j],
1829                                                           CStringGetDatum(callargs[j]),
1830                                                           ObjectIdGetDatum(qdesc->argtypelems[j]),
1831                                                           Int32GetDatum(qdesc->arglen[j]));
1832                 }
1833
1834                 /************************************************************
1835                  * Free the splitted argument value list
1836                  ************************************************************/
1837                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1838                 ckfree(callargs);
1839                 callargs = NULL;
1840         }
1841         else
1842                 callnargs = 0;
1843
1844         /************************************************************
1845          * Remember the index of the last processed call
1846          * argument - a loop body for SELECT might follow
1847          ************************************************************/
1848         loop_body = i;
1849
1850         /************************************************************
1851          * Prepare to start a controlled return through all
1852          * interpreter levels on transaction abort
1853          ************************************************************/
1854         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1855         if (sigsetjmp(Warn_restart, 1) != 0)
1856         {
1857                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1858                 for (j = 0; j < callnargs; j++)
1859                 {
1860                         if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
1861                         {
1862                                 pfree((char *) (qdesc->argvalues[j]));
1863                                 qdesc->argvalues[j] = (Datum) NULL;
1864                         }
1865                 }
1866                 plperl_restart_in_progress = 1;
1867                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1868                 return TCL_ERROR;
1869         }
1870
1871         /************************************************************
1872          * Execute the plan
1873          ************************************************************/
1874         spi_rc = SPI_execp(qdesc->plan, qdesc->argvalues, nulls, count);
1875         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1876
1877         /************************************************************
1878          * For varlena data types, free the argument values
1879          ************************************************************/
1880         for (j = 0; j < callnargs; j++)
1881         {
1882                 if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
1883                 {
1884                         pfree((char *) (qdesc->argvalues[j]));
1885                         qdesc->argvalues[j] = (Datum) NULL;
1886                 }
1887         }
1888
1889         /************************************************************
1890          * Check the return code from SPI_execp()
1891          ************************************************************/
1892         switch (spi_rc)
1893         {
1894                 case SPI_OK_UTILITY:
1895                         Tcl_SetResult(interp, "0", TCL_VOLATILE);
1896                         return TCL_OK;
1897
1898                 case SPI_OK_SELINTO:
1899                 case SPI_OK_INSERT:
1900                 case SPI_OK_DELETE:
1901                 case SPI_OK_UPDATE:
1902                         sprintf(buf, "%d", SPI_processed);
1903                         Tcl_SetResult(interp, buf, TCL_VOLATILE);
1904                         return TCL_OK;
1905
1906                 case SPI_OK_SELECT:
1907                         break;
1908
1909                 case SPI_ERROR_ARGUMENT:
1910                         Tcl_SetResult(interp,
1911                                                 "plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
1912                                                   TCL_VOLATILE);
1913                         return TCL_ERROR;
1914
1915                 case SPI_ERROR_UNCONNECTED:
1916                         Tcl_SetResult(interp,
1917                                          "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
1918                                                   TCL_VOLATILE);
1919                         return TCL_ERROR;
1920
1921                 case SPI_ERROR_COPY:
1922                         Tcl_SetResult(interp,
1923                                                   "plperl: SPI_exec() failed - SPI_ERROR_COPY",
1924                                                   TCL_VOLATILE);
1925                         return TCL_ERROR;
1926
1927                 case SPI_ERROR_CURSOR:
1928                         Tcl_SetResult(interp,
1929                                                   "plperl: SPI_exec() failed - SPI_ERROR_CURSOR",
1930                                                   TCL_VOLATILE);
1931                         return TCL_ERROR;
1932
1933                 case SPI_ERROR_TRANSACTION:
1934                         Tcl_SetResult(interp,
1935                                          "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
1936                                                   TCL_VOLATILE);
1937                         return TCL_ERROR;
1938
1939                 case SPI_ERROR_OPUNKNOWN:
1940                         Tcl_SetResult(interp,
1941                                            "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
1942                                                   TCL_VOLATILE);
1943                         return TCL_ERROR;
1944
1945                 default:
1946                         sprintf(buf, "%d", spi_rc);
1947                         Tcl_AppendResult(interp, "plperl: SPI_exec() failed - ",
1948                                                          "unknown RC ", buf, NULL);
1949                         return TCL_ERROR;
1950         }
1951
1952         /************************************************************
1953          * Only SELECT queries fall through to here - remember the
1954          * tuples we got
1955          ************************************************************/
1956
1957         ntuples = SPI_processed;
1958         if (ntuples > 0)
1959         {
1960                 tuples = SPI_tuptable->vals;
1961                 tupdesc = SPI_tuptable->tupdesc;
1962         }
1963
1964         /************************************************************
1965          * Prepare to start a controlled return through all
1966          * interpreter levels on transaction abort during
1967          * the ouput conversions of the results
1968          ************************************************************/
1969         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1970         if (sigsetjmp(Warn_restart, 1) != 0)
1971         {
1972                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1973                 plperl_restart_in_progress = 1;
1974                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1975                 return TCL_ERROR;
1976         }
1977
1978         /************************************************************
1979          * If there is no loop body given, just set the variables
1980          * from the first tuple (if any) and return the number of
1981          * tuples selected
1982          ************************************************************/
1983         if (loop_body >= argc)
1984         {
1985                 if (ntuples > 0)
1986                         plperl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
1987                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1988                 sprintf(buf, "%d", ntuples);
1989                 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1990                 return TCL_OK;
1991         }
1992
1993         /************************************************************
1994          * There is a loop body - process all tuples and evaluate
1995          * the body on each
1996          ************************************************************/
1997         for (i = 0; i < ntuples; i++)
1998         {
1999                 plperl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);
2000
2001                 loop_rc = Tcl_Eval(interp, argv[loop_body]);
2002
2003                 if (loop_rc == TCL_OK)
2004                         continue;
2005                 if (loop_rc == TCL_CONTINUE)
2006                         continue;
2007                 if (loop_rc == TCL_RETURN)
2008                 {
2009                         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2010                         return TCL_RETURN;
2011                 }
2012                 if (loop_rc == TCL_BREAK)
2013                         break;
2014                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2015                 return TCL_ERROR;
2016         }
2017
2018         /************************************************************
2019          * Finally return the number of tuples
2020          ************************************************************/
2021         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2022         sprintf(buf, "%d", ntuples);
2023         Tcl_SetResult(interp, buf, TCL_VOLATILE);
2024         return TCL_OK;
2025 }
2026
2027
2028 /**********************************************************************
2029  * plperl_set_tuple_values() - Set variables for all attributes
2030  *                                of a given tuple
2031  **********************************************************************/
2032 static void
2033 plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
2034                                                 int tupno, HeapTuple tuple, TupleDesc tupdesc)
2035 {
2036         int                     i;
2037         char       *outputstr;
2038         char            buf[64];
2039         Datum           attr;
2040         bool            isnull;
2041
2042         char       *attname;
2043         HeapTuple       typeTup;
2044         Oid                     typoutput;
2045         Oid                     typelem;
2046
2047         char      **arrptr;
2048         char      **nameptr;
2049         char       *nullname = NULL;
2050
2051         /************************************************************
2052          * Prepare pointers for Tcl_SetVar2() below and in array
2053          * mode set the .tupno element
2054          ************************************************************/
2055         if (arrayname == NULL)
2056         {
2057                 arrptr = &attname;
2058                 nameptr = &nullname;
2059         }
2060         else
2061         {
2062                 arrptr = &arrayname;
2063                 nameptr = &attname;
2064                 sprintf(buf, "%d", tupno);
2065                 Tcl_SetVar2(interp, arrayname, ".tupno", buf, 0);
2066         }
2067
2068         for (i = 0; i < tupdesc->natts; i++)
2069         {
2070                 /************************************************************
2071                  * Get the attribute name
2072                  ************************************************************/
2073                 attname = tupdesc->attrs[i]->attname.data;
2074
2075                 /************************************************************
2076                  * Get the attributes value
2077                  ************************************************************/
2078                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2079
2080                 /************************************************************
2081                  * Lookup the attribute type in the syscache
2082                  * for the output function
2083                  ************************************************************/
2084                 typeTup = SearchSysCacheTuple(TYPEOID,
2085                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
2086                                                                           0, 0, 0);
2087                 if (!HeapTupleIsValid(typeTup))
2088                 {
2089                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
2090                                  attname, tupdesc->attrs[i]->atttypid);
2091                 }
2092
2093                 typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
2094                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
2095
2096                 /************************************************************
2097                  * If there is a value, set the variable
2098                  * If not, unset it
2099                  *
2100                  * Hmmm - Null attributes will cause functions to
2101                  *                crash if they don't expect them - need something
2102                  *                smarter here.
2103                  ************************************************************/
2104                 if (!isnull && OidIsValid(typoutput))
2105                 {
2106                         outputstr = DatumGetCString(OidFunctionCall3(typoutput,
2107                                                                                 attr,
2108                                                                                 ObjectIdGetDatum(typelem),
2109                                                                                 Int32GetDatum(tupdesc->attrs[i]->attlen)));
2110                         Tcl_SetVar2(interp, *arrptr, *nameptr, outputstr, 0);
2111                         pfree(outputstr);
2112                 }
2113                 else
2114                         Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
2115         }
2116 }
2117
2118
2119 #endif
2120 /**********************************************************************
2121  * plperl_build_tuple_argument() - Build a string for a ref to a hash
2122  *                                from all attributes of a given tuple
2123  **********************************************************************/
2124 static SV  *
2125 plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
2126 {
2127         int                     i;
2128         SV                 *output;
2129         Datum           attr;
2130         bool            isnull;
2131
2132         char       *attname;
2133         char       *outputstr;
2134         HeapTuple       typeTup;
2135         Oid                     typoutput;
2136         Oid                     typelem;
2137
2138         output = sv_2mortal(newSVpv("{", 0));
2139
2140         for (i = 0; i < tupdesc->natts; i++)
2141         {
2142                 /************************************************************
2143                  * Get the attribute name
2144                  ************************************************************/
2145                 attname = tupdesc->attrs[i]->attname.data;
2146
2147                 /************************************************************
2148                  * Get the attributes value
2149                  ************************************************************/
2150                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2151
2152                 /************************************************************
2153                  * Lookup the attribute type in the syscache
2154                  * for the output function
2155                  ************************************************************/
2156                 typeTup = SearchSysCacheTuple(TYPEOID,
2157                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
2158                                                                           0, 0, 0);
2159                 if (!HeapTupleIsValid(typeTup))
2160                 {
2161                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
2162                                  attname, tupdesc->attrs[i]->atttypid);
2163                 }
2164
2165                 typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
2166                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
2167
2168                 /************************************************************
2169                  * If there is a value, append the attribute name and the
2170                  * value to the list.
2171                  *      If it is null it will be set to undef.
2172                  ************************************************************/
2173                 if (!isnull && OidIsValid(typoutput))
2174                 {
2175                         outputstr = DatumGetCString(OidFunctionCall3(typoutput,
2176                                                                                 attr,
2177                                                                                 ObjectIdGetDatum(typelem),
2178                                                                                 Int32GetDatum(tupdesc->attrs[i]->attlen)));
2179                         sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
2180                         pfree(outputstr);
2181                 }
2182                 else
2183                         sv_catpvf(output, "'%s' => undef,", attname);
2184         }
2185         sv_catpv(output, "}");
2186         output = perl_eval_pv(SvPV(output, na), TRUE);
2187         return output;
2188 }