@@ -68,6 +68,7 @@ PG_MODULE_MAGIC;
68
68
*
69
69
* The plperl_interp_desc structs are kept in a Postgres hash table indexed
70
70
* by userid OID, with OID 0 used for the single untrusted interpreter.
71
+ * Once created, an interpreter is kept for the life of the process.
71
72
*
72
73
* We start out by creating a "held" interpreter, which we initialize
73
74
* only as far as we can do without deciding if it will be trusted or
@@ -93,28 +94,44 @@ typedef struct plperl_interp_desc
93
94
94
95
/**********************************************************************
95
96
* The information we cache about loaded procedures
97
+ *
98
+ * The refcount field counts the struct's reference from the hash table shown
99
+ * below, plus one reference for each function call level that is using the
100
+ * struct. We can release the struct, and the associated Perl sub, when the
101
+ * refcount goes to zero.
96
102
**********************************************************************/
97
103
typedef struct plperl_proc_desc
98
104
{
99
105
char * proname ;/* user name of procedure */
100
- TransactionId fn_xmin ;
106
+ TransactionId fn_xmin ;/* xmin/TID of procedure's pg_proc tuple */
101
107
ItemPointerData fn_tid ;
108
+ int refcount ;/* reference count of this struct */
109
+ SV * reference ;/* CODE reference for Perl sub */
102
110
plperl_interp_desc * interp ;/* interpreter it's created in */
103
- bool fn_readonly ;
104
- bool lanpltrusted ;
111
+ bool fn_readonly ;/* is function readonly (not volatile)? */
112
+ bool lanpltrusted ;/* is it plperl, rather than plperlu? */
105
113
bool fn_retistuple ;/* true, if function returns tuple */
106
114
bool fn_retisset ;/* true, if function returns set */
107
115
bool fn_retisarray ;/* true if function returns array */
116
+ /* Conversion info for function's result type: */
108
117
Oid result_oid ;/* Oid of result type */
109
118
FmgrInfo result_in_func ;/* I/O function and arg for result type */
110
119
Oid result_typioparam ;
120
+ /* Conversion info for function's argument types: */
111
121
int nargs ;
112
122
FmgrInfo arg_out_func [FUNC_MAX_ARGS ];
113
123
bool arg_is_rowtype [FUNC_MAX_ARGS ];
114
124
Oid arg_arraytype [FUNC_MAX_ARGS ];/* InvalidOid if not an array */
115
- SV * reference ;
116
125
}plperl_proc_desc ;
117
126
127
+ #define increment_prodesc_refcount (prodesc ) \
128
+ ((prodesc)->refcount++)
129
+ #define decrement_prodesc_refcount (prodesc ) \
130
+ do { \
131
+ if (--((prodesc)->refcount) <= 0) \
132
+ free_plperl_function(prodesc); \
133
+ } while(0)
134
+
118
135
/**********************************************************************
119
136
* For speedy lookup, we maintain a hash table mapping from
120
137
* function OID + trigger flag + user OID to plperl_proc_desc pointers.
@@ -236,6 +253,8 @@ static void set_interp_require(bool trusted);
236
253
static Datum plperl_func_handler (PG_FUNCTION_ARGS );
237
254
static Datum plperl_trigger_handler (PG_FUNCTION_ARGS );
238
255
256
+ static void free_plperl_function (plperl_proc_desc * prodesc );
257
+
239
258
static plperl_proc_desc * compile_plperl_function (Oid fn_oid ,bool is_trigger );
240
259
241
260
static SV * plperl_hash_from_tuple (HeapTuple tuple ,TupleDesc tupdesc );
@@ -1679,19 +1698,24 @@ plperl_call_handler(PG_FUNCTION_ARGS)
1679
1698
1680
1699
PG_TRY ();
1681
1700
{
1701
+ current_call_data = NULL ;
1682
1702
if (CALLED_AS_TRIGGER (fcinfo ))
1683
1703
retval = PointerGetDatum (plperl_trigger_handler (fcinfo ));
1684
1704
else
1685
1705
retval = plperl_func_handler (fcinfo );
1686
1706
}
1687
1707
PG_CATCH ();
1688
1708
{
1709
+ if (current_call_data && current_call_data -> prodesc )
1710
+ decrement_prodesc_refcount (current_call_data -> prodesc );
1689
1711
current_call_data = save_call_data ;
1690
1712
activate_interpreter (oldinterp );
1691
1713
PG_RE_THROW ();
1692
1714
}
1693
1715
PG_END_TRY ();
1694
1716
1717
+ if (current_call_data && current_call_data -> prodesc )
1718
+ decrement_prodesc_refcount (current_call_data -> prodesc );
1695
1719
current_call_data = save_call_data ;
1696
1720
activate_interpreter (oldinterp );
1697
1721
return retval ;
@@ -1743,14 +1767,15 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
1743
1767
desc .nargs = 0 ;
1744
1768
desc .reference = NULL ;
1745
1769
1746
- current_call_data = (plperl_call_data * )palloc0 (sizeof (plperl_call_data ));
1747
- current_call_data -> fcinfo = & fake_fcinfo ;
1748
- current_call_data -> prodesc = & desc ;
1749
-
1750
1770
PG_TRY ();
1751
1771
{
1752
1772
SV * perlret ;
1753
1773
1774
+ current_call_data = (plperl_call_data * )palloc0 (sizeof (plperl_call_data ));
1775
+ current_call_data -> fcinfo = & fake_fcinfo ;
1776
+ current_call_data -> prodesc = & desc ;
1777
+ /* we do not bother with refcounting the fake prodesc */
1778
+
1754
1779
if (SPI_connect ()!= SPI_OK_CONNECT )
1755
1780
elog (ERROR ,"could not connect to SPI manager" );
1756
1781
@@ -2144,6 +2169,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
2144
2169
2145
2170
prodesc = compile_plperl_function (fcinfo -> flinfo -> fn_oid , false);
2146
2171
current_call_data -> prodesc = prodesc ;
2172
+ increment_prodesc_refcount (prodesc );
2147
2173
2148
2174
/* Set a callback for error reporting */
2149
2175
pl_error_context .callback = plperl_exec_callback ;
@@ -2264,6 +2290,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
2264
2290
/* Find or compile the function */
2265
2291
prodesc = compile_plperl_function (fcinfo -> flinfo -> fn_oid , true);
2266
2292
current_call_data -> prodesc = prodesc ;
2293
+ increment_prodesc_refcount (prodesc );
2267
2294
2268
2295
/* Set a callback for error reporting */
2269
2296
pl_error_context .callback = plperl_exec_callback ;
@@ -2373,23 +2400,35 @@ validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
2373
2400
2374
2401
/* Otherwise, unlink the obsoleted entry from the hashtable ... */
2375
2402
proc_ptr -> proc_ptr = NULL ;
2376
- /* ... and throw it away */
2377
- if (prodesc -> reference )
2378
- {
2379
- plperl_interp_desc * oldinterp = plperl_active_interp ;
2380
-
2381
- activate_interpreter (prodesc -> interp );
2382
- SvREFCNT_dec (prodesc -> reference );
2383
- activate_interpreter (oldinterp );
2384
- }
2385
- free (prodesc -> proname );
2386
- free (prodesc );
2403
+ /* ... and release the corresponding refcount, probably deleting it */
2404
+ decrement_prodesc_refcount (prodesc );
2387
2405
}
2388
2406
2389
2407
return false;
2390
2408
}
2391
2409
2392
2410
2411
+ static void
2412
+ free_plperl_function (plperl_proc_desc * prodesc )
2413
+ {
2414
+ Assert (prodesc -> refcount <=0 );
2415
+ /* Release CODE reference, if we have one, from the appropriate interp */
2416
+ if (prodesc -> reference )
2417
+ {
2418
+ plperl_interp_desc * oldinterp = plperl_active_interp ;
2419
+
2420
+ activate_interpreter (prodesc -> interp );
2421
+ SvREFCNT_dec (prodesc -> reference );
2422
+ activate_interpreter (oldinterp );
2423
+ }
2424
+ /* Get rid of what we conveniently can of our own structs */
2425
+ /* (FmgrInfo subsidiary info will get leaked ...) */
2426
+ if (prodesc -> proname )
2427
+ free (prodesc -> proname );
2428
+ free (prodesc );
2429
+ }
2430
+
2431
+
2393
2432
static plperl_proc_desc *
2394
2433
compile_plperl_function (Oid fn_oid ,bool is_trigger )
2395
2434
{
@@ -2460,12 +2499,17 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2460
2499
ereport (ERROR ,
2461
2500
(errcode (ERRCODE_OUT_OF_MEMORY ),
2462
2501
errmsg ("out of memory" )));
2502
+ /* Initialize all fields to 0 so free_plperl_function is safe */
2463
2503
MemSet (prodesc ,0 ,sizeof (plperl_proc_desc ));
2504
+
2464
2505
prodesc -> proname = strdup (NameStr (procStruct -> proname ));
2465
2506
if (prodesc -> proname == NULL )
2507
+ {
2508
+ free_plperl_function (prodesc );
2466
2509
ereport (ERROR ,
2467
2510
(errcode (ERRCODE_OUT_OF_MEMORY ),
2468
2511
errmsg ("out of memory" )));
2512
+ }
2469
2513
prodesc -> fn_xmin = HeapTupleHeaderGetXmin (procTup -> t_data );
2470
2514
prodesc -> fn_tid = procTup -> t_self ;
2471
2515
@@ -2480,8 +2524,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2480
2524
ObjectIdGetDatum (procStruct -> prolang ));
2481
2525
if (!HeapTupleIsValid (langTup ))
2482
2526
{
2483
- free (prodesc -> proname );
2484
- free (prodesc );
2527
+ free_plperl_function (prodesc );
2485
2528
elog (ERROR ,"cache lookup failed for language %u" ,
2486
2529
procStruct -> prolang );
2487
2530
}
@@ -2500,8 +2543,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2500
2543
ObjectIdGetDatum (procStruct -> prorettype ));
2501
2544
if (!HeapTupleIsValid (typeTup ))
2502
2545
{
2503
- free (prodesc -> proname );
2504
- free (prodesc );
2546
+ free_plperl_function (prodesc );
2505
2547
elog (ERROR ,"cache lookup failed for type %u" ,
2506
2548
procStruct -> prorettype );
2507
2549
}
@@ -2515,17 +2557,15 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2515
2557
/* okay */ ;
2516
2558
else if (procStruct -> prorettype == TRIGGEROID )
2517
2559
{
2518
- free (prodesc -> proname );
2519
- free (prodesc );
2560
+ free_plperl_function (prodesc );
2520
2561
ereport (ERROR ,
2521
2562
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2522
2563
errmsg ("trigger functions can only be called "
2523
2564
"as triggers" )));
2524
2565
}
2525
2566
else
2526
2567
{
2527
- free (prodesc -> proname );
2528
- free (prodesc );
2568
+ free_plperl_function (prodesc );
2529
2569
ereport (ERROR ,
2530
2570
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2531
2571
errmsg ("PL/Perl functions cannot return type %s" ,
@@ -2560,8 +2600,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2560
2600
ObjectIdGetDatum (procStruct -> proargtypes .values [i ]));
2561
2601
if (!HeapTupleIsValid (typeTup ))
2562
2602
{
2563
- free (prodesc -> proname );
2564
- free (prodesc );
2603
+ free_plperl_function (prodesc );
2565
2604
elog (ERROR ,"cache lookup failed for type %u" ,
2566
2605
procStruct -> proargtypes .values [i ]);
2567
2606
}
@@ -2571,8 +2610,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2571
2610
if (typeStruct -> typtype == TYPTYPE_PSEUDO &&
2572
2611
procStruct -> proargtypes .values [i ]!= RECORDOID )
2573
2612
{
2574
- free (prodesc -> proname );
2575
- free (prodesc );
2613
+ free_plperl_function (prodesc );
2576
2614
ereport (ERROR ,
2577
2615
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2578
2616
errmsg ("PL/Perl functions cannot accept type %s" ,
@@ -2625,8 +2663,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2625
2663
pfree (proc_source );
2626
2664
if (!prodesc -> reference )/* can this happen? */
2627
2665
{
2628
- free (prodesc -> proname );
2629
- free (prodesc );
2666
+ free_plperl_function (prodesc );
2630
2667
elog (ERROR ,"could not create PL/Perl internal procedure" );
2631
2668
}
2632
2669
@@ -2638,6 +2675,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2638
2675
proc_ptr = hash_search (plperl_proc_hash ,& proc_key ,
2639
2676
HASH_ENTER ,NULL );
2640
2677
proc_ptr -> proc_ptr = prodesc ;
2678
+ increment_prodesc_refcount (prodesc );
2641
2679
}
2642
2680
2643
2681
/* restore previous error callback */