@@ -67,6 +67,7 @@ PG_MODULE_MAGIC;
67
67
*
68
68
* The plperl_interp_desc structs are kept in a Postgres hash table indexed
69
69
* by userid OID, with OID 0 used for the single untrusted interpreter.
70
+ * Once created, an interpreter is kept for the life of the process.
70
71
*
71
72
* We start out by creating a "held" interpreter, which we initialize
72
73
* only as far as we can do without deciding if it will be trusted or
@@ -92,27 +93,43 @@ typedef struct plperl_interp_desc
92
93
93
94
/**********************************************************************
94
95
* The information we cache about loaded procedures
96
+ *
97
+ * The refcount field counts the struct's reference from the hash table shown
98
+ * below, plus one reference for each function call level that is using the
99
+ * struct. We can release the struct, and the associated Perl sub, when the
100
+ * refcount goes to zero.
95
101
**********************************************************************/
96
102
typedef struct plperl_proc_desc
97
103
{
98
104
char * proname ;/* user name of procedure */
99
- TransactionId fn_xmin ;
105
+ TransactionId fn_xmin ;/* xmin/TID of procedure's pg_proc tuple */
100
106
ItemPointerData fn_tid ;
107
+ int refcount ;/* reference count of this struct */
108
+ SV * reference ;/* CODE reference for Perl sub */
101
109
plperl_interp_desc * interp ;/* interpreter it's created in */
102
- bool fn_readonly ;
103
- bool lanpltrusted ;
110
+ bool fn_readonly ;/* is function readonly (not volatile)? */
111
+ bool lanpltrusted ;/* is it plperl, rather than plperlu? */
104
112
bool fn_retistuple ;/* true, if function returns tuple */
105
113
bool fn_retisset ;/* true, if function returns set */
106
114
bool fn_retisarray ;/* true if function returns array */
115
+ /* Conversion info for function's result type: */
107
116
Oid result_oid ;/* Oid of result type */
108
117
FmgrInfo result_in_func ;/* I/O function and arg for result type */
109
118
Oid result_typioparam ;
119
+ /* Conversion info for function's argument types: */
110
120
int nargs ;
111
121
FmgrInfo arg_out_func [FUNC_MAX_ARGS ];
112
122
bool arg_is_rowtype [FUNC_MAX_ARGS ];
113
- SV * reference ;
114
123
}plperl_proc_desc ;
115
124
125
+ #define increment_prodesc_refcount (prodesc ) \
126
+ ((prodesc)->refcount++)
127
+ #define decrement_prodesc_refcount (prodesc ) \
128
+ do { \
129
+ if (--((prodesc)->refcount) <= 0) \
130
+ free_plperl_function(prodesc); \
131
+ } while(0)
132
+
116
133
/**********************************************************************
117
134
* For speedy lookup, we maintain a hash table mapping from
118
135
* function OID + trigger flag + user OID to plperl_proc_desc pointers.
@@ -217,6 +234,8 @@ static void set_interp_require(bool trusted);
217
234
static Datum plperl_func_handler (PG_FUNCTION_ARGS );
218
235
static Datum plperl_trigger_handler (PG_FUNCTION_ARGS );
219
236
237
+ static void free_plperl_function (plperl_proc_desc * prodesc );
238
+
220
239
static plperl_proc_desc * compile_plperl_function (Oid fn_oid ,bool is_trigger );
221
240
222
241
static SV * plperl_hash_from_tuple (HeapTuple tuple ,TupleDesc tupdesc );
@@ -1228,19 +1247,24 @@ plperl_call_handler(PG_FUNCTION_ARGS)
1228
1247
1229
1248
PG_TRY ();
1230
1249
{
1250
+ current_call_data = NULL ;
1231
1251
if (CALLED_AS_TRIGGER (fcinfo ))
1232
1252
retval = PointerGetDatum (plperl_trigger_handler (fcinfo ));
1233
1253
else
1234
1254
retval = plperl_func_handler (fcinfo );
1235
1255
}
1236
1256
PG_CATCH ();
1237
1257
{
1258
+ if (current_call_data && current_call_data -> prodesc )
1259
+ decrement_prodesc_refcount (current_call_data -> prodesc );
1238
1260
current_call_data = save_call_data ;
1239
1261
activate_interpreter (oldinterp );
1240
1262
PG_RE_THROW ();
1241
1263
}
1242
1264
PG_END_TRY ();
1243
1265
1266
+ if (current_call_data && current_call_data -> prodesc )
1267
+ decrement_prodesc_refcount (current_call_data -> prodesc );
1244
1268
current_call_data = save_call_data ;
1245
1269
activate_interpreter (oldinterp );
1246
1270
return retval ;
@@ -1292,14 +1316,15 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
1292
1316
desc .nargs = 0 ;
1293
1317
desc .reference = NULL ;
1294
1318
1295
- current_call_data = (plperl_call_data * )palloc0 (sizeof (plperl_call_data ));
1296
- current_call_data -> fcinfo = & fake_fcinfo ;
1297
- current_call_data -> prodesc = & desc ;
1298
-
1299
1319
PG_TRY ();
1300
1320
{
1301
1321
SV * perlret ;
1302
1322
1323
+ current_call_data = (plperl_call_data * )palloc0 (sizeof (plperl_call_data ));
1324
+ current_call_data -> fcinfo = & fake_fcinfo ;
1325
+ current_call_data -> prodesc = & desc ;
1326
+ /* we do not bother with refcounting the fake prodesc */
1327
+
1303
1328
if (SPI_connect ()!= SPI_OK_CONNECT )
1304
1329
elog (ERROR ,"could not connect to SPI manager" );
1305
1330
@@ -1659,6 +1684,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
1659
1684
1660
1685
prodesc = compile_plperl_function (fcinfo -> flinfo -> fn_oid , false);
1661
1686
current_call_data -> prodesc = prodesc ;
1687
+ increment_prodesc_refcount (prodesc );
1662
1688
1663
1689
/* Set a callback for error reporting */
1664
1690
pl_error_context .callback = plperl_exec_callback ;
@@ -1820,6 +1846,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
1820
1846
/* Find or compile the function */
1821
1847
prodesc = compile_plperl_function (fcinfo -> flinfo -> fn_oid , true);
1822
1848
current_call_data -> prodesc = prodesc ;
1849
+ increment_prodesc_refcount (prodesc );
1823
1850
1824
1851
/* Set a callback for error reporting */
1825
1852
pl_error_context .callback = plperl_exec_callback ;
@@ -1928,23 +1955,35 @@ validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
1928
1955
1929
1956
/* Otherwise, unlink the obsoleted entry from the hashtable ... */
1930
1957
proc_ptr -> proc_ptr = NULL ;
1931
- /* ... and throw it away */
1932
- if (prodesc -> reference )
1933
- {
1934
- plperl_interp_desc * oldinterp = plperl_active_interp ;
1935
-
1936
- activate_interpreter (prodesc -> interp );
1937
- SvREFCNT_dec (prodesc -> reference );
1938
- activate_interpreter (oldinterp );
1939
- }
1940
- free (prodesc -> proname );
1941
- free (prodesc );
1958
+ /* ... and release the corresponding refcount, probably deleting it */
1959
+ decrement_prodesc_refcount (prodesc );
1942
1960
}
1943
1961
1944
1962
return false;
1945
1963
}
1946
1964
1947
1965
1966
+ static void
1967
+ free_plperl_function (plperl_proc_desc * prodesc )
1968
+ {
1969
+ Assert (prodesc -> refcount <=0 );
1970
+ /* Release CODE reference, if we have one, from the appropriate interp */
1971
+ if (prodesc -> reference )
1972
+ {
1973
+ plperl_interp_desc * oldinterp = plperl_active_interp ;
1974
+
1975
+ activate_interpreter (prodesc -> interp );
1976
+ SvREFCNT_dec (prodesc -> reference );
1977
+ activate_interpreter (oldinterp );
1978
+ }
1979
+ /* Get rid of what we conveniently can of our own structs */
1980
+ /* (FmgrInfo subsidiary info will get leaked ...) */
1981
+ if (prodesc -> proname )
1982
+ free (prodesc -> proname );
1983
+ free (prodesc );
1984
+ }
1985
+
1986
+
1948
1987
static plperl_proc_desc *
1949
1988
compile_plperl_function (Oid fn_oid ,bool is_trigger )
1950
1989
{
@@ -2015,12 +2054,17 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2015
2054
ereport (ERROR ,
2016
2055
(errcode (ERRCODE_OUT_OF_MEMORY ),
2017
2056
errmsg ("out of memory" )));
2057
+ /* Initialize all fields to 0 so free_plperl_function is safe */
2018
2058
MemSet (prodesc ,0 ,sizeof (plperl_proc_desc ));
2059
+
2019
2060
prodesc -> proname = strdup (NameStr (procStruct -> proname ));
2020
2061
if (prodesc -> proname == NULL )
2062
+ {
2063
+ free_plperl_function (prodesc );
2021
2064
ereport (ERROR ,
2022
2065
(errcode (ERRCODE_OUT_OF_MEMORY ),
2023
2066
errmsg ("out of memory" )));
2067
+ }
2024
2068
prodesc -> fn_xmin = HeapTupleHeaderGetXmin (procTup -> t_data );
2025
2069
prodesc -> fn_tid = procTup -> t_self ;
2026
2070
@@ -2035,8 +2079,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2035
2079
ObjectIdGetDatum (procStruct -> prolang ));
2036
2080
if (!HeapTupleIsValid (langTup ))
2037
2081
{
2038
- free (prodesc -> proname );
2039
- free (prodesc );
2082
+ free_plperl_function (prodesc );
2040
2083
elog (ERROR ,"cache lookup failed for language %u" ,
2041
2084
procStruct -> prolang );
2042
2085
}
@@ -2055,8 +2098,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2055
2098
ObjectIdGetDatum (procStruct -> prorettype ));
2056
2099
if (!HeapTupleIsValid (typeTup ))
2057
2100
{
2058
- free (prodesc -> proname );
2059
- free (prodesc );
2101
+ free_plperl_function (prodesc );
2060
2102
elog (ERROR ,"cache lookup failed for type %u" ,
2061
2103
procStruct -> prorettype );
2062
2104
}
@@ -2070,17 +2112,15 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2070
2112
/* okay */ ;
2071
2113
else if (procStruct -> prorettype == TRIGGEROID )
2072
2114
{
2073
- free (prodesc -> proname );
2074
- free (prodesc );
2115
+ free_plperl_function (prodesc );
2075
2116
ereport (ERROR ,
2076
2117
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2077
2118
errmsg ("trigger functions can only be called "
2078
2119
"as triggers" )));
2079
2120
}
2080
2121
else
2081
2122
{
2082
- free (prodesc -> proname );
2083
- free (prodesc );
2123
+ free_plperl_function (prodesc );
2084
2124
ereport (ERROR ,
2085
2125
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2086
2126
errmsg ("PL/Perl functions cannot return type %s" ,
@@ -2115,8 +2155,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2115
2155
ObjectIdGetDatum (procStruct -> proargtypes .values [i ]));
2116
2156
if (!HeapTupleIsValid (typeTup ))
2117
2157
{
2118
- free (prodesc -> proname );
2119
- free (prodesc );
2158
+ free_plperl_function (prodesc );
2120
2159
elog (ERROR ,"cache lookup failed for type %u" ,
2121
2160
procStruct -> proargtypes .values [i ]);
2122
2161
}
@@ -2125,8 +2164,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2125
2164
/* Disallow pseudotype argument */
2126
2165
if (typeStruct -> typtype == TYPTYPE_PSEUDO )
2127
2166
{
2128
- free (prodesc -> proname );
2129
- free (prodesc );
2167
+ free_plperl_function (prodesc );
2130
2168
ereport (ERROR ,
2131
2169
(errcode (ERRCODE_FEATURE_NOT_SUPPORTED ),
2132
2170
errmsg ("PL/Perl functions cannot accept type %s" ,
@@ -2172,8 +2210,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2172
2210
pfree (proc_source );
2173
2211
if (!prodesc -> reference )/* can this happen? */
2174
2212
{
2175
- free (prodesc -> proname );
2176
- free (prodesc );
2213
+ free_plperl_function (prodesc );
2177
2214
elog (ERROR ,"could not create PL/Perl internal procedure" );
2178
2215
}
2179
2216
@@ -2185,6 +2222,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
2185
2222
proc_ptr = hash_search (plperl_proc_hash ,& proc_key ,
2186
2223
HASH_ENTER ,NULL );
2187
2224
proc_ptr -> proc_ptr = prodesc ;
2225
+ increment_prodesc_refcount (prodesc );
2188
2226
}
2189
2227
2190
2228
/* restore previous error callback */