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.40.2.1 2005/01/26 17:09:21 tgl Exp $
38
**********************************************************************/
47
/* postgreSQL stuff */
48
#include "executor/spi.h"
49
#include "commands/trigger.h"
51
#include "access/heapam.h"
52
#include "tcop/tcopprot.h"
53
#include "utils/syscache.h"
54
#include "catalog/pg_language.h"
55
#include "catalog/pg_proc.h"
56
#include "catalog/pg_type.h"
64
/* just in case these symbols aren't provided */
71
/**********************************************************************
72
* The information we cache about loaded procedures
73
**********************************************************************/
74
typedef struct plperl_proc_desc
77
TransactionId fn_xmin;
80
FmgrInfo result_in_func;
83
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
84
Oid arg_out_elem[FUNC_MAX_ARGS];
85
int arg_is_rel[FUNC_MAX_ARGS];
90
/**********************************************************************
92
**********************************************************************/
93
static int plperl_firstcall = 1;
94
static PerlInterpreter *plperl_interp = NULL;
95
static HV *plperl_proc_hash = NULL;
97
/**********************************************************************
98
* Forward declarations
99
**********************************************************************/
100
static void plperl_init_all(void);
101
static void plperl_init_interp(void);
103
Datum plperl_call_handler(PG_FUNCTION_ARGS);
104
void plperl_init(void);
106
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
108
static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
110
static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
111
static void plperl_init_shared_libs(pTHX);
115
* This routine is a crock, and so is everyplace that calls it. The problem
116
* is that the cached form of plperl functions/queries is allocated permanently
117
* (mostly via malloc()) and never released until backend exit. Subsidiary
118
* data structures such as fmgr info records therefore must live forever
119
* as well. A better implementation would store all this stuff in a per-
120
* function memory context that could be reclaimed at need. In the meantime,
121
* fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
122
* it might allocate, and whatever the eventual function might allocate using
123
* fn_mcxt, will live forever too.
126
perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
128
fmgr_info_cxt(functionId, finfo, TopMemoryContext);
131
/**********************************************************************
132
* plperl_init() - Initialize everything that can be
133
* safely initialized during postmaster
136
* DO NOT make this static --- it has to be callable by preload
137
**********************************************************************/
141
/************************************************************
142
* Do initialization only once
143
************************************************************/
144
if (!plperl_firstcall)
147
/************************************************************
148
* Free the proc hash table
149
************************************************************/
150
if (plperl_proc_hash != NULL)
152
hv_undef(plperl_proc_hash);
153
SvREFCNT_dec((SV *) plperl_proc_hash);
154
plperl_proc_hash = NULL;
157
/************************************************************
158
* Destroy the existing Perl interpreter
159
************************************************************/
160
if (plperl_interp != NULL)
162
perl_destruct(plperl_interp);
163
perl_free(plperl_interp);
164
plperl_interp = NULL;
167
/************************************************************
168
* Now recreate a new Perl interpreter
169
************************************************************/
170
plperl_init_interp();
172
plperl_firstcall = 0;
175
/**********************************************************************
176
* plperl_init_all() - Initialize all
177
**********************************************************************/
179
plperl_init_all(void)
182
/************************************************************
183
* Execute postmaster-startup safe initialization
184
************************************************************/
185
if (plperl_firstcall)
188
/************************************************************
189
* Any other initialization that must be done each time a new
190
* backend starts -- currently none
191
************************************************************/
196
/**********************************************************************
197
* plperl_init_interp() - Create the Perl interpreter
198
**********************************************************************/
200
plperl_init_interp(void)
203
char *embedding[3] = {
207
* no commas between the next 5 please. They are supposed to be
210
"require Safe; SPI::bootstrap();"
211
"sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
212
"$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
213
" return $x->reval(qq[sub { $_[0] }]); }"
214
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
217
plperl_interp = perl_alloc();
219
elog(ERROR, "could not allocate perl interpreter");
221
perl_construct(plperl_interp);
222
perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
223
perl_run(plperl_interp);
225
/************************************************************
226
* Initialize the proc and query hash tables
227
************************************************************/
228
plperl_proc_hash = newHV();
233
/**********************************************************************
234
* plperl_call_handler - This is the only visible function
235
* of the PL interpreter. The PostgreSQL
236
* function manager and trigger manager
237
* call this function for execution of
239
**********************************************************************/
240
PG_FUNCTION_INFO_V1(plperl_call_handler);
242
/* keep non-static */
244
plperl_call_handler(PG_FUNCTION_ARGS)
248
/************************************************************
249
* Initialize interpreter
250
************************************************************/
253
/************************************************************
254
* Connect to SPI manager
255
************************************************************/
256
if (SPI_connect() != SPI_OK_CONNECT)
257
elog(ERROR, "could not connect to SPI manager");
259
/************************************************************
260
* Determine if called as function or trigger and
261
* call appropriate subhandler
262
************************************************************/
263
if (CALLED_AS_TRIGGER(fcinfo))
266
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
267
errmsg("cannot use perl in triggers yet")));
270
* retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
272
/* make the compiler happy */
276
retval = plperl_func_handler(fcinfo);
282
/**********************************************************************
283
* plperl_create_sub() - calls the perl interpreter to
284
* create the anonymous subroutine whose text is in the SV.
285
* Returns the SV containing the RV to the closure.
286
**********************************************************************/
288
plperl_create_sub(char *s, bool trusted)
297
XPUSHs(sv_2mortal(newSVpv(s, 0)));
301
* G_KEEPERR seems to be needed here, else we don't recognize compile
302
* errors properly. Perhaps it's because there's another level of
303
* eval inside mksafefunc?
305
count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
306
G_SCALAR | G_EVAL | G_KEEPERR);
314
elog(ERROR, "didn't get a return item from mksafefunc");
323
elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
327
* need to make a deep copy of the return. it comes off the stack as a
330
subref = newSVsv(POPs);
339
* subref is our responsibility because it is not mortal
341
SvREFCNT_dec(subref);
342
elog(ERROR, "didn't get a code ref");
352
/**********************************************************************
353
* plperl_init_shared_libs() -
355
* We cannot use the DynaLoader directly to get at the Opcode
356
* module (used by Safe.pm). So, we link Opcode into ourselves
357
* and do the initialization behind perl's back.
359
**********************************************************************/
361
EXTERN_C void boot_DynaLoader(pTHX_ CV * cv);
362
EXTERN_C void boot_SPI(pTHX_ CV * cv);
365
plperl_init_shared_libs(pTHX)
367
char *file = __FILE__;
369
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
370
newXS("SPI::bootstrap", boot_SPI, file);
373
/**********************************************************************
374
* plperl_call_perl_func() - calls a perl function through the RV
375
* stored in the prodesc structure. massages the input parms properly
376
**********************************************************************/
378
plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
389
for (i = 0; i < desc->nargs; i++)
391
if (desc->arg_is_rel[i])
393
TupleTableSlot *slot = (TupleTableSlot *) fcinfo->arg[i];
396
Assert(slot != NULL && !fcinfo->argnull[i]);
399
* plperl_build_tuple_argument better return a mortal SV.
401
hashref = plperl_build_tuple_argument(slot->val,
402
slot->ttc_tupleDescriptor);
407
if (fcinfo->argnull[i])
408
XPUSHs(&PL_sv_undef);
413
tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
415
ObjectIdGetDatum(desc->arg_out_elem[i]),
417
XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
424
/* Do NOT use G_KEEPERR here */
425
count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
434
elog(ERROR, "didn't get a return item from function");
443
elog(ERROR, "error from function: %s", SvPV(ERRSV, PL_na));
446
retval = newSVsv(POPs);
456
/**********************************************************************
457
* plperl_func_handler() - Handler for regular function calls
458
**********************************************************************/
460
plperl_func_handler(PG_FUNCTION_ARGS)
462
plperl_proc_desc *prodesc;
466
/* Find or compile the function */
467
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
469
/************************************************************
470
* Call the Perl function
471
************************************************************/
472
perlret = plperl_call_perl_func(prodesc, fcinfo);
474
/************************************************************
475
* Disconnect from SPI manager and then create the return
476
* values datum (if the input function does a palloc for it
477
* this must not be allocated in the SPI memory context
478
* because SPI_finish would free it).
479
************************************************************/
480
if (SPI_finish() != SPI_OK_FINISH)
481
elog(ERROR, "SPI_finish() failed");
483
if (!(perlret && SvOK(perlret)))
485
/* return NULL if Perl code returned undef */
487
fcinfo->isnull = true;
491
retval = FunctionCall3(&prodesc->result_in_func,
492
PointerGetDatum(SvPV(perlret, PL_na)),
493
ObjectIdGetDatum(prodesc->result_in_elem),
497
SvREFCNT_dec(perlret);
503
/**********************************************************************
504
* compile_plperl_function - compile (or hopefully just look up) function
505
**********************************************************************/
506
static plperl_proc_desc *
507
compile_plperl_function(Oid fn_oid, bool is_trigger)
510
Form_pg_proc procStruct;
511
char internal_proname[64];
513
plperl_proc_desc *prodesc = NULL;
516
/* We'll need the pg_proc tuple in any case... */
517
procTup = SearchSysCache(PROCOID,
518
ObjectIdGetDatum(fn_oid),
520
if (!HeapTupleIsValid(procTup))
521
elog(ERROR, "cache lookup failed for function %u", fn_oid);
522
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
524
/************************************************************
525
* Build our internal proc name from the functions Oid
526
************************************************************/
528
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
530
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
531
proname_len = strlen(internal_proname);
533
/************************************************************
534
* Lookup the internal proc name in the hashtable
535
************************************************************/
536
if (hv_exists(plperl_proc_hash, internal_proname, proname_len))
540
prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
541
internal_proname, proname_len, 0));
543
/************************************************************
544
* If it's present, must check whether it's still up to date.
545
* This is needed because CREATE OR REPLACE FUNCTION can modify the
546
* function's pg_proc entry without changing its OID.
547
************************************************************/
548
uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
549
prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
553
/* need we delete old entry? */
558
/************************************************************
559
* If we haven't found it in the hashtable, we analyze
560
* the functions arguments and returntype and store
561
* the in-/out-functions in the prodesc block and create
562
* a new hashtable entry for it.
564
* Then we load the procedure into the Perl interpreter.
565
************************************************************/
570
Form_pg_language langStruct;
571
Form_pg_type typeStruct;
574
/************************************************************
575
* Allocate a new procedure description block
576
************************************************************/
577
prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
580
(errcode(ERRCODE_OUT_OF_MEMORY),
581
errmsg("out of memory")));
582
MemSet(prodesc, 0, sizeof(plperl_proc_desc));
583
prodesc->proname = strdup(internal_proname);
584
prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
585
prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
587
/************************************************************
588
* Lookup the pg_language tuple by Oid
589
************************************************************/
590
langTup = SearchSysCache(LANGOID,
591
ObjectIdGetDatum(procStruct->prolang),
593
if (!HeapTupleIsValid(langTup))
595
free(prodesc->proname);
597
elog(ERROR, "cache lookup failed for language %u",
598
procStruct->prolang);
600
langStruct = (Form_pg_language) GETSTRUCT(langTup);
601
prodesc->lanpltrusted = langStruct->lanpltrusted;
602
ReleaseSysCache(langTup);
604
/************************************************************
605
* Get the required information for input conversion of the
607
************************************************************/
610
typeTup = SearchSysCache(TYPEOID,
611
ObjectIdGetDatum(procStruct->prorettype),
613
if (!HeapTupleIsValid(typeTup))
615
free(prodesc->proname);
617
elog(ERROR, "cache lookup failed for type %u",
618
procStruct->prorettype);
620
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
622
/* Disallow pseudotype result, except VOID */
623
if (typeStruct->typtype == 'p')
625
if (procStruct->prorettype == VOIDOID)
627
else if (procStruct->prorettype == TRIGGEROID)
629
free(prodesc->proname);
632
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
633
errmsg("trigger functions may only be called as triggers")));
637
free(prodesc->proname);
640
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
641
errmsg("plperl functions cannot return type %s",
642
format_type_be(procStruct->prorettype))));
646
if (typeStruct->typrelid != InvalidOid)
648
free(prodesc->proname);
651
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
652
errmsg("plperl functions cannot return tuples yet")));
655
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
656
prodesc->result_in_elem = typeStruct->typelem;
658
ReleaseSysCache(typeTup);
661
/************************************************************
662
* Get the required information for output conversion
663
* of all procedure arguments
664
************************************************************/
667
prodesc->nargs = procStruct->pronargs;
668
for (i = 0; i < prodesc->nargs; i++)
670
typeTup = SearchSysCache(TYPEOID,
671
ObjectIdGetDatum(procStruct->proargtypes[i]),
673
if (!HeapTupleIsValid(typeTup))
675
free(prodesc->proname);
677
elog(ERROR, "cache lookup failed for type %u",
678
procStruct->proargtypes[i]);
680
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
682
/* Disallow pseudotype argument */
683
if (typeStruct->typtype == 'p')
685
free(prodesc->proname);
688
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
689
errmsg("plperl functions cannot take type %s",
690
format_type_be(procStruct->proargtypes[i]))));
693
if (typeStruct->typrelid != InvalidOid)
694
prodesc->arg_is_rel[i] = 1;
696
prodesc->arg_is_rel[i] = 0;
698
perm_fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
699
prodesc->arg_out_elem[i] = typeStruct->typelem;
700
ReleaseSysCache(typeTup);
704
/************************************************************
705
* create the text of the anonymous subroutine.
706
* we do not use a named subroutine so that we can call directly
707
* through the reference.
709
************************************************************/
710
proc_source = DatumGetCString(DirectFunctionCall1(textout,
711
PointerGetDatum(&procStruct->prosrc)));
713
/************************************************************
714
* Create the procedure in the interpreter
715
************************************************************/
716
prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
718
if (!prodesc->reference)
720
free(prodesc->proname);
722
elog(ERROR, "could not create internal procedure \"%s\"",
726
/************************************************************
727
* Add the proc description block to the hashtable
728
************************************************************/
729
hv_store(plperl_proc_hash, internal_proname, proname_len,
730
newSViv((IV) prodesc), 0);
733
ReleaseSysCache(procTup);
739
/**********************************************************************
740
* plperl_build_tuple_argument() - Build a ref to a hash
741
* from all attributes of a given tuple
742
**********************************************************************/
744
plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
751
for (i = 0; i < tupdesc->natts; i++)
762
if (tupdesc->attrs[i]->attisdropped)
765
attname = NameStr(tupdesc->attrs[i]->attname);
766
namelen = strlen(attname);
767
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
770
/* Store (attname => undef) and move on. */
771
hv_store(hv, attname, namelen, newSV(0), 0);
775
/* XXX should have a way to cache these lookups */
777
getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
778
&typoutput, &typioparam, &typisvarlena);
780
outputstr = DatumGetCString(OidFunctionCall3(typoutput,
782
ObjectIdGetDatum(typioparam),
783
Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
785
hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0);
788
return newRV_noinc((SV *) hv);
added
removed
src/pl/plperl/plperl.c
