Re: plperl fixes

Previous patch removed from the queue.

Your patch has been added to the PostgreSQL unapplied patches list at:

http://momjian.postgresql.org/cgi-bin/pgpatches

I will try to apply it within the next 48 hours.

---------------------------------------------------------------------------

Andrew Dunstan wrote:
>
> The attached patch, which incorporates the previous one sent and
> currently unapplied regarding spi_internal.c, makes some additional
> fixes relating to return types, and also contains the fix for
> preventing the use of insecure versions of Safe.pm.
>
> There is one remaing return case that does not appear to work, namely
> return of a composite directly in a select, i.e. if foo returns some
> composite type, 'select * from foo()' works but 'select foo()' doesn't.
> We will either fix that or document it as a limitation.
>
> The function plperl_func_handler is a mess - I will try to get it
> cleaned up (and split up) in a subsequent patch, time permitting.
>
> Also, reiterating previous advice - this changes slightly the API for
> spi_exec_query - the returned object has either 2 or 3 members: 'status'
> (string) and 'proceesed' (int,- number of rows) and, if rows are
> returned, 'rows' (array of tuple hashes).
>
> cheers
>
> andrew

> Index: plperl.c
> ===================================================================
> RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
> retrieving revision 1.45
> diff -c -w -r1.45 plperl.c
> *** plperl.c 1 Jul 2004 20:50:22 -0000 1.45
> --- plperl.c 7 Jul 2004 15:35:35 -0000
> ***************
> *** 80,85 ****
> --- 80,86 ----
> CommandId fn_cmin;
> bool lanpltrusted;
> bool fn_retistuple; /* true, if function returns tuple */
> + bool fn_retisset; /*true, if function returns set*/
> Oid ret_oid; /* Oid of returning type */
> FmgrInfo result_in_func;
> Oid result_typioparam;
> ***************
> *** 95,105 ****
> * Global data
> **********************************************************************/
> static int plperl_firstcall = 1;
> static PerlInterpreter *plperl_interp = NULL;
> static HV *plperl_proc_hash = NULL;
> ! AV *g_row_keys = NULL;
> ! AV *g_column_keys = NULL;
> ! int g_attr_num = 0;
>
> /**********************************************************************
> * Forward declarations
> --- 96,108 ----
> * Global data
> **********************************************************************/
> static int plperl_firstcall = 1;
> + static bool plperl_safe_init_done = false;
> static PerlInterpreter *plperl_interp = NULL;
> static HV *plperl_proc_hash = NULL;
> ! static AV *g_row_keys = NULL;
> ! static AV *g_column_keys = NULL;
> ! static SV *srf_perlret=NULL; /*keep returned value*/
> ! static int g_attr_num = 0;
>
> /**********************************************************************
> * Forward declarations
> ***************
> *** 215,225 ****
> * no commas between the next lines please. They are supposed to be
> * one string
> */
> ! "require Safe; SPI::bootstrap(); use vars qw(%_SHARED);"
> ! "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
> ! "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
> ! "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
> ! "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
> "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
> };
>
> --- 218,224 ----
> * no commas between the next lines please. They are supposed to be
> * one string
> */
> ! "SPI::bootstrap(); use vars qw(%_SHARED);"
> "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
> };
>
> ***************
> *** 238,243 ****
> --- 237,277 ----
>
> }
>
> +
> + static void
> + plperl_safe_init(void)
> + {
> + static char *safe_module =
> + "require Safe; $Safe::VERSION";
> +
> + static char * safe_ok =
> + "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
> + "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
> + "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
> + "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
> + ;
> +
> + static char * safe_bad =
> + "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
> + "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
> + "$PLContainer->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
> + "sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
> + "elog(ERROR,'trusted perl functions disabled - please upgrade perl Safe module to at least 2.09');}]); }"
> + ;
> +
> + SV * res;
> +
> + float safe_version;
> +
> + res = eval_pv(safe_module,FALSE); /* TRUE = croak if failure */
> +
> + safe_version = SvNV(res);
> +
> + eval_pv((safe_version < 2.09 ? safe_bad : safe_ok),FALSE);
> +
> + plperl_safe_init_done = true;
> + }
> +
> /**********************************************************************
> * turn a tuple into a hash expression and add it to a list
> **********************************************************************/
> ***************
> *** 596,601 ****
> --- 630,638 ----
> SV *subref;
> int count;
>
> + if(trusted && !plperl_safe_init_done)
> + plperl_safe_init();
> +
> ENTER;
> SAVETMPS;
> PUSHMARK(SP);
> ***************
> *** 839,853 ****
> /* Find or compile the function */
> prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
> /************************************************************
> ! * Call the Perl function
> ************************************************************/
> perlret = plperl_call_perl_func(prodesc, fcinfo);
> ! if (prodesc->fn_retistuple && SRF_IS_FIRSTCALL())
> {
>
> if (SvTYPE(perlret) != SVt_RV)
> ! elog(ERROR, "plperl: this function must return a reference");
> ! g_column_keys = newAV();
> }
>
> /************************************************************
> --- 876,897 ----
> /* Find or compile the function */
> prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
> /************************************************************
> ! * Call the Perl function if not returning set
> ************************************************************/
> + if (!prodesc->fn_retisset)
> perlret = plperl_call_perl_func(prodesc, fcinfo);
> ! else
> {
> + if (SRF_IS_FIRSTCALL()) /*call function only once*/
> + srf_perlret = plperl_call_perl_func(prodesc, fcinfo);
> + perlret = srf_perlret;
> + }
>
> + if (prodesc->fn_retisset && SRF_IS_FIRSTCALL())
> + {
> + if (prodesc->fn_retistuple) g_column_keys = newAV();
> if (SvTYPE(perlret) != SVt_RV)
> ! elog(ERROR, "plperl: set-returning function must return reference");
> }
>
> /************************************************************
> ***************
> *** 882,895 ****
> char **values = NULL;
> ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
>
> ! if (!rsinfo)
> ereport(ERROR,
> (errcode(ERRCODE_SYNTAX_ERROR),
> errmsg("returning a composite type is not allowed in this context"),
> errhint("This function is intended for use in the FROM clause.")));
>
> if (SvTYPE(perlret) != SVt_RV)
> ! elog(ERROR, "plperl: this function must return a reference");
>
> isset = plperl_is_set(perlret);
>
> --- 926,940 ----
> char **values = NULL;
> ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
>
> ! if (prodesc->fn_retisset && !rsinfo)
> ereport(ERROR,
> (errcode(ERRCODE_SYNTAX_ERROR),
> errmsg("returning a composite type is not allowed in this context"),
> errhint("This function is intended for use in the FROM clause.")));
>
> if (SvTYPE(perlret) != SVt_RV)
> ! elog(ERROR, "plperl: composite-returning function must return a reference");
> !
>
> isset = plperl_is_set(perlret);
>
> ***************
> *** 997,1002 ****
> --- 1042,1094 ----
> SRF_RETURN_DONE(funcctx);
> }
> }
> + else if (prodesc->fn_retisset)
> + {
> + FuncCallContext *funcctx;
> +
> + if (SRF_IS_FIRSTCALL())
> + {
> + MemoryContext oldcontext;
> + int i;
> +
> + funcctx = SRF_FIRSTCALL_INIT();
> + oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
> +
> + if(SvTYPE(SvRV(perlret))!=SVt_PVAV) elog(ERROR, "plperl: set-returning function must return reference to array");
> + else funcctx->max_calls = av_len((AV*)SvRV(perlret))+1;
> + }
> +
> + funcctx = SRF_PERCALL_SETUP();
> +
> + if (funcctx->call_cntr < funcctx->max_calls)
> + {
> + Datum result;
> + AV* array;
> + SV** svp;
> + int i;
> +
> + array = (AV*)SvRV(perlret);
> + svp = av_fetch(array, funcctx->call_cntr, FALSE);
> +
> + if (SvTYPE(*svp) != SVt_NULL)
> + result = FunctionCall3(&prodesc->result_in_func,
> + PointerGetDatum(SvPV(*svp, PL_na)),
> + ObjectIdGetDatum(prodesc->result_typioparam),
> + Int32GetDatum(-1));
> + else
> + {
> + fcinfo->isnull = true;
> + result = (Datum) 0;
> + }
> + SRF_RETURN_NEXT(funcctx, result);
> + fcinfo->isnull = false;
> + }
> + else
> + {
> + if (perlret) SvREFCNT_dec(perlret);
> + SRF_RETURN_DONE(funcctx);
> + }
> + }
> else if (! fcinfo->isnull)
> {
> retval = FunctionCall3(&prodesc->result_in_func,
> ***************
> *** 1248,1253 ****
> --- 1340,1347 ----
> format_type_be(procStruct->prorettype))));
> }
> }
> +
> + prodesc->fn_retisset = procStruct->proretset; /*true, if function returns set*/
>
> if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
> {
> Index: spi_internal.c
> ===================================================================
> RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/spi_internal.c,v
> retrieving revision 1.1
> diff -c -w -r1.1 spi_internal.c
> *** spi_internal.c 1 Jul 2004 20:50:22 -0000 1.1
> --- spi_internal.c 7 Jul 2004 15:35:35 -0000
> ***************
> *** 82,123 ****
> * Get the attributes value
> ************************************************************/
> attdata = SPI_getvalue(tuple, tupdesc, i+1);
> hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
> }
> return array;
> }
>
> static HV*
> ! plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int rows, int status)
> {
>
> HV *result;
> int i;
>
> result = newHV();
>
> if (status == SPI_OK_UTILITY)
> {
> hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
> ! hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
> }
> else if (status != SPI_OK_SELECT)
> {
> hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
> ! hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
> }
> else
> {
> ! if (rows)
> {
> - char* key=palloc(sizeof(int));
> HV *row;
> ! for (i = 0; i < rows; i++)
> {
> row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
> ! sprintf(key, "%i", i);
> ! hv_store(result, key, strlen(key), newRV_noinc((SV*)row), 0);
> }
> SPI_freetuptable(tuptable);
> }
> }
> --- 82,129 ----
> * Get the attributes value
> ************************************************************/
> attdata = SPI_getvalue(tuple, tupdesc, i+1);
> + if(attdata)
> hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
> + else
> + hv_store(array, attname, strlen(attname), newSVpv("undef",0), 0);
> }
> return array;
> }
>
> static HV*
> ! plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, int status)
> {
>
> HV *result;
> + AV *rows;
> int i;
>
> result = newHV();
> + rows = newAV();
>
> if (status == SPI_OK_UTILITY)
> {
> hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
> ! hv_store(result, "processed", strlen("processed"), newSViv(processed), 0);
> }
> else if (status != SPI_OK_SELECT)
> {
> hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
> ! hv_store(result, "processed", strlen("processed"), newSViv(processed), 0);
> }
> else
> {
> ! hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
> ! hv_store(result, "processed", strlen("processed"), newSViv(processed), 0);
> ! if (processed)
> {
> HV *row;
> ! for (i = 0; i < processed; i++)
> {
> row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
> ! av_store(rows, i, newRV_noinc((SV*)row));
> }
> + hv_store(result, "rows", strlen("rows"), newRV_noinc((SV*)rows), 0);
> SPI_freetuptable(tuptable);
> }
> }
> Index: spi_internal.h
> ===================================================================
> RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/spi_internal.h,v
> retrieving revision 1.1
> diff -c -w -r1.1 spi_internal.h
> *** spi_internal.h 1 Jul 2004 20:50:22 -0000 1.1
> --- spi_internal.h 7 Jul 2004 15:35:35 -0000
> ***************
> *** 1,6 ****
> --- 1,7 ----
> #include "EXTERN.h"
> #include "perl.h"
> #include "XSUB.h"
> + #include "ppport.h"
>
> int spi_DEBUG(void);
>

>
> ---------------------------(end of broadcast)---------------------------
> TIP 6: Have you searched our list archives?
>
> http://archives.postgresql.org

--
Bruce Momjian | http://candle.pha.pa.us
pgman(at)candle(dot)pha(dot)pa(dot)us | (610) 359-1001
+ If your life is a hard drive, | 13 Roberts Road
+ Christ can be your backup. | Newtown Square, Pennsylvania 19073