pl/pgperl Patch for adding $_FN detail just like triggers have for $_TD
Hi Hackers!
This would be version v1 of this feature
Basically, the subject says it all: pl/pgperl Patch for being able to
tell which function you're in.
This is a hashref so it will be possible to populate new and exciting
other details in the future as the need arises
This also greatly improves logging capabilities for things like catching
warnings, Because as it stands right now, there's no information that
can assist with locating the source of a warning like this:
# tail -f /var/log/postgresql.log
******* GOT A WARNING - Use of uninitialized value $prefix in
concatenation (.) or string at (eval 531) line 48.
Now, with $_FN you can do this:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
use warnings;
use strict;
use Data::Dumper;
$SIG{__WARN__} = sub {
elog(NOTICE, Dumper($_FN));
print STDERR "In Function: $_FN->{name}: $_[0]\n";
};
my $a;
print "$a"; # uninit!
return undef;
$function$
;
This patch is against 12 which is still our production branch. This
could easily be also patched against newer releases as well.
I've been using this code in production now for about 3 years, it's
greatly helped track down issues. And there shouldn't be anything
platform-specific here, it's all regular perl API
I'm not sure about adding testing. This is my first postgres patch, so
any guidance on adding regression testing would be appreciated.
The rationale for this has come from the need to know the source
function name, and we've typically resorted to things like this in the past:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
my $function_name = 'throw_warning';
$SIG{__WARN__} = sub { print STDERR "In Function: $function_name:
$_[0]\n"; }
$function$
;
We've literally had to copy/paste this all over and it's something that
postgres should just 'give you' since it knows the name already, just
like when triggers pass you $_TD with all the pertinent information
A wishlist item would be for postgres plperl to automatically prepend
the function name and schema when throwing perl warnings so you don't
have to do your own __WARN__ handler, but this is the next best thing.
Attachments:
plperl-add-FN-v1.patchtext/x-patch; charset=UTF-8; name=plperl-add-FN-v1.patchDownload
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);
Import Notes
Reply to msg id not found: ee59ec8a-e257-4af8-a09e-e800a847a6ef@intellasoft.netReference msg id not found: ee59ec8a-e257-4af8-a09e-e800a847a6ef@intellasoft.net
Hi Hackers!
This would be version v1 of this feature
Basically, the subject says it all: pl/pgperl Patch for being able to
tell which function you're in.
This is a hashref so it will be possible to populate new and exciting
other details in the future as the need arises
This also greatly improves logging capabilities for things like catching
warnings, Because as it stands right now, there's no information that
can assist with locating the source of a warning like this:
# tail -f /var/log/postgresql.log
******* GOT A WARNING - Use of uninitialized value $prefix in
concatenation (.) or string at (eval 531) line 48.
Now, with $_FN you can do this:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
use warnings;
use strict;
use Data::Dumper;
$SIG{__WARN__} = sub {
elog(NOTICE, Dumper($_FN));
print STDERR "In Function: $_FN->{name}: $_[0]\n";
};
my $a;
print "$a"; # uninit!
return undef;
$function$
;
This patch is against 12 which is still our production branch. This
could easily be also patched against newer releases as well.
I've been using this code in production now for about 3 years, it's
greatly helped track down issues. And there shouldn't be anything
platform-specific here, it's all regular perl API
I'm not sure about adding testing. This is my first postgres patch, so
any guidance on adding regression testing would be appreciated.
The rationale for this has come from the need to know the source
function name, and we've typically resorted to things like this in the past:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
my $function_name = 'throw_warning';
$SIG{__WARN__} = sub { print STDERR "In Function: $function_name:
$_[0]\n"; }
$function$
;
We've literally had to copy/paste this all over and it's something that
postgres should just 'give you' since it knows the name already, just
like when triggers pass you $_TD with all the pertinent information
A wishlist item would be for postgres plperl to automatically prepend
the function name and schema when throwing perl warnings so you don't
have to do your own __WARN__ handler, but this is the next best thing.
Attachments:
plperl-add-FN-v1.patchtext/x-patch; charset=UTF-8; name=plperl-add-FN-v1.patchDownload
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);
Hi Hackers!
This would be version v1 of this feature
Basically, the subject says it all: pl/pgperl Patch for being able to
tell which function you're in.
This is a hashref so it will be possible to populate new and exciting
other details in the future as the need arises
This also greatly improves logging capabilities for things like catching
warnings, Because as it stands right now, there's no information that
can assist with locating the source of a warning like this:
# tail -f /var/log/postgresql.log
******* GOT A WARNING - Use of uninitialized value $prefix in
concatenation (.) or string at (eval 531) line 48.
Now, with $_FN you can do this:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
use warnings;
use strict;
use Data::Dumper;
$SIG{__WARN__} = sub {
elog(NOTICE, Dumper($_FN));
print STDERR "In Function: $_FN->{name}: $_[0]\n";
};
my $a;
print "$a"; # uninit!
return undef;
$function$
;
This patch is against 12 which is still our production branch. This
could easily be also patched against newer releases as well.
I've been using this code in production now for about 3 years, it's
greatly helped track down issues. And there shouldn't be anything
platform-specific here, it's all regular perl API
I'm not sure about adding testing. This is my first postgres patch, so
any guidance on adding regression testing would be appreciated.
The rationale for this has come from the need to know the source
function name, and we've typically resorted to things like this in the past:
CREATE OR REPLACE FUNCTION throw_warning() RETURNS text LANGUAGE plperlu
AS $function$
my $function_name = 'throw_warning';
$SIG{__WARN__} = sub { print STDERR "In Function: $function_name:
$_[0]\n"; }
$function$
;
We've literally had to copy/paste this all over and it's something that
postgres should just 'give you' since it knows the name already, just
like when triggers pass you $_TD with all the pertinent information
A wishlist item would be for postgres plperl to automatically prepend
the function name and schema when throwing perl warnings so you don't
have to do your own __WARN__ handler, but this is the next best thing.
Attachments:
plperl-add-FN-v1.patchtext/x-patch; charset=UTF-8; name=plperl-add-FN-v1.patchDownload
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);
We don't really need four copies of this patch.
regards, tom lane
Sorry! I'm having email delivery issues. I thought the first few
didn't go through. I'm working through email DKMS problems where we
were incompatible with the mailing list.
It sounds like it's fixed now! Sorry for the spam!
Show quoted text
On 8/28/24 18:38, Tom Lane wrote:
We don't really need four copies of this patch.
regards, tom lane