@@ -58,8 +58,8 @@ PG_MODULE_MAGIC;
58
58
59
59
60
60
/**********************************************************************
61
- * Information associated with a Perl interpreter. We have one interpreter
62
- * that is used for all plperlu (untrusted) functions. For plperl (trusted)
61
+ * Information associated with a Perl interpreter. We have one interpreter
62
+ * that is used for all plperlu (untrusted) functions. For plperl (trusted)
63
63
* functions, there is a separate interpreter for each effective SQL userid.
64
64
* (This is needed to ensure that an unprivileged user can't inject Perl code
65
65
* that'll be executed with the privileges of some other SQL user.)
@@ -83,9 +83,9 @@ PG_MODULE_MAGIC;
83
83
**********************************************************************/
84
84
typedef struct plperl_interp_desc
85
85
{
86
- Oid user_id ; /* Hash key (must be first!) */
87
- PerlInterpreter * interp ; /* The interpreter */
88
- HTAB * query_hash ; /* plperl_query_entry structs */
86
+ Oid user_id ; /* Hash key (must be first!) */
87
+ PerlInterpreter * interp ; /* The interpreter */
88
+ HTAB * query_hash ; /* plperl_query_entry structs */
89
89
} plperl_interp_desc ;
90
90
91
91
@@ -97,7 +97,7 @@ typedef struct plperl_proc_desc
97
97
char * proname ; /* user name of procedure */
98
98
TransactionId fn_xmin ;
99
99
ItemPointerData fn_tid ;
100
- plperl_interp_desc * interp ; /* interpreter it's created in */
100
+ plperl_interp_desc * interp ; /* interpreter it's created in */
101
101
bool fn_readonly ;
102
102
bool lanpltrusted ;
103
103
bool fn_retistuple ; /* true, if function returns tuple */
@@ -127,18 +127,19 @@ typedef struct plperl_proc_desc
127
127
**********************************************************************/
128
128
typedef struct plperl_proc_key
129
129
{
130
- Oid proc_id ; /* Function OID */
130
+ Oid proc_id ; /* Function OID */
131
+
131
132
/*
132
133
* is_trigger is really a bool, but declare as Oid to ensure this struct
133
134
* contains no padding
134
135
*/
135
- Oid is_trigger ; /* is it a trigger function? */
136
- Oid user_id ; /* User calling the function, or 0 */
136
+ Oid is_trigger ; /* is it a trigger function? */
137
+ Oid user_id ; /* User calling the function, or 0 */
137
138
} plperl_proc_key ;
138
139
139
140
typedef struct plperl_proc_ptr
140
141
{
141
- plperl_proc_key proc_key ; /* Hash key (must be first!) */
142
+ plperl_proc_key proc_key ; /* Hash key (must be first!) */
142
143
plperl_proc_desc * proc_ptr ;
143
144
} plperl_proc_ptr ;
144
145
@@ -184,6 +185,7 @@ typedef struct plperl_query_entry
184
185
static HTAB * plperl_interp_hash = NULL ;
185
186
static HTAB * plperl_proc_hash = NULL ;
186
187
static plperl_interp_desc * plperl_active_interp = NULL ;
188
+
187
189
/* If we have an unassigned "held" interpreter, it's stored here */
188
190
static PerlInterpreter * plperl_held_interp = NULL ;
189
191
@@ -227,7 +229,8 @@ static char *hek2cstr(HE *he);
227
229
static SV * * hv_store_string (HV * hv , const char * key , SV * val );
228
230
static SV * * hv_fetch_string (HV * hv , const char * key );
229
231
static void plperl_create_sub (plperl_proc_desc * desc , char * s , Oid fn_oid );
230
- static SV * plperl_call_perl_func (plperl_proc_desc * desc , FunctionCallInfo fcinfo );
232
+ static SV * plperl_call_perl_func (plperl_proc_desc * desc ,
233
+ FunctionCallInfo fcinfo );
231
234
static void plperl_compile_callback (void * arg );
232
235
static void plperl_exec_callback (void * arg );
233
236
static void plperl_inline_callback (void * arg );
@@ -245,31 +248,32 @@ static char *setlocale_perl(int category, char *locale);
245
248
static char *
246
249
hek2cstr (HE * he )
247
250
{
248
- /*
249
- * Unfortunately, while HeUTF8 is true for most things > 256, for
250
- * values 128..255 it's not, but perl will treat them as
251
- * unicode code points if the utf8 flag is not set ( see
252
- * The "Unicode Bug" in perldoc perlunicode for more)
251
+ /*-------------------------
252
+ * Unfortunately, while HeUTF8 is true for most things > 256, for values
253
+ * 128..255 it's not, but perl will treat them as unicode code points if
254
+ * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
255
+ * for more)
253
256
*
254
257
* So if we did the expected:
255
- * if (HeUTF8(he))
256
- * utf_u2e(key...);
257
- * else // must be ascii
258
- * return HePV(he);
258
+ * if (HeUTF8(he))
259
+ * utf_u2e(key...);
260
+ * else // must be ascii
261
+ * return HePV(he);
259
262
* we won't match columns with codepoints from 128..255
260
263
*
261
- * For a more concrete example given a column with the
262
- * name of the unicode codepoint U+00ae (registered sign)
263
- * and a UTF8 database and the perl return_next {
264
- * "\N{U+00ae}=>'text } would always fail as heUTF8
265
- * returns 0 and HePV() would give us a char * with 1 byte
266
- * contains the decimal value 174
264
+ * For a more concrete example given a column with the name of the unicode
265
+ * codepoint U+00ae (registered sign) and a UTF8 database and the perl
266
+ * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
267
+ * 0 and HePV() would give us a char * with 1 byte contains the decimal
268
+ * value 174
267
269
*
268
- * Perl has the brains to know when it should utf8 encode
269
- * 174 properly, so here we force it into an SV so that
270
- * perl will figure it out and do the right thing
270
+ * Perl has the brains to know when it should utf8 encode 174 properly, so
271
+ * here we force it into an SV so that perl will figure it out and do the
272
+ * right thing
273
+ *-------------------------
271
274
*/
272
- SV * sv = HeSVKEY_force (he );
275
+ SV * sv = HeSVKEY_force (he );
276
+
273
277
if (HeUTF8 (he ))
274
278
SvUTF8_on (sv );
275
279
return sv2cstr (sv );
@@ -547,6 +551,7 @@ select_perl_context(bool trusted)
547
551
else
548
552
{
549
553
#ifdef MULTIPLICITY
554
+
550
555
/*
551
556
* plperl_init_interp will change Perl's idea of the active
552
557
* interpreter. Reset plperl_active_interp temporarily, so that if we
@@ -675,7 +680,7 @@ plperl_init_interp(void)
675
680
STMT_START { \
676
681
if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
677
682
} STMT_END
678
- #endif /* WIN32 */
683
+ #endif /* WIN32 */
679
684
680
685
if (plperl_on_init && * plperl_on_init )
681
686
{
@@ -685,12 +690,12 @@ plperl_init_interp(void)
685
690
686
691
/*
687
692
* The perl API docs state that PERL_SYS_INIT3 should be called before
688
- * allocating interpreters. Unfortunately, on some platforms this fails
689
- * in the Perl_do_taint() routine, which is called when the platform is
690
- * using the system's malloc() instead of perl's own. Other platforms,
691
- * notably Windows, fail if PERL_SYS_INIT3 is not called. So we call it
692
- * if it's available, unless perl is using the system malloc(), which is
693
- * true when MYMALLOC is set.
693
+ * allocating interpreters. Unfortunately, on some platforms this fails in
694
+ * the Perl_do_taint() routine, which is called when the platform is using
695
+ * the system's malloc() instead of perl's own. Other platforms, notably
696
+ * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
697
+ * available, unless perl is using the system malloc(), which is true when
698
+ * MYMALLOC is set.
694
699
*/
695
700
#if defined(PERL_SYS_INIT3 ) && !defined(MYMALLOC )
696
701
{
@@ -859,8 +864,8 @@ plperl_trusted_init(void)
859
864
errcontext ("while executing PLC_TRUSTED" )));
860
865
861
866
/*
862
- * Force loading of utf8 module now to prevent errors that can arise
863
- * from the regex code later trying to load utf8 modules. See
867
+ * Force loading of utf8 module now to prevent errors that can arise from
868
+ * the regex code later trying to load utf8 modules. See
864
869
* http://rt.perl.org/rt3/Ticket/Display.html?id=47576
865
870
*/
866
871
eval_pv ("my $a=chr(0x100); return $a =~ /\\xa9/i" , FALSE);
@@ -956,7 +961,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
956
961
{
957
962
TupleDesc td = attinmeta -> tupdesc ;
958
963
char * * values ;
959
- HE * he ;
964
+ HE * he ;
960
965
HeapTuple tup ;
961
966
int i ;
962
967
@@ -965,9 +970,9 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
965
970
hv_iterinit (perlhash );
966
971
while ((he = hv_iternext (perlhash )))
967
972
{
968
- SV * val = HeVAL (he );
969
- char * key = hek2cstr (he );
970
- int attn = SPI_fnumber (td , key );
973
+ SV * val = HeVAL (he );
974
+ char * key = hek2cstr (he );
975
+ int attn = SPI_fnumber (td , key );
971
976
972
977
if (attn <= 0 || td -> attrs [attn - 1 ]-> attisdropped )
973
978
ereport (ERROR ,
@@ -985,7 +990,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
985
990
986
991
tup = BuildTupleFromCStrings (attinmeta , values );
987
992
988
- for (i = 0 ; i < td -> natts ; i ++ )
993
+ for (i = 0 ; i < td -> natts ; i ++ )
989
994
{
990
995
if (values [i ])
991
996
pfree (values [i ]);
@@ -1173,8 +1178,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
1173
1178
Oid typioparam ;
1174
1179
int32 atttypmod ;
1175
1180
FmgrInfo finfo ;
1176
- SV * val = HeVAL (he );
1177
- char * key = hek2cstr (he );
1181
+ SV * val = HeVAL (he );
1182
+ char * key = hek2cstr (he );
1178
1183
int attn = SPI_fnumber (tupdesc , key );
1179
1184
1180
1185
if (attn <= 0 || tupdesc -> attrs [attn - 1 ]-> attisdropped )
@@ -1189,7 +1194,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
1189
1194
atttypmod = tupdesc -> attrs [attn - 1 ]-> atttypmod ;
1190
1195
if (SvOK (val ))
1191
1196
{
1192
- char * str = sv2cstr (val );
1197
+ char * str = sv2cstr (val );
1198
+
1193
1199
modvalues [slotsused ] = InputFunctionCall (& finfo ,
1194
1200
str ,
1195
1201
typioparam ,
@@ -1452,12 +1458,13 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
1452
1458
EXTEND (SP , 4 );
1453
1459
PUSHs (sv_2mortal (cstr2sv (subname )));
1454
1460
PUSHs (sv_2mortal (newRV_noinc ((SV * ) pragma_hv )));
1455
- /*
1456
- * Use 'false' for $prolog in mkfunc, which is kept for compatibility
1457
- * in case a module such as PostgreSQL::PLPerl::NYTprof replaces
1458
- * the function compiler.
1461
+
1462
+ /*
1463
+ * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
1464
+ * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
1465
+ * compiler.
1459
1466
*/
1460
- PUSHs (& PL_sv_no );
1467
+ PUSHs (& PL_sv_no );
1461
1468
PUSHs (sv_2mortal (cstr2sv (s )));
1462
1469
PUTBACK ;
1463
1470
@@ -1609,15 +1616,17 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
1609
1616
SV * td )
1610
1617
{
1611
1618
dSP ;
1612
- SV * retval , * TDsv ;
1613
- int i , count ;
1619
+ SV * retval ,
1620
+ * TDsv ;
1621
+ int i ,
1622
+ count ;
1614
1623
Trigger * tg_trigger = ((TriggerData * ) fcinfo -> context )-> tg_trigger ;
1615
1624
1616
1625
ENTER ;
1617
1626
SAVETMPS ;
1618
1627
1619
1628
TDsv = get_sv ("_TD" , GV_ADD );
1620
- SAVESPTR (TDsv ); /* local $_TD */
1629
+ SAVESPTR (TDsv ); /* local $_TD */
1621
1630
sv_setsv (TDsv , td );
1622
1631
1623
1632
PUSHMARK (sp );
@@ -1796,7 +1805,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
1796
1805
else
1797
1806
{
1798
1807
/* Return a perl string converted to a Datum */
1799
- char * str ;
1808
+ char * str ;
1800
1809
1801
1810
if (prodesc -> fn_retisarray && SvROK (perlret ) &&
1802
1811
SvTYPE (SvRV (perlret )) == SVt_PVAV )
@@ -2500,7 +2509,7 @@ plperl_return_next(SV *sv)
2500
2509
2501
2510
if (SvOK (sv ))
2502
2511
{
2503
- char * str ;
2512
+ char * str ;
2504
2513
2505
2514
if (prodesc -> fn_retisarray && SvROK (sv ) &&
2506
2515
SvTYPE (SvRV (sv )) == SVt_PVAV )
@@ -2754,7 +2763,7 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
2754
2763
typInput ,
2755
2764
typIOParam ;
2756
2765
int32 typmod ;
2757
- char * typstr ;
2766
+ char * typstr ;
2758
2767
2759
2768
typstr = sv2cstr (argv [i ]);
2760
2769
parseTypeString (typstr , & typId , & typmod );
@@ -2922,7 +2931,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
2922
2931
{
2923
2932
if (SvOK (argv [i ]))
2924
2933
{
2925
- char * str = sv2cstr (argv [i ]);
2934
+ char * str = sv2cstr (argv [i ]);
2935
+
2926
2936
argvalues [i ] = InputFunctionCall (& qdesc -> arginfuncs [i ],
2927
2937
str ,
2928
2938
qdesc -> argtypioparams [i ],
@@ -3057,7 +3067,8 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
3057
3067
{
3058
3068
if (SvOK (argv [i ]))
3059
3069
{
3060
- char * str = sv2cstr (argv [i ]);
3070
+ char * str = sv2cstr (argv [i ]);
3071
+
3061
3072
argvalues [i ] = InputFunctionCall (& qdesc -> arginfuncs [i ],
3062
3073
str ,
3063
3074
qdesc -> argtypioparams [i ],
@@ -3177,10 +3188,12 @@ static SV **
3177
3188
hv_store_string (HV * hv , const char * key , SV * val )
3178
3189
{
3179
3190
int32 hlen ;
3180
- char * hkey ;
3181
- SV * * ret ;
3191
+ char * hkey ;
3192
+ SV * * ret ;
3182
3193
3183
- hkey = (char * )pg_do_encoding_conversion ((unsigned char * )key , strlen (key ), GetDatabaseEncoding (), PG_UTF8 );
3194
+ hkey = (char * )
3195
+ pg_do_encoding_conversion ((unsigned char * ) key , strlen (key ),
3196
+ GetDatabaseEncoding (), PG_UTF8 );
3184
3197
3185
3198
/*
3186
3199
* This seems nowhere documented, but under Perl 5.8.0 and up, hv_store()
@@ -3205,16 +3218,18 @@ static SV **
3205
3218
hv_fetch_string (HV * hv , const char * key )
3206
3219
{
3207
3220
int32 hlen ;
3208
- char * hkey ;
3209
- SV * * ret ;
3221
+ char * hkey ;
3222
+ SV * * ret ;
3210
3223
3211
- hkey = (char * )pg_do_encoding_conversion ((unsigned char * )key , strlen (key ), GetDatabaseEncoding (), PG_UTF8 );
3224
+ hkey = (char * )
3225
+ pg_do_encoding_conversion ((unsigned char * ) key , strlen (key ),
3226
+ GetDatabaseEncoding (), PG_UTF8 );
3212
3227
3213
3228
/* See notes in hv_store_string */
3214
3229
hlen = - strlen (hkey );
3215
3230
ret = hv_fetch (hv , hkey , hlen , 0 );
3216
3231
3217
- if (hkey != key )
3232
+ if (hkey != key )
3218
3233
pfree (hkey );
3219
3234
3220
3235
return ret ;
0 commit comments