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  **********************************************************************/
  36
  37
  38 /* system stuff */
  39 #include <stdio.h>
  40 #include <stdlib.h>
  41 #include <stdarg.h>
  42 #include <unistd.h>
  43 #include <fcntl.h>
  44 #include <string.h>
  45 #include <setjmp.h>
  46
  47 /* postgreSQL stuff */
  48 #include "executor/spi.h"
  49 #include "commands/trigger.h"
  50 #include "utils/elog.h"
  51 #include "fmgr.h"
  52 #include "access/heapam.h"
  53
  54 #include "tcop/tcopprot.h"
  55 #include "utils/syscache.h"
  56 #include "catalog/pg_proc.h"
  57 #include "catalog/pg_type.h"
  58
  59 /* perl stuff */
  60 /*
  61  * Evil Code Alert
  62  *
  63  * both posgreSQL and perl try to do 'the right thing'
  64  * and provide union semun if the platform doesn't define
  65  * it in a system header.
  66  * psql uses HAVE_UNION_SEMUN
  67  * perl uses HAS_UNION_SEMUN
  68  * together, they cause compile errors.
  69  * If we need it, the psql headers above will provide it.
  70  * So we tell perl that we have it.
  71  */
  72 #ifndef HAS_UNION_SEMUN
  73 #define HAS_UNION_SEMUN
  74 #endif
  75 #include <EXTERN.h>
  76 #include <perl.h>
  77
  78
  79 /**********************************************************************
  80  * The information we cache about loaded procedures
  81  **********************************************************************/
  82 typedef struct plperl_proc_desc
  83 {
  84         char       *proname;
  85         FmgrInfo        result_in_func;
  86         Oid                     result_in_elem;
  87         int                     result_in_len;
  88         int                     nargs;
  89         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  90         Oid                     arg_out_elem[FUNC_MAX_ARGS];
  91         int                     arg_out_len[FUNC_MAX_ARGS];
  92         int                     arg_is_rel[FUNC_MAX_ARGS];
  93         SV                 *reference;
  94 }                       plperl_proc_desc;
  95
  96
  97 /**********************************************************************
  98  * The information we cache about prepared and saved plans
  99  **********************************************************************/
 100 typedef struct plperl_query_desc
 101 {
 102         char            qname[20];
 103         void       *plan;
 104         int                     nargs;
 105         Oid                *argtypes;
 106         FmgrInfo   *arginfuncs;
 107         Oid                *argtypelems;
 108         Datum      *argvalues;
 109         int                *arglen;
 110 }                       plperl_query_desc;
 111
 112
 113 /**********************************************************************
 114  * Global data
 115  **********************************************************************/
 116 static int      plperl_firstcall = 1;
 117 static int      plperl_call_level = 0;
 118 static int      plperl_restart_in_progress = 0;
 119 static PerlInterpreter *plperl_safe_interp = NULL;
 120 static HV  *plperl_proc_hash = NULL;
 121
 122 #if REALLYHAVEITONTHEBALL
 123 static Tcl_HashTable *plperl_query_hash = NULL;
 124
 125 #endif
 126
 127 /**********************************************************************
 128  * Forward declarations
 129  **********************************************************************/
 130 static void plperl_init_all(void);
 131 static void plperl_init_safe_interp(void);
 132
 133 Datum plperl_call_handler(FmgrInfo *proinfo,
 134                                         FmgrValues *proargs, bool *isNull);
 135
 136 static Datum plperl_func_handler(FmgrInfo *proinfo,
 137                                         FmgrValues *proargs, bool *isNull);
 138
 139 static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
 140 static void plperl_init_shared_libs(void);
 141
 142 #ifdef REALLYHAVEITONTHEBALL
 143 static HeapTuple plperl_trigger_handler(FmgrInfo *proinfo);
 144
 145 static int plperl_elog(ClientData cdata, Tcl_Interp *interp,
 146                         int argc, char *argv[]);
 147 static int plperl_quote(ClientData cdata, Tcl_Interp *interp,
 148                          int argc, char *argv[]);
 149
 150 static int plperl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
 151                                 int argc, char *argv[]);
 152 static int plperl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
 153                                    int argc, char *argv[]);
 154 static int plperl_SPI_execp(ClientData cdata, Tcl_Interp *interp,
 155                                  int argc, char *argv[]);
 156
 157 static void plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
 158                                                 int tupno, HeapTuple tuple, TupleDesc tupdesc);
 159
 160 #endif
 161
 162
 163 /**********************************************************************
 164  * plperl_init_all()            - Initialize all
 165  **********************************************************************/
 166 static void
 167 plperl_init_all(void)
 168 {
 169
 170         /************************************************************
 171          * Do initialization only once
 172          ************************************************************/
 173         if (!plperl_firstcall)
 174                 return;
 175
 176
 177         /************************************************************
 178          * Destroy the existing safe interpreter
 179          ************************************************************/
 180         if (plperl_safe_interp != NULL)
 181         {
 182                 perl_destruct(plperl_safe_interp);
 183                 perl_free(plperl_safe_interp);
 184                 plperl_safe_interp = NULL;
 185         }
 186
 187         /************************************************************
 188          * Free the proc hash table
 189          ************************************************************/
 190         if (plperl_proc_hash != NULL)
 191         {
 192                 hv_undef(plperl_proc_hash);
 193                 SvREFCNT_dec((SV *) plperl_proc_hash);
 194                 plperl_proc_hash = NULL;
 195         }
 196
 197         /************************************************************
 198          * Free the prepared query hash table
 199          ************************************************************/
 200
 201         /*
 202          * if (plperl_query_hash != NULL) { }
 203          */
 204
 205         /************************************************************
 206          * Now recreate a new safe interpreter
 207          ************************************************************/
 208         plperl_init_safe_interp();
 209
 210         plperl_firstcall = 0;
 211         return;
 212 }
 213
 214
 215 /**********************************************************************
 216  * plperl_init_safe_interp() - Create the safe Perl interpreter
 217  **********************************************************************/
 218 static void
 219 plperl_init_safe_interp(void)
 220 {
 221
 222         char       *embedding[] = {"", "-e", "use DynaLoader; require Safe; SPI::bootstrap()", "0"};
 223
 224         plperl_safe_interp = perl_alloc();
 225         if (!plperl_safe_interp)
 226                 elog(ERROR, "plperl_init_safe_interp(): could not allocate perl interpreter");
 227
 228         perl_construct(plperl_safe_interp);
 229         perl_parse(plperl_safe_interp, plperl_init_shared_libs, 3, embedding, NULL);
 230         perl_run(plperl_safe_interp);
 231
 232
 233
 234         /************************************************************
 235          * Initialize the proc and query hash tables
 236          ************************* ***********************************/
 237         plperl_proc_hash = newHV();
 238
 239 }
 240
 241
 242
 243 /**********************************************************************
 244  * plperl_call_handler          - This is the only visible function
 245  *                                of the PL interpreter. The PostgreSQL
 246  *                                function manager and trigger manager
 247  *                                call this function for execution of
 248  *                                perl procedures.
 249  **********************************************************************/
 250
 251 /* keep non-static */
 252 Datum
 253 plperl_call_handler(FmgrInfo *proinfo,
 254                                         FmgrValues *proargs,
 255                                         bool *isNull)
 256 {
 257         Datum           retval;
 258
 259         /************************************************************
 260          * Initialize interpreters on first call
 261          ************************************************************/
 262         if (plperl_firstcall)
 263                 plperl_init_all();
 264
 265         /************************************************************
 266          * Connect to SPI manager
 267          ************************************************************/
 268         if (SPI_connect() != SPI_OK_CONNECT)
 269                 elog(ERROR, "plperl: cannot connect to SPI manager");
 270         /************************************************************
 271          * Keep track about the nesting of Tcl-SPI-Tcl-... calls
 272          ************************************************************/
 273         plperl_call_level++;
 274
 275         /************************************************************
 276          * Determine if called as function or trigger and
 277          * call appropriate subhandler
 278          ************************************************************/
 279         if (CurrentTriggerData == NULL)
 280                 retval = plperl_func_handler(proinfo, proargs, isNull);
 281         else
 282         {
 283                 elog(ERROR, "plperl: can't use perl in triggers yet.");
 284
 285                 /*
 286                  * retval = (Datum) plperl_trigger_handler(proinfo);
 287                  */
 288                 /* make the compiler happy */
 289                 retval = (Datum) 0;
 290         }
 291
 292         plperl_call_level--;
 293
 294         return retval;
 295 }
 296
 297
 298 /**********************************************************************
 299  * plperl_create_sub()          - calls the perl interpreter to
 300  *              create the anonymous subroutine whose text is in the SV.
 301  *              Returns the SV containing the RV to the closure.
 302  **********************************************************************/
 303 static
 304 SV *
 305 plperl_create_sub(SV * s)
 306 {
 307         dSP;
 308
 309         SV                 *subref = NULL;
 310
 311         ENTER;
 312         SAVETMPS;
 313         PUSHMARK(SP);
 314         perl_eval_sv(s, G_SCALAR | G_EVAL | G_KEEPERR);
 315         SPAGAIN;
 316
 317         if (SvTRUE(GvSV(errgv)))
 318         {
 319                 POPs;
 320                 PUTBACK;
 321                 FREETMPS;
 322                 LEAVE;
 323                 elog(ERROR, "creation of function failed : %s", SvPV(GvSV(errgv), na));
 324         }
 325
 326         /*
 327          * need to make a deep copy of the return. it comes off the stack as a
 328          * temporary.
 329          */
 330         subref = newSVsv(POPs);
 331
 332         if (!SvROK(subref))
 333         {
 334                 PUTBACK;
 335                 FREETMPS;
 336                 LEAVE;
 337
 338                 /*
 339                  * subref is our responsibility because it is not mortal
 340                  */
 341                 SvREFCNT_dec(subref);
 342                 elog(ERROR, "plperl_create_sub: didn't get a code ref");
 343         }
 344
 345         PUTBACK;
 346         FREETMPS;
 347         LEAVE;
 348         return subref;
 349 }
 350
 351 /**********************************************************************
 352  * plperl_init_shared_libs()            -
 353  *
 354  * We cannot use the DynaLoader directly to get at the Opcode
 355  * module (used by Safe.pm). So, we link Opcode into ourselves
 356  * and do the initialization behind perl's back.
 357  *
 358  **********************************************************************/
 359
 360 extern void boot_DynaLoader _((CV * cv));
 361 extern void boot_Opcode _((CV * cv));
 362 extern void boot_SPI _((CV * cv));
 363
 364 static void
 365 plperl_init_shared_libs(void)
 366 {
 367         char       *file = __FILE__;
 368
 369         newXS("DynaLoader::bootstrap", boot_DynaLoader, file);
 370         newXS("Opcode::bootstrap", boot_Opcode, file);
 371         newXS("SPI::bootstrap", boot_SPI, file);
 372 }
 373
 374 /**********************************************************************
 375  * plperl_call_perl_func()              - calls a perl function through the RV
 376  *                      stored in the prodesc structure. massages the input parms properly
 377  **********************************************************************/
 378 static
 379 SV *
 380 plperl_call_perl_func(plperl_proc_desc * desc, FmgrValues *pargs)
 381 {
 382         dSP;
 383
 384         SV                 *retval;
 385         int                     i;
 386         int                     count;
 387
 388
 389         ENTER;
 390         SAVETMPS;
 391
 392         PUSHMARK(sp);
 393         for (i = 0; i < desc->nargs; i++)
 394         {
 395                 if (desc->arg_is_rel[i])
 396                 {
 397
 398                         /*
 399                          * plperl_build_tuple_argument better return a mortal SV.
 400                          */
 401                         SV                 *hashref = plperl_build_tuple_argument(
 402                                                           ((TupleTableSlot *) (pargs->data[i]))->val,
 403                          ((TupleTableSlot *) (pargs->data[i]))->ttc_tupleDescriptor);
 404
 405                         XPUSHs(hashref);
 406                 }
 407                 else
 408                 {
 409                         char       *tmp = (*fmgr_faddr(&(desc->arg_out_func[i])))
 410                         (pargs->data[i],
 411                          desc->arg_out_elem[i],
 412                          desc->arg_out_len[i]);
 413
 414                         XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
 415                         pfree(tmp);
 416                 }
 417         }
 418         PUTBACK;
 419         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
 420
 421         SPAGAIN;
 422
 423         if (count != 1)
 424         {
 425                 PUTBACK;
 426                 FREETMPS;
 427                 LEAVE;
 428                 elog(ERROR, "plperl : didn't get a return item from function");
 429         }
 430
 431         if (SvTRUE(GvSV(errgv)))
 432         {
 433                 POPs;
 434                 PUTBACK;
 435                 FREETMPS;
 436                 LEAVE;
 437                 elog(ERROR, "plperl : error from function : %s", SvPV(GvSV(errgv), na));
 438         }
 439
 440         retval = newSVsv(POPs);
 441
 442
 443         PUTBACK;
 444         FREETMPS;
 445         LEAVE;
 446
 447         return retval;
 448
 449
 450 }
 451
 452 /**********************************************************************
 453  * plperl_func_handler()                - Handler for regular function calls
 454  **********************************************************************/
 455 static Datum
 456 plperl_func_handler(FmgrInfo *proinfo,
 457                                         FmgrValues *proargs,
 458                                         bool *isNull)
 459 {
 460         int                     i;
 461         char            internal_proname[512];
 462         int                     proname_len;
 463         char       *stroid;
 464         plperl_proc_desc *prodesc;
 465         SV                 *perlret;
 466         Datum           retval;
 467         sigjmp_buf      save_restart;
 468
 469         /************************************************************
 470          * Build our internal proc name from the functions Oid
 471          ************************************************************/
 472         stroid = oidout(proinfo->fn_oid);
 473         strcpy(internal_proname, "__PLperl_proc_");
 474         strcat(internal_proname, stroid);
 475         pfree(stroid);
 476         proname_len = strlen(internal_proname);
 477
 478         /************************************************************
 479          * Lookup the internal proc name in the hashtable
 480          ************************************************************/
 481         if (!hv_exists(plperl_proc_hash, internal_proname, proname_len))
 482         {
 483                 /************************************************************
 484                  * If we haven't found it in the hashtable, we analyze
 485                  * the functions arguments and returntype and store
 486                  * the in-/out-functions in the prodesc block and create
 487                  * a new hashtable entry for it.
 488                  *
 489                  * Then we load the procedure into the safe interpreter.
 490                  ************************************************************/
 491                 HeapTuple       procTup;
 492                 HeapTuple       typeTup;
 493                 Form_pg_proc procStruct;
 494                 Form_pg_type typeStruct;
 495                 SV                 *proc_internal_def;
 496                 char            proc_internal_args[4096];
 497                 char       *proc_source;
 498
 499                 /************************************************************
 500                  * Allocate a new procedure description block
 501                  ************************************************************/
 502                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
 503                 prodesc->proname = malloc(strlen(internal_proname) + 1);
 504                 strcpy(prodesc->proname, internal_proname);
 505
 506                 /************************************************************
 507                  * Lookup the pg_proc tuple by Oid
 508                  ************************************************************/
 509                 procTup = SearchSysCacheTuple(PROCOID,
 510                                                                           ObjectIdGetDatum(proinfo->fn_oid),
 511                                                                           0, 0, 0);
 512                 if (!HeapTupleIsValid(procTup))
 513                 {
 514                         free(prodesc->proname);
 515                         free(prodesc);
 516                         elog(ERROR, "plperl: cache lookup for proc %u failed",
 517                                  proinfo->fn_oid);
 518                 }
 519                 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
 520
 521                 /************************************************************
 522                  * Get the required information for input conversion of the
 523                  * return value.
 524                  ************************************************************/
 525                 typeTup = SearchSysCacheTuple(TYPEOID,
 526                                                                 ObjectIdGetDatum(procStruct->prorettype),
 527                                                                           0, 0, 0);
 528                 if (!HeapTupleIsValid(typeTup))
 529                 {
 530                         free(prodesc->proname);
 531                         free(prodesc);
 532                         elog(ERROR, "plperl: cache lookup for return type %u failed",
 533                                  procStruct->prorettype);
 534                 }
 535                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 536
 537                 if (typeStruct->typrelid != InvalidOid)
 538                 {
 539                         free(prodesc->proname);
 540                         free(prodesc);
 541                         elog(ERROR, "plperl: return types of tuples not supported yet");
 542                 }
 543
 544                 fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
 545                 prodesc->result_in_elem = (Oid) (typeStruct->typelem);
 546                 prodesc->result_in_len = typeStruct->typlen;
 547
 548                 /************************************************************
 549                  * Get the required information for output conversion
 550                  * of all procedure arguments
 551                  ************************************************************/
 552                 prodesc->nargs = proinfo->fn_nargs;
 553                 proc_internal_args[0] = '\0';
 554                 for (i = 0; i < proinfo->fn_nargs; i++)
 555                 {
 556                         typeTup = SearchSysCacheTuple(TYPEOID,
 557                                                         ObjectIdGetDatum(procStruct->proargtypes[i]),
 558                                                                                   0, 0, 0);
 559                         if (!HeapTupleIsValid(typeTup))
 560                         {
 561                                 free(prodesc->proname);
 562                                 free(prodesc);
 563                                 elog(ERROR, "plperl: cache lookup for argument type %u failed",
 564                                          procStruct->proargtypes[i]);
 565                         }
 566                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 567
 568                         if (typeStruct->typrelid != InvalidOid)
 569                                 prodesc->arg_is_rel[i] = 1;
 570                         else
 571                                 prodesc->arg_is_rel[i] = 0;
 572
 573                         fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
 574                         prodesc->arg_out_elem[i] = (Oid) (typeStruct->typelem);
 575                         prodesc->arg_out_len[i] = typeStruct->typlen;
 576
 577                 }
 578
 579                 /************************************************************
 580                  * create the text of the anonymous subroutine.
 581                  * we do not use a named subroutine so that we can call directly
 582                  * through the reference.
 583                  *
 584                  ************************************************************/
 585                 proc_source = textout(&(procStruct->prosrc));
 586
 587                 /*
 588                  * the string has been split for readbility. please don't put
 589                  * commas between them. Hope everyone is ANSI
 590                  */
 591                 proc_internal_def = newSVpvf(
 592                                                                          "$::x = new Safe;"
 593                                                                          "$::x->permit_only(':default');"
 594                                    "$::x->share(qw[&elog &DEBUG &NOTICE &NOIND &ERROR]);"
 595                                                                          "use strict;"
 596                                    "return $::x->reval( q[ sub { %s } ]);", proc_source);
 597
 598                 pfree(proc_source);
 599
 600                 /************************************************************
 601                  * Create the procedure in the interpreter
 602                  ************************************************************/
 603                 prodesc->reference = plperl_create_sub(proc_internal_def);
 604                 if (!prodesc->reference)
 605                 {
 606                         free(prodesc->proname);
 607                         free(prodesc);
 608                         elog(ERROR, "plperl: cannot create internal procedure %s",
 609                                  internal_proname);
 610                 }
 611
 612                 /************************************************************
 613                  * Add the proc description block to the hashtable
 614                  ************************************************************/
 615                 hv_store(plperl_proc_hash, internal_proname, proname_len,
 616                                  newSViv((IV) prodesc), 0);
 617         }
 618         else
 619         {
 620                 /************************************************************
 621                  * Found the proc description block in the hashtable
 622                  ************************************************************/
 623                 prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
 624                                                                           internal_proname, proname_len, 0));
 625         }
 626
 627
 628         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
 629
 630         if (sigsetjmp(Warn_restart, 1) != 0)
 631         {
 632                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 633                 plperl_restart_in_progress = 1;
 634                 if (--plperl_call_level == 0)
 635                         plperl_restart_in_progress = 0;
 636                 siglongjmp(Warn_restart, 1);
 637         }
 638
 639
 640         /************************************************************
 641          * Call the Perl function
 642          ************************************************************/
 643         perlret = plperl_call_perl_func(prodesc, proargs);
 644
 645         /************************************************************
 646          * Disconnect from SPI manager and then create the return
 647          * values datum (if the input function does a palloc for it
 648          * this must not be allocated in the SPI memory context
 649          * because SPI_finish would free it).
 650          ************************************************************/
 651         if (SPI_finish() != SPI_OK_FINISH)
 652                 elog(ERROR, "plperl: SPI_finish() failed");
 653
 654         retval = (Datum) (*fmgr_faddr(&prodesc->result_in_func))
 655                 (SvPV(perlret, na),
 656                  prodesc->result_in_elem,
 657                  prodesc->result_in_len);
 658
 659         SvREFCNT_dec(perlret);
 660
 661         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 662         if (plperl_restart_in_progress)
 663         {
 664                 if (--plperl_call_level == 0)
 665                         plperl_restart_in_progress = 0;
 666                 siglongjmp(Warn_restart, 1);
 667         }
 668
 669         return retval;
 670 }
 671
 672
 673 #ifdef REALLYHAVEITONTHEBALL
 674 /**********************************************************************
 675  * plperl_trigger_handler() - Handler for trigger calls
 676  **********************************************************************/
 677 static HeapTuple
 678 plperl_trigger_handler(FmgrInfo *proinfo)
 679 {
 680         TriggerData *trigdata;
 681         char            internal_proname[512];
 682         char       *stroid;
 683         Tcl_HashEntry *hashent;
 684         int                     hashnew;
 685         plperl_proc_desc *prodesc;
 686         TupleDesc       tupdesc;
 687         HeapTuple       rettup;
 688         Tcl_DString tcl_cmd;
 689         Tcl_DString tcl_trigtup;
 690         Tcl_DString tcl_newtup;
 691         int                     tcl_rc;
 692         int                     i;
 693
 694         int                *modattrs;
 695         Datum      *modvalues;
 696         char       *modnulls;
 697
 698         int                     ret_numvals;
 699         char      **ret_values;
 700
 701         sigjmp_buf      save_restart;
 702
 703         /************************************************************
 704          * Save the current trigger data local
 705          ************************************************************/
 706         trigdata = CurrentTriggerData;
 707         CurrentTriggerData = NULL;
 708
 709         /************************************************************
 710          * Build our internal proc name from the functions Oid
 711          ************************************************************/
 712         stroid = oidout(proinfo->fn_oid);
 713         strcpy(internal_proname, "__PLTcl_proc_");
 714         strcat(internal_proname, stroid);
 715         pfree(stroid);
 716
 717         /************************************************************
 718          * Lookup the internal proc name in the hashtable
 719          ************************************************************/
 720         hashent = Tcl_FindHashEntry(plperl_proc_hash, internal_proname);
 721         if (hashent == NULL)
 722         {
 723                 /************************************************************
 724                  * If we haven't found it in the hashtable,
 725                  * we load the procedure into the safe interpreter.
 726                  ************************************************************/
 727                 Tcl_DString proc_internal_def;
 728                 Tcl_DString proc_internal_body;
 729                 HeapTuple       procTup;
 730                 Form_pg_proc procStruct;
 731                 char       *proc_source;
 732
 733                 /************************************************************
 734                  * Allocate a new procedure description block
 735                  ************************************************************/
 736                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
 737                 memset(prodesc, 0, sizeof(plperl_proc_desc));
 738                 prodesc->proname = malloc(strlen(internal_proname) + 1);
 739                 strcpy(prodesc->proname, internal_proname);
 740
 741                 /************************************************************
 742                  * Lookup the pg_proc tuple by Oid
 743                  ************************************************************/
 744                 procTup = SearchSysCacheTuple(PROCOID,
 745                                                                           ObjectIdGetDatum(proinfo->fn_oid),
 746                                                                           0, 0, 0);
 747                 if (!HeapTupleIsValid(procTup))
 748                 {
 749                         free(prodesc->proname);
 750                         free(prodesc);
 751                         elog(ERROR, "plperl: cache lookup for proc %u failed",
 752                                  proinfo->fn_oid);
 753                 }
 754                 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
 755
 756                 /************************************************************
 757                  * Create the tcl command to define the internal
 758                  * procedure
 759                  ************************************************************/
 760                 Tcl_DStringInit(&proc_internal_def);
 761                 Tcl_DStringInit(&proc_internal_body);
 762                 Tcl_DStringAppendElement(&proc_internal_def, "proc");
 763                 Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
 764                 Tcl_DStringAppendElement(&proc_internal_def,
 765                                                                  "TG_name TG_relid TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
 766
 767                 /************************************************************
 768                  * prefix procedure body with
 769                  * upvar #0 <internal_procname> GD
 770                  * and with appropriate setting of NEW, OLD,
 771                  * and the arguments as numerical variables.
 772                  ************************************************************/
 773                 Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
 774                 Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
 775                 Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
 776
 777                 Tcl_DStringAppend(&proc_internal_body,
 778                                                   "array set NEW $__PLTcl_Tup_NEW\n", -1);
 779                 Tcl_DStringAppend(&proc_internal_body,
 780                                                   "array set OLD $__PLTcl_Tup_OLD\n", -1);
 781
 782                 Tcl_DStringAppend(&proc_internal_body,
 783                                                   "set i 0\n"
 784                                                   "set v 0\n"
 785                                                   "foreach v $args {\n"
 786                                                   "  incr i\n"
 787                                                   "  set $i $v\n"
 788                                                   "}\n"
 789                                                   "unset i v\n\n", -1);
 790
 791                 proc_source = textout(&(procStruct->prosrc));
 792                 Tcl_DStringAppend(&proc_internal_body, proc_source, -1);
 793                 pfree(proc_source);
 794                 Tcl_DStringAppendElement(&proc_internal_def,
 795                                                                  Tcl_DStringValue(&proc_internal_body));
 796                 Tcl_DStringFree(&proc_internal_body);
 797
 798                 /************************************************************
 799                  * Create the procedure in the safe interpreter
 800                  ************************************************************/
 801                 tcl_rc = Tcl_GlobalEval(plperl_safe_interp,
 802                                                                 Tcl_DStringValue(&proc_internal_def));
 803                 Tcl_DStringFree(&proc_internal_def);
 804                 if (tcl_rc != TCL_OK)
 805                 {
 806                         free(prodesc->proname);
 807                         free(prodesc);
 808                         elog(ERROR, "plperl: cannot create internal procedure %s - %s",
 809                                  internal_proname, plperl_safe_interp->result);
 810                 }
 811
 812                 /************************************************************
 813                  * Add the proc description block to the hashtable
 814                  ************************************************************/
 815                 hashent = Tcl_CreateHashEntry(plperl_proc_hash,
 816                                                                           prodesc->proname, &hashnew);
 817                 Tcl_SetHashValue(hashent, (ClientData) prodesc);
 818         }
 819         else
 820         {
 821                 /************************************************************
 822                  * Found the proc description block in the hashtable
 823                  ************************************************************/
 824                 prodesc = (plperl_proc_desc *) Tcl_GetHashValue(hashent);
 825         }
 826
 827         tupdesc = trigdata->tg_relation->rd_att;
 828
 829         /************************************************************
 830          * Create the tcl command to call the internal
 831          * proc in the safe interpreter
 832          ************************************************************/
 833         Tcl_DStringInit(&tcl_cmd);
 834         Tcl_DStringInit(&tcl_trigtup);
 835         Tcl_DStringInit(&tcl_newtup);
 836
 837         /************************************************************
 838          * We call external functions below - care for elog(ERROR)
 839          ************************************************************/
 840         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
 841         if (sigsetjmp(Warn_restart, 1) != 0)
 842         {
 843                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 844                 Tcl_DStringFree(&tcl_cmd);
 845                 Tcl_DStringFree(&tcl_trigtup);
 846                 Tcl_DStringFree(&tcl_newtup);
 847                 plperl_restart_in_progress = 1;
 848                 if (--plperl_call_level == 0)
 849                         plperl_restart_in_progress = 0;
 850                 siglongjmp(Warn_restart, 1);
 851         }
 852
 853         /* The procedure name */
 854         Tcl_DStringAppendElement(&tcl_cmd, internal_proname);
 855
 856         /* The trigger name for argument TG_name */
 857         Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgname);
 858
 859         /* The oid of the trigger relation for argument TG_relid */
 860         stroid = oidout(trigdata->tg_relation->rd_id);
 861         Tcl_DStringAppendElement(&tcl_cmd, stroid);
 862         pfree(stroid);
 863
 864         /* A list of attribute names for argument TG_relatts */
 865         Tcl_DStringAppendElement(&tcl_trigtup, "");
 866         for (i = 0; i < tupdesc->natts; i++)
 867                 Tcl_DStringAppendElement(&tcl_trigtup, tupdesc->attrs[i]->attname.data);
 868         Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 869         Tcl_DStringFree(&tcl_trigtup);
 870         Tcl_DStringInit(&tcl_trigtup);
 871
 872         /* The when part of the event for TG_when */
 873         if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
 874                 Tcl_DStringAppendElement(&tcl_cmd, "BEFORE");
 875         else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
 876                 Tcl_DStringAppendElement(&tcl_cmd, "AFTER");
 877         else
 878                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 879
 880         /* The level part of the event for TG_level */
 881         if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
 882                 Tcl_DStringAppendElement(&tcl_cmd, "ROW");
 883         else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
 884                 Tcl_DStringAppendElement(&tcl_cmd, "STATEMENT");
 885         else
 886                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 887
 888         /* Build the data list for the trigtuple */
 889         plperl_build_tuple_argument(trigdata->tg_trigtuple,
 890                                                                 tupdesc, &tcl_trigtup);
 891
 892         /*
 893          * Now the command part of the event for TG_op and data for NEW and
 894          * OLD
 895          */
 896         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
 897         {
 898                 Tcl_DStringAppendElement(&tcl_cmd, "INSERT");
 899
 900                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 901                 Tcl_DStringAppendElement(&tcl_cmd, "");
 902
 903                 rettup = trigdata->tg_trigtuple;
 904         }
 905         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
 906         {
 907                 Tcl_DStringAppendElement(&tcl_cmd, "DELETE");
 908
 909                 Tcl_DStringAppendElement(&tcl_cmd, "");
 910                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 911
 912                 rettup = trigdata->tg_trigtuple;
 913         }
 914         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
 915         {
 916                 Tcl_DStringAppendElement(&tcl_cmd, "UPDATE");
 917
 918                 plperl_build_tuple_argument(trigdata->tg_newtuple,
 919                                                                         tupdesc, &tcl_newtup);
 920
 921                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_newtup));
 922                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 923
 924                 rettup = trigdata->tg_newtuple;
 925         }
 926         else
 927         {
 928                 Tcl_DStringAppendElement(&tcl_cmd, "UNKNOWN");
 929
 930                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 931                 Tcl_DStringAppendElement(&tcl_cmd, Tcl_DStringValue(&tcl_trigtup));
 932
 933                 rettup = trigdata->tg_trigtuple;
 934         }
 935
 936         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
 937         Tcl_DStringFree(&tcl_trigtup);
 938         Tcl_DStringFree(&tcl_newtup);
 939
 940         /************************************************************
 941          * Finally append the arguments from CREATE TRIGGER
 942          ************************************************************/
 943         for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
 944                 Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgargs[i]);
 945
 946         /************************************************************
 947          * Call the Tcl function
 948          ************************************************************/
 949         tcl_rc = Tcl_GlobalEval(plperl_safe_interp, Tcl_DStringValue(&tcl_cmd));
 950         Tcl_DStringFree(&tcl_cmd);
 951
 952         /************************************************************
 953          * Check the return code from Tcl and handle
 954          * our special restart mechanism to get rid
 955          * of all nested call levels on transaction
 956          * abort.
 957          ************************************************************/
 958         if (tcl_rc == TCL_ERROR || plperl_restart_in_progress)
 959         {
 960                 if (!plperl_restart_in_progress)
 961                 {
 962                         plperl_restart_in_progress = 1;
 963                         if (--plperl_call_level == 0)
 964                                 plperl_restart_in_progress = 0;
 965                         elog(ERROR, "plperl: %s", plperl_safe_interp->result);
 966                 }
 967                 if (--plperl_call_level == 0)
 968                         plperl_restart_in_progress = 0;
 969                 siglongjmp(Warn_restart, 1);
 970         }
 971
 972         switch (tcl_rc)
 973         {
 974                 case TCL_OK:
 975                         break;
 976
 977                 default:
 978                         elog(ERROR, "plperl: unsupported TCL return code %d", tcl_rc);
 979         }
 980
 981         /************************************************************
 982          * The return value from the procedure might be one of
 983          * the magic strings OK or SKIP or a list from array get
 984          ************************************************************/
 985         if (SPI_finish() != SPI_OK_FINISH)
 986                 elog(ERROR, "plperl: SPI_finish() failed");
 987
 988         if (strcmp(plperl_safe_interp->result, "OK") == 0)
 989                 return rettup;
 990         if (strcmp(plperl_safe_interp->result, "SKIP") == 0)
 991         {
 992                 return (HeapTuple) NULL;;
 993         }
 994
 995         /************************************************************
 996          * Convert the result value from the safe interpreter
 997          * and setup structures for SPI_modifytuple();
 998          ************************************************************/
 999         if (Tcl_SplitList(plperl_safe_interp, plperl_safe_interp->result,
1000                                           &ret_numvals, &ret_values) != TCL_OK)
1001         {
1002                 elog(NOTICE, "plperl: cannot split return value from trigger");
1003                 elog(ERROR, "plperl: %s", plperl_safe_interp->result);
1004         }
1005
1006         if (ret_numvals % 2 != 0)
1007         {
1008                 ckfree(ret_values);
1009                 elog(ERROR, "plperl: invalid return list from trigger - must have even # of elements");
1010         }
1011
1012         modattrs = (int *) palloc(tupdesc->natts * sizeof(int));
1013         modvalues = (Datum *) palloc(tupdesc->natts * sizeof(Datum));
1014         for (i = 0; i < tupdesc->natts; i++)
1015         {
1016                 modattrs[i] = i + 1;
1017                 modvalues[i] = (Datum) NULL;
1018         }
1019
1020         modnulls = palloc(tupdesc->natts + 1);
1021         memset(modnulls, 'n', tupdesc->natts);
1022         modnulls[tupdesc->natts] = '\0';
1023
1024         /************************************************************
1025          * Care for possible elog(ERROR)'s below
1026          ************************************************************/
1027         if (sigsetjmp(Warn_restart, 1) != 0)
1028         {
1029                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1030                 ckfree(ret_values);
1031                 plperl_restart_in_progress = 1;
1032                 if (--plperl_call_level == 0)
1033                         plperl_restart_in_progress = 0;
1034                 siglongjmp(Warn_restart, 1);
1035         }
1036
1037         i = 0;
1038         while (i < ret_numvals)
1039         {
1040                 int                     attnum;
1041                 HeapTuple       typeTup;
1042                 Oid                     typinput;
1043                 Oid                     typelem;
1044                 FmgrInfo        finfo;
1045
1046                 /************************************************************
1047                  * Ignore pseudo elements with a dot name
1048                  ************************************************************/
1049                 if (*(ret_values[i]) == '.')
1050                 {
1051                         i += 2;
1052                         continue;
1053                 }
1054
1055                 /************************************************************
1056                  * Get the attribute number
1057                  ************************************************************/
1058                 attnum = SPI_fnumber(tupdesc, ret_values[i++]);
1059                 if (attnum == SPI_ERROR_NOATTRIBUTE)
1060                         elog(ERROR, "plperl: invalid attribute '%s'", ret_values[--i]);
1061
1062                 /************************************************************
1063                  * Lookup the attribute type in the syscache
1064                  * for the input function
1065                  ************************************************************/
1066                 typeTup = SearchSysCacheTuple(TYPEOID,
1067                                   ObjectIdGetDatum(tupdesc->attrs[attnum - 1]->atttypid),
1068                                                                           0, 0, 0);
1069                 if (!HeapTupleIsValid(typeTup))
1070                 {
1071                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
1072                                  ret_values[--i],
1073                                  tupdesc->attrs[attnum - 1]->atttypid);
1074                 }
1075                 typinput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typinput);
1076                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
1077
1078                 /************************************************************
1079                  * Set the attribute to NOT NULL and convert the contents
1080                  ************************************************************/
1081                 modnulls[attnum - 1] = ' ';
1082                 fmgr_info(typinput, &finfo);
1083                 modvalues[attnum - 1] = (Datum) (*fmgr_faddr(&finfo))
1084                         (ret_values[i++],
1085                          typelem,
1086                          (!VARLENA_FIXED_SIZE(tupdesc->attrs[attnum - 1]))
1087                          ? tupdesc->attrs[attnum - 1]->attlen
1088                          : tupdesc->attrs[attnum - 1]->atttypmod
1089                         );
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] = (Datum) (*fmgr_faddr(&qdesc->arginfuncs[j]))
1828                                 (callargs[j],
1829                                  qdesc->argtypelems[j],
1830                                  qdesc->arglen[j]);
1831                 }
1832
1833                 /************************************************************
1834                  * Free the splitted argument value list
1835                  ************************************************************/
1836                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1837                 ckfree(callargs);
1838                 callargs = NULL;
1839         }
1840         else
1841                 callnargs = 0;
1842
1843         /************************************************************
1844          * Remember the index of the last processed call
1845          * argument - a loop body for SELECT might follow
1846          ************************************************************/
1847         loop_body = i;
1848
1849         /************************************************************
1850          * Prepare to start a controlled return through all
1851          * interpreter levels on transaction abort
1852          ************************************************************/
1853         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1854         if (sigsetjmp(Warn_restart, 1) != 0)
1855         {
1856                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1857                 for (j = 0; j < callnargs; j++)
1858                 {
1859                         if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
1860                         {
1861                                 pfree((char *) (qdesc->argvalues[j]));
1862                                 qdesc->argvalues[j] = (Datum) NULL;
1863                         }
1864                 }
1865                 plperl_restart_in_progress = 1;
1866                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1867                 return TCL_ERROR;
1868         }
1869
1870         /************************************************************
1871          * Execute the plan
1872          ************************************************************/
1873         spi_rc = SPI_execp(qdesc->plan, qdesc->argvalues, nulls, count);
1874         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1875
1876         /************************************************************
1877          * For varlena data types, free the argument values
1878          ************************************************************/
1879         for (j = 0; j < callnargs; j++)
1880         {
1881                 if (qdesc->arglen[j] < 0 && qdesc->argvalues[j] != (Datum) NULL)
1882                 {
1883                         pfree((char *) (qdesc->argvalues[j]));
1884                         qdesc->argvalues[j] = (Datum) NULL;
1885                 }
1886         }
1887
1888         /************************************************************
1889          * Check the return code from SPI_execp()
1890          ************************************************************/
1891         switch (spi_rc)
1892         {
1893                 case SPI_OK_UTILITY:
1894                         Tcl_SetResult(interp, "0", TCL_VOLATILE);
1895                         return TCL_OK;
1896
1897                 case SPI_OK_SELINTO:
1898                 case SPI_OK_INSERT:
1899                 case SPI_OK_DELETE:
1900                 case SPI_OK_UPDATE:
1901                         sprintf(buf, "%d", SPI_processed);
1902                         Tcl_SetResult(interp, buf, TCL_VOLATILE);
1903                         return TCL_OK;
1904
1905                 case SPI_OK_SELECT:
1906                         break;
1907
1908                 case SPI_ERROR_ARGUMENT:
1909                         Tcl_SetResult(interp,
1910                                                 "plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
1911                                                   TCL_VOLATILE);
1912                         return TCL_ERROR;
1913
1914                 case SPI_ERROR_UNCONNECTED:
1915                         Tcl_SetResult(interp,
1916                                          "plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
1917                                                   TCL_VOLATILE);
1918                         return TCL_ERROR;
1919
1920                 case SPI_ERROR_COPY:
1921                         Tcl_SetResult(interp,
1922                                                   "plperl: SPI_exec() failed - SPI_ERROR_COPY",
1923                                                   TCL_VOLATILE);
1924                         return TCL_ERROR;
1925
1926                 case SPI_ERROR_CURSOR:
1927                         Tcl_SetResult(interp,
1928                                                   "plperl: SPI_exec() failed - SPI_ERROR_CURSOR",
1929                                                   TCL_VOLATILE);
1930                         return TCL_ERROR;
1931
1932                 case SPI_ERROR_TRANSACTION:
1933                         Tcl_SetResult(interp,
1934                                          "plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
1935                                                   TCL_VOLATILE);
1936                         return TCL_ERROR;
1937
1938                 case SPI_ERROR_OPUNKNOWN:
1939                         Tcl_SetResult(interp,
1940                                            "plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN",
1941                                                   TCL_VOLATILE);
1942                         return TCL_ERROR;
1943
1944                 default:
1945                         sprintf(buf, "%d", spi_rc);
1946                         Tcl_AppendResult(interp, "plperl: SPI_exec() failed - ",
1947                                                          "unknown RC ", buf, NULL);
1948                         return TCL_ERROR;
1949         }
1950
1951         /************************************************************
1952          * Only SELECT queries fall through to here - remember the
1953          * tuples we got
1954          ************************************************************/
1955
1956         ntuples = SPI_processed;
1957         if (ntuples > 0)
1958         {
1959                 tuples = SPI_tuptable->vals;
1960                 tupdesc = SPI_tuptable->tupdesc;
1961         }
1962
1963         /************************************************************
1964          * Prepare to start a controlled return through all
1965          * interpreter levels on transaction abort during
1966          * the ouput conversions of the results
1967          ************************************************************/
1968         memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
1969         if (sigsetjmp(Warn_restart, 1) != 0)
1970         {
1971                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1972                 plperl_restart_in_progress = 1;
1973                 Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
1974                 return TCL_ERROR;
1975         }
1976
1977         /************************************************************
1978          * If there is no loop body given, just set the variables
1979          * from the first tuple (if any) and return the number of
1980          * tuples selected
1981          ************************************************************/
1982         if (loop_body >= argc)
1983         {
1984                 if (ntuples > 0)
1985                         plperl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc);
1986                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
1987                 sprintf(buf, "%d", ntuples);
1988                 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1989                 return TCL_OK;
1990         }
1991
1992         /************************************************************
1993          * There is a loop body - process all tuples and evaluate
1994          * the body on each
1995          ************************************************************/
1996         for (i = 0; i < ntuples; i++)
1997         {
1998                 plperl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc);
1999
2000                 loop_rc = Tcl_Eval(interp, argv[loop_body]);
2001
2002                 if (loop_rc == TCL_OK)
2003                         continue;
2004                 if (loop_rc == TCL_CONTINUE)
2005                         continue;
2006                 if (loop_rc == TCL_RETURN)
2007                 {
2008                         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2009                         return TCL_RETURN;
2010                 }
2011                 if (loop_rc == TCL_BREAK)
2012                         break;
2013                 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2014                 return TCL_ERROR;
2015         }
2016
2017         /************************************************************
2018          * Finally return the number of tuples
2019          ************************************************************/
2020         memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
2021         sprintf(buf, "%d", ntuples);
2022         Tcl_SetResult(interp, buf, TCL_VOLATILE);
2023         return TCL_OK;
2024 }
2025
2026
2027 /**********************************************************************
2028  * plperl_set_tuple_values() - Set variables for all attributes
2029  *                                of a given tuple
2030  **********************************************************************/
2031 static void
2032 plperl_set_tuple_values(Tcl_Interp *interp, char *arrayname,
2033                                                 int tupno, HeapTuple tuple, TupleDesc tupdesc)
2034 {
2035         int                     i;
2036         char       *outputstr;
2037         char            buf[64];
2038         Datum           attr;
2039         bool            isnull;
2040
2041         char       *attname;
2042         HeapTuple       typeTup;
2043         Oid                     typoutput;
2044         Oid                     typelem;
2045
2046         char      **arrptr;
2047         char      **nameptr;
2048         char       *nullname = NULL;
2049
2050         /************************************************************
2051          * Prepare pointers for Tcl_SetVar2() below and in array
2052          * mode set the .tupno element
2053          ************************************************************/
2054         if (arrayname == NULL)
2055         {
2056                 arrptr = &attname;
2057                 nameptr = &nullname;
2058         }
2059         else
2060         {
2061                 arrptr = &arrayname;
2062                 nameptr = &attname;
2063                 sprintf(buf, "%d", tupno);
2064                 Tcl_SetVar2(interp, arrayname, ".tupno", buf, 0);
2065         }
2066
2067         for (i = 0; i < tupdesc->natts; i++)
2068         {
2069                 /************************************************************
2070                  * Get the attribute name
2071                  ************************************************************/
2072                 attname = tupdesc->attrs[i]->attname.data;
2073
2074                 /************************************************************
2075                  * Get the attributes value
2076                  ************************************************************/
2077                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2078
2079                 /************************************************************
2080                  * Lookup the attribute type in the syscache
2081                  * for the output function
2082                  ************************************************************/
2083                 typeTup = SearchSysCacheTuple(TYPEOID,
2084                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
2085                                                                           0, 0, 0);
2086                 if (!HeapTupleIsValid(typeTup))
2087                 {
2088                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
2089                                  attname, tupdesc->attrs[i]->atttypid);
2090                 }
2091
2092                 typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
2093                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
2094
2095                 /************************************************************
2096                  * If there is a value, set the variable
2097                  * If not, unset it
2098                  *
2099                  * Hmmm - Null attributes will cause functions to
2100                  *                crash if they don't expect them - need something
2101                  *                smarter here.
2102                  ************************************************************/
2103                 if (!isnull && OidIsValid(typoutput))
2104                 {
2105                         FmgrInfo        finfo;
2106
2107                         fmgr_info(typoutput, &finfo);
2108
2109                         outputstr = (*fmgr_faddr(&finfo))
2110                                 (attr, typelem,
2111                                  tupdesc->attrs[i]->attlen);
2112
2113                         Tcl_SetVar2(interp, *arrptr, *nameptr, outputstr, 0);
2114                         pfree(outputstr);
2115                 }
2116                 else
2117                         Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
2118         }
2119 }
2120
2121
2122 #endif
2123 /**********************************************************************
2124  * plperl_build_tuple_argument() - Build a string for a ref to a hash
2125  *                                from all attributes of a given tuple
2126  **********************************************************************/
2127 static SV  *
2128 plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
2129 {
2130         int                     i;
2131         SV                 *output;
2132         Datum           attr;
2133         bool            isnull;
2134
2135         char       *attname;
2136         char       *outputstr;
2137         HeapTuple       typeTup;
2138         Oid                     typoutput;
2139         Oid                     typelem;
2140
2141         output = sv_2mortal(newSVpv("{", 0));
2142
2143         for (i = 0; i < tupdesc->natts; i++)
2144         {
2145                 /************************************************************
2146                  * Get the attribute name
2147                  ************************************************************/
2148                 attname = tupdesc->attrs[i]->attname.data;
2149
2150                 /************************************************************
2151                  * Get the attributes value
2152                  ************************************************************/
2153                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2154
2155                 /************************************************************
2156                  * Lookup the attribute type in the syscache
2157                  * for the output function
2158                  ************************************************************/
2159                 typeTup = SearchSysCacheTuple(TYPEOID,
2160                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
2161                                                                           0, 0, 0);
2162                 if (!HeapTupleIsValid(typeTup))
2163                 {
2164                         elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
2165                                  attname, tupdesc->attrs[i]->atttypid);
2166                 }
2167
2168                 typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
2169                 typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
2170
2171                 /************************************************************
2172                  * If there is a value, append the attribute name and the
2173                  * value to the list.
2174                  *      If it is null it will be set to undef.
2175                  ************************************************************/
2176                 if (!isnull && OidIsValid(typoutput))
2177                 {
2178                         FmgrInfo        finfo;
2179
2180                         fmgr_info(typoutput, &finfo);
2181
2182                         outputstr = (*fmgr_faddr(&finfo))
2183                                 (attr, typelem,
2184                                  tupdesc->attrs[i]->attlen);
2185
2186                         sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
2187                         pfree(outputstr);
2188                 }
2189                 else
2190                         sv_catpvf(output, "'%s' => undef,", attname);
2191         }
2192         sv_catpv(output, "}");
2193         output = perl_eval_pv(SvPV(output, na), TRUE);
2194         return output;
2195 }