diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index f400050f38d..24b8f98cf1e 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -2116,274 +2116,298 @@ plperlu_validator(PG_FUNCTION_ARGS) * supplied in s, and returns a reference to it */ static void plperl_create_sub(plperl_proc_desc *prodesc, const char *s, Oid fn_oid) { dTHX; dSP; char subname[NAMEDATALEN + 40]; HV *pragma_hv = newHV(); SV *subref = NULL; int count; sprintf(subname, "%s__%u", prodesc->proname, fn_oid); if (plperl_use_strict) hv_store_string(pragma_hv, "strict", (SV *) newAV()); ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 4); PUSHs(sv_2mortal(cstr2sv(subname))); PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv))); /* * Use 'false' for $prolog in mkfunc, which is kept for compatibility in * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function * compiler. */ PUSHs(&PL_sv_no); PUSHs(sv_2mortal(cstr2sv(s))); PUTBACK; /* * G_KEEPERR seems to be needed here, else we don't recognize compile * errors properly. Perhaps it's because there's another level of eval * inside mksafefunc? */ count = call_pv("PostgreSQL::InServer::mkfunc", G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; if (count == 1) { SV *sub_rv = (SV *) POPs; if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV) { subref = newRV_inc(SvRV(sub_rv)); } } PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); if (!subref) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("didn't get a CODE reference from compiling function \"%s\"", prodesc->proname))); prodesc->reference = subref; return; } /********************************************************************** * plperl_init_shared_libs() - **********************************************************************/ static void plperl_init_shared_libs(pTHX) { char *file = __FILE__; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); newXS("PostgreSQL::InServer::Util::bootstrap", boot_PostgreSQL__InServer__Util, file); /* newXS for...::SPI::bootstrap is in select_perl_context() */ } static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) { dTHX; dSP; SV *retval; int i; int count; Oid *argtypes = NULL; int nargs = 0; + HV *hv; // hash + SV *FNsv; // scalar reference to the hash + SV *svFN; // local reference to the hash + ENTER; SAVETMPS; + /* Give functions some metadata about what's going on in $_FN (Similar to $_TD for triggers) */ + + FNsv = get_sv("main::_FN", GV_ADD); + if (!FNsv) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("couldn't fetch $_FN"))); + + hv = newHV(); // create new hash + hv_store_string(hv, "name", cstr2sv(desc->proname)); + + save_item(FNsv); /* local $_FN */ + + sv_upgrade(FNsv, SVt_RV); + SvRV_set(FNsv, (SV*)hv); + SvROK_on(FNsv); + + svFN = newRV_noinc((SV *) hv); // reference to the new hash + sv_setsv(FNsv, svFN); + PUSHMARK(SP); EXTEND(sp, desc->nargs); /* Get signature for true functions; inline blocks have no args. */ if (fcinfo->flinfo->fn_oid) get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs); Assert(nargs == desc->nargs); for (i = 0; i < desc->nargs; i++) { if (fcinfo->args[i].isnull) PUSHs(&PL_sv_undef); else if (desc->arg_is_rowtype[i]) { SV *sv = plperl_hash_from_datum(fcinfo->args[i].value); PUSHs(sv_2mortal(sv)); } else { SV *sv; Oid funcid; if (OidIsValid(desc->arg_arraytype[i])) sv = plperl_ref_from_pg_array(fcinfo->args[i].value, desc->arg_arraytype[i]); else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes))) sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->args[i].value)); else { char *tmp; tmp = OutputFunctionCall(&(desc->arg_out_func[i]), fcinfo->args[i].value); sv = cstr2sv(tmp); pfree(tmp); } PUSHs(sv_2mortal(sv)); } } PUTBACK; /* Do NOT use G_KEEPERR here */ count = call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("didn't get a return item from function"))); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; /* XXX need to find a way to determine a better errcode here */ ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); } retval = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; return retval; } static SV * plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) { dTHX; dSP; SV *retval, *TDsv; int i, count; Trigger *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger; ENTER; SAVETMPS; TDsv = get_sv("main::_TD", 0); if (!TDsv) ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("couldn't fetch $_TD"))); save_item(TDsv); /* local $_TD */ sv_setsv(TDsv, td); PUSHMARK(sp); EXTEND(sp, tg_trigger->tgnargs); for (i = 0; i < tg_trigger->tgnargs; i++) PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i]))); PUTBACK; /* Do NOT use G_KEEPERR here */ count = call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("didn't get a return item from trigger function"))); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; /* XXX need to find a way to determine a better errcode here */ ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); } retval = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; return retval; } static void plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) { dTHX; dSP; SV *retval, *TDsv; int count; ENTER; SAVETMPS; TDsv = get_sv("main::_TD", 0); if (!TDsv) ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("couldn't fetch $_TD"))); save_item(TDsv); /* local $_TD */ sv_setsv(TDsv, td); PUSHMARK(sp);