1 /**********************************************************************
2 * plperl.c - perl as a procedural language for PostgreSQL
6 * This software is copyrighted by Mark Hollomon
7 * but is shameless cribbed from pltcl.c by Jan Weick.
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.
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
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.
36 * $Header: /cvsroot/pgsql/src/pl/plperl/plperl.c,v 1.31 2002/06/15 19:54:24 momjian Exp $
38 **********************************************************************/
51 /* postgreSQL stuff */
52 #include "executor/spi.h"
53 #include "commands/trigger.h"
54 #include "utils/elog.h"
56 #include "access/heapam.h"
58 #include "tcop/tcopprot.h"
59 #include "utils/syscache.h"
60 #include "catalog/pg_language.h"
61 #include "catalog/pg_proc.h"
62 #include "catalog/pg_type.h"
70 /* just in case these symbols aren't provided */
77 /**********************************************************************
78 * The information we cache about loaded procedures
79 **********************************************************************/
80 typedef struct plperl_proc_desc
83 TransactionId fn_xmin;
86 FmgrInfo result_in_func;
89 FmgrInfo arg_out_func[FUNC_MAX_ARGS];
90 Oid arg_out_elem[FUNC_MAX_ARGS];
91 int arg_is_rel[FUNC_MAX_ARGS];
96 /**********************************************************************
98 **********************************************************************/
99 static int plperl_firstcall = 1;
100 static int plperl_call_level = 0;
101 static int plperl_restart_in_progress = 0;
102 static PerlInterpreter *plperl_interp = NULL;
103 static HV *plperl_proc_hash = NULL;
105 /**********************************************************************
106 * Forward declarations
107 **********************************************************************/
108 static void plperl_init_all(void);
109 static void plperl_init_interp(void);
111 Datum plperl_call_handler(PG_FUNCTION_ARGS);
113 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
115 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
117 static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
118 static void plperl_init_shared_libs(pTHX);
122 * This routine is a crock, and so is everyplace that calls it. The problem
123 * is that the cached form of plperl functions/queries is allocated permanently
124 * (mostly via malloc()) and never released until backend exit. Subsidiary
125 * data structures such as fmgr info records therefore must live forever
126 * as well. A better implementation would store all this stuff in a per-
127 * function memory context that could be reclaimed at need. In the meantime,
128 * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
129 * it might allocate, and whatever the eventual function might allocate using
130 * fn_mcxt, will live forever too.
133 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
135 fmgr_info_cxt(functionId, finfo, TopMemoryContext);
138 /**********************************************************************
139 * plperl_init_all() - Initialize all
140 **********************************************************************/
142 plperl_init_all(void)
145 /************************************************************
146 * Do initialization only once
147 ************************************************************/
148 if (!plperl_firstcall)
152 /************************************************************
153 * Destroy the existing Perl interpreter
154 ************************************************************/
155 if (plperl_interp != NULL)
157 perl_destruct(plperl_interp);
158 perl_free(plperl_interp);
159 plperl_interp = NULL;
162 /************************************************************
163 * Free the proc hash table
164 ************************************************************/
165 if (plperl_proc_hash != NULL)
167 hv_undef(plperl_proc_hash);
168 SvREFCNT_dec((SV *) plperl_proc_hash);
169 plperl_proc_hash = NULL;
172 /************************************************************
173 * Now recreate a new Perl interpreter
174 ************************************************************/
175 plperl_init_interp();
177 plperl_firstcall = 0;
181 /**********************************************************************
182 * plperl_init_interp() - Create the Perl interpreter
183 **********************************************************************/
185 plperl_init_interp(void)
188 char *embedding[3] = {
192 * no commas between the next 5 please. They are supposed to be
195 "require Safe; SPI::bootstrap();"
196 "sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
197 "$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
198 " return $x->reval(qq[sub { $_[0] }]); }"
199 "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
202 plperl_interp = perl_alloc();
204 elog(ERROR, "plperl_init_interp(): could not allocate perl interpreter");
206 perl_construct(plperl_interp);
207 perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
208 perl_run(plperl_interp);
212 /************************************************************
213 * Initialize the proc and query hash tables
214 ************************************************************/
215 plperl_proc_hash = newHV();
221 /**********************************************************************
222 * plperl_call_handler - This is the only visible function
223 * of the PL interpreter. The PostgreSQL
224 * function manager and trigger manager
225 * call this function for execution of
227 **********************************************************************/
228 PG_FUNCTION_INFO_V1(plperl_call_handler);
230 /* keep non-static */
232 plperl_call_handler(PG_FUNCTION_ARGS)
236 /************************************************************
237 * Initialize interpreters on first call
238 ************************************************************/
239 if (plperl_firstcall)
242 /************************************************************
243 * Connect to SPI manager
244 ************************************************************/
245 if (SPI_connect() != SPI_OK_CONNECT)
246 elog(ERROR, "plperl: cannot connect to SPI manager");
247 /************************************************************
248 * Keep track about the nesting of Perl-SPI-Perl-... calls
249 ************************************************************/
252 /************************************************************
253 * Determine if called as function or trigger and
254 * call appropriate subhandler
255 ************************************************************/
256 if (CALLED_AS_TRIGGER(fcinfo))
258 elog(ERROR, "plperl: can't use perl in triggers yet.");
261 * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
263 /* make the compiler happy */
267 retval = plperl_func_handler(fcinfo);
275 /**********************************************************************
276 * plperl_create_sub() - calls the perl interpreter to
277 * create the anonymous subroutine whose text is in the SV.
278 * Returns the SV containing the RV to the closure.
279 **********************************************************************/
282 plperl_create_sub(char *s, bool trusted)
292 XPUSHs(sv_2mortal(newSVpv(s, 0)));
294 count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
295 G_SCALAR | G_EVAL | G_KEEPERR);
304 elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
308 elog(ERROR, "creation of function failed - no return from mksafefunc");
311 * need to make a deep copy of the return. it comes off the stack as a
314 subref = newSVsv(POPs);
323 * subref is our responsibility because it is not mortal
325 SvREFCNT_dec(subref);
326 elog(ERROR, "plperl_create_sub: didn't get a code ref");
335 /**********************************************************************
336 * plperl_init_shared_libs() -
338 * We cannot use the DynaLoader directly to get at the Opcode
339 * module (used by Safe.pm). So, we link Opcode into ourselves
340 * and do the initialization behind perl's back.
342 **********************************************************************/
344 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
345 EXTERN_C void boot_SPI(pTHX_ CV* cv);
348 plperl_init_shared_libs(pTHX)
350 char *file = __FILE__;
352 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
353 newXS("SPI::bootstrap", boot_SPI, file);
356 /**********************************************************************
357 * plperl_call_perl_func() - calls a perl function through the RV
358 * stored in the prodesc structure. massages the input parms properly
359 **********************************************************************/
362 plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
375 for (i = 0; i < desc->nargs; i++)
377 if (desc->arg_is_rel[i])
379 TupleTableSlot *slot = (TupleTableSlot *) fcinfo->arg[i];
382 Assert(slot != NULL && !fcinfo->argnull[i]);
385 * plperl_build_tuple_argument better return a mortal SV.
387 hashref = plperl_build_tuple_argument(slot->val,
388 slot->ttc_tupleDescriptor);
393 if (fcinfo->argnull[i])
394 XPUSHs(&PL_sv_undef);
399 tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
401 ObjectIdGetDatum(desc->arg_out_elem[i]),
403 XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
409 count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
418 elog(ERROR, "plperl: didn't get a return item from function");
427 elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
430 retval = newSVsv(POPs);
442 /**********************************************************************
443 * plperl_func_handler() - Handler for regular function calls
444 **********************************************************************/
446 plperl_func_handler(PG_FUNCTION_ARGS)
448 plperl_proc_desc *prodesc;
451 sigjmp_buf save_restart;
453 /* Find or compile the function */
454 prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
456 /* Set up error handling */
457 memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
459 if (sigsetjmp(Warn_restart, 1) != 0)
461 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
462 plperl_restart_in_progress = 1;
463 if (--plperl_call_level == 0)
464 plperl_restart_in_progress = 0;
465 siglongjmp(Warn_restart, 1);
468 /************************************************************
469 * Call the Perl function
470 ************************************************************/
471 perlret = plperl_call_perl_func(prodesc, fcinfo);
473 /************************************************************
474 * Disconnect from SPI manager and then create the return
475 * values datum (if the input function does a palloc for it
476 * this must not be allocated in the SPI memory context
477 * because SPI_finish would free it).
478 ************************************************************/
479 if (SPI_finish() != SPI_OK_FINISH)
480 elog(ERROR, "plperl: SPI_finish() failed");
482 if (!(perlret && SvOK(perlret)))
484 /* return NULL if Perl code returned undef */
486 fcinfo->isnull = true;
490 retval = FunctionCall3(&prodesc->result_in_func,
491 PointerGetDatum(SvPV(perlret, PL_na)),
492 ObjectIdGetDatum(prodesc->result_in_elem),
496 SvREFCNT_dec(perlret);
498 memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
499 if (plperl_restart_in_progress)
501 if (--plperl_call_level == 0)
502 plperl_restart_in_progress = 0;
503 siglongjmp(Warn_restart, 1);
510 /**********************************************************************
511 * compile_plperl_function - compile (or hopefully just look up) function
512 **********************************************************************/
513 static plperl_proc_desc *
514 compile_plperl_function(Oid fn_oid, bool is_trigger)
517 Form_pg_proc procStruct;
518 char internal_proname[64];
520 plperl_proc_desc *prodesc = NULL;
523 /* We'll need the pg_proc tuple in any case... */
524 procTup = SearchSysCache(PROCOID,
525 ObjectIdGetDatum(fn_oid),
527 if (!HeapTupleIsValid(procTup))
528 elog(ERROR, "plperl: cache lookup for proc %u failed", fn_oid);
529 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
531 /************************************************************
532 * Build our internal proc name from the functions Oid
533 ************************************************************/
535 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
537 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
538 proname_len = strlen(internal_proname);
540 /************************************************************
541 * Lookup the internal proc name in the hashtable
542 ************************************************************/
543 if (hv_exists(plperl_proc_hash, internal_proname, proname_len))
547 prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
548 internal_proname, proname_len, 0));
550 /************************************************************
551 * If it's present, must check whether it's still up to date.
552 * This is needed because CREATE OR REPLACE FUNCTION can modify the
553 * function's pg_proc entry without changing its OID.
554 ************************************************************/
555 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
556 prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
560 /* need we delete old entry? */
565 /************************************************************
566 * If we haven't found it in the hashtable, we analyze
567 * the functions arguments and returntype and store
568 * the in-/out-functions in the prodesc block and create
569 * a new hashtable entry for it.
571 * Then we load the procedure into the Perl interpreter.
572 ************************************************************/
577 Form_pg_language langStruct;
578 Form_pg_type typeStruct;
581 /************************************************************
582 * Allocate a new procedure description block
583 ************************************************************/
584 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
586 elog(ERROR, "plperl: out of memory");
587 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
588 prodesc->proname = strdup(internal_proname);
589 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
590 prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
592 /************************************************************
593 * Lookup the pg_language tuple by Oid
594 ************************************************************/
595 langTup = SearchSysCache(LANGOID,
596 ObjectIdGetDatum(procStruct->prolang),
598 if (!HeapTupleIsValid(langTup))
600 free(prodesc->proname);
602 elog(ERROR, "plperl: cache lookup for language %u failed",
603 procStruct->prolang);
605 langStruct = (Form_pg_language) GETSTRUCT(langTup);
606 prodesc->lanpltrusted = langStruct->lanpltrusted;
607 ReleaseSysCache(langTup);
609 /************************************************************
610 * Get the required information for input conversion of the
612 ************************************************************/
615 typeTup = SearchSysCache(TYPEOID,
616 ObjectIdGetDatum(procStruct->prorettype),
618 if (!HeapTupleIsValid(typeTup))
620 free(prodesc->proname);
622 if (!OidIsValid(procStruct->prorettype))
623 elog(ERROR, "plperl functions cannot return type \"opaque\""
624 "\n\texcept when used as triggers");
626 elog(ERROR, "plperl: cache lookup for return type %u failed",
627 procStruct->prorettype);
629 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
631 if (typeStruct->typrelid != InvalidOid)
633 free(prodesc->proname);
635 elog(ERROR, "plperl: return types of tuples not supported yet");
638 perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
639 prodesc->result_in_elem = typeStruct->typelem;
641 ReleaseSysCache(typeTup);
644 /************************************************************
645 * Get the required information for output conversion
646 * of all procedure arguments
647 ************************************************************/
650 prodesc->nargs = procStruct->pronargs;
651 for (i = 0; i < prodesc->nargs; i++)
653 typeTup = SearchSysCache(TYPEOID,
654 ObjectIdGetDatum(procStruct->proargtypes[i]),
656 if (!HeapTupleIsValid(typeTup))
658 free(prodesc->proname);
660 if (!OidIsValid(procStruct->proargtypes[i]))
661 elog(ERROR, "plperl functions cannot take type \"opaque\"");
663 elog(ERROR, "plperl: cache lookup for argument type %u failed",
664 procStruct->proargtypes[i]);
666 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
668 if (typeStruct->typrelid != InvalidOid)
669 prodesc->arg_is_rel[i] = 1;
671 prodesc->arg_is_rel[i] = 0;
673 perm_fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
674 prodesc->arg_out_elem[i] = typeStruct->typelem;
675 ReleaseSysCache(typeTup);
679 /************************************************************
680 * create the text of the anonymous subroutine.
681 * we do not use a named subroutine so that we can call directly
682 * through the reference.
684 ************************************************************/
685 proc_source = DatumGetCString(DirectFunctionCall1(textout,
686 PointerGetDatum(&procStruct->prosrc)));
688 /************************************************************
689 * Create the procedure in the interpreter
690 ************************************************************/
691 prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
693 if (!prodesc->reference)
695 free(prodesc->proname);
697 elog(ERROR, "plperl: cannot create internal procedure %s",
701 /************************************************************
702 * Add the proc description block to the hashtable
703 ************************************************************/
704 hv_store(plperl_proc_hash, internal_proname, proname_len,
705 newSViv((IV) prodesc), 0);
708 ReleaseSysCache(procTup);
714 /**********************************************************************
715 * plperl_build_tuple_argument() - Build a string for a ref to a hash
716 * from all attributes of a given tuple
717 **********************************************************************/
719 plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
731 output = sv_2mortal(newSVpv("{", 0));
733 for (i = 0; i < tupdesc->natts; i++)
735 /************************************************************
736 * Get the attribute name
737 ************************************************************/
738 attname = tupdesc->attrs[i]->attname.data;
740 /************************************************************
741 * Get the attributes value
742 ************************************************************/
743 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
745 /************************************************************
746 * If it is null it will be set to undef in the hash.
747 ************************************************************/
750 sv_catpvf(output, "'%s' => undef,", attname);
754 /************************************************************
755 * Lookup the attribute type in the syscache
756 * for the output function
757 ************************************************************/
758 typeTup = SearchSysCache(TYPEOID,
759 ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
761 if (!HeapTupleIsValid(typeTup))
762 elog(ERROR, "plperl: Cache lookup for attribute '%s' type %u failed",
763 attname, tupdesc->attrs[i]->atttypid);
765 typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
766 typelem = ((Form_pg_type) GETSTRUCT(typeTup))->typelem;
767 ReleaseSysCache(typeTup);
769 /************************************************************
770 * Append the attribute name and the value to the list.
771 ************************************************************/
772 outputstr = DatumGetCString(OidFunctionCall3(typoutput,
774 ObjectIdGetDatum(typelem),
775 Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
776 sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
780 sv_catpv(output, "}");
781 output = perl_eval_pv(SvPV(output, PL_na), TRUE);