struct t_hashtable *
weechat_perl_hash_to_hashtable (SV *hash, int size, const char *type_keys,
const char *type_values)
{
struct t_hashtable *hashtable;
HV *hash2;
SV *value;
char *str_key;
I32 retlen;
hashtable = weechat_hashtable_new (size, type_keys, type_values,
NULL, NULL);
if (!hashtable)
return NULL;
if ((hash) && SvROK(hash) && SvRV(hash)
&& (SvTYPE(SvRV(hash)) == SVt_PVHV))
{
hash2 = (HV *)SvRV(hash);
hv_iterinit (hash2);
while ((value = hv_iternextsv (hash2, &str_key, &retlen)))
{
if (strcmp (type_values, WEECHAT_HASHTABLE_STRING) == 0)
{
weechat_hashtable_set (hashtable, str_key,
SvPV (value, PL_na));
}
else if (strcmp (type_values, WEECHAT_HASHTABLE_POINTER) == 0)
{
weechat_hashtable_set (hashtable, str_key,
plugin_script_str2ptr (
weechat_perl_plugin,
NULL, NULL,
SvPV (value, PL_na)));
}
}
}
return hashtable;
}
static void perl_hash_to_json( SV *input, json_writer_t *writer )
{
HV *h;
char *prop;
I32 cnt, retlen;
SV *item;
json_writer_start_object( writer );
if ( ( SvROK( input ) && SvTYPE( SvRV( input ) ) == SVt_PVHV ) ) {
h = (HV *) SvRV( input );
cnt = hv_iterinit( h );
while ( cnt-- ) {
item = hv_iternextsv( h, &prop, &retlen );
json_writer_start_property( writer, prop );
perl_variable_to_json_internal( item, writer );
json_writer_end_property( writer );
}
}
json_writer_end_object( writer );
}
SV *
Window_menuItems( Handle self, Bool set, SV * menuItems)
{
dPROFILE;
if ( var-> stage > csFrozen) return nilSV;
if ( !set)
return var-> menu ? CMenu( var-> menu)-> get_items( var-> menu, "") : nilSV;
if ( var-> menu == nilHandle) {
if ( SvTYPE( menuItems)) {
HV * profile = newHV();
pset_sv( items, menuItems);
pset_H ( owner, self);
pset_i ( selected, false);
my-> set_menu( self, create_instance( "Prima::Menu"));
sv_free(( SV *) profile);
}
} else
CMenu( var-> menu)-> set_items( var-> menu, menuItems);
return menuItems;
}
void
pack_modify_request_ref(SV *dest, HV *hv) {
STRLEN offset1, offset2;
SV *changes;
offset1 = start_constructed(dest, ASN1_APPLICATION|ASN1_CONSTRUCTED, LDAP_OP_MODIFY_REQUEST);
pack_string_utf8(dest, hv_fetchs_def_undef(hv, "dn"));
offset2 = start_sequence(dest);
changes = hv_fetchs_def_undef(hv, "changes");
if (changes && SvOK(changes)) {
AV *av;
I32 i, len;
if (SvROK(changes) && (av = (AV*)SvRV(changes)) && (SvTYPE(av) == SVt_PVAV)) {
len = av_len(av);
for (i = 0; i <= len; i++)
ldap_pack_modop(dest, av_fetch_def_undef(av, i));
}
else
ldap_pack_modop(dest, changes);
}
end_sequence(dest, offset2);
end_constructed(dest, offset1);
}
SV *
AbstractMenu_action( Handle self, Bool set, char * varName, SV * action)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return nilSV;
m = find_menuitem( self, varName, true);
if ( !m) return nilSV;
if ( !set) {
if ( m-> code) return newSVsv( m-> code);
if ( m-> perlSub) {
SV * sv = newSVpv( m-> perlSub, 0);
if ( m-> flags. utf8_perlSub) SvUTF8_on( sv);
return sv;
}
return nilSV;
}
if ( m-> flags. divider || m-> down) return nilSV;
if ( SvROK( action))
{
if ( m-> code) sv_free( m-> code);
m-> code = nil;
if ( SvTYPE( SvRV( action)) == SVt_PVCV)
{
m-> code = newSVsv( action);
free( m-> perlSub);
m-> perlSub = nil;
}
m-> flags. utf8_perlSub = 0;
} else {
char * line = ( char *) SvPV_nolen( action);
free( m-> perlSub);
if ( m-> code) sv_free( m-> code);
m-> code = nil;
m-> perlSub = duplicate_string( line);
m-> flags. utf8_perlSub = prima_is_utf8_sv( action);
}
return nilSV;
}
/*
* Boyan :
* Gets the content from hashes
*/
static int get_hv_content(HV *my_hv, VALUE_PAIR **vp)
{
SV *res_sv, **av_sv;
AV *av;
char *key;
I32 key_len, len, i, j;
int ret=0;
for (i = hv_iterinit(my_hv); i > 0; i--) {
res_sv = hv_iternextsv(my_hv,&key,&key_len);
if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) {
av = (AV*)SvRV(res_sv);
len = av_len(av);
for (j = 0; j <= len; j++) {
av_sv = av_fetch(av, j, 0);
ret = pairadd_sv(vp, key, *av_sv, T_OP_ADD) + ret;
}
} else ret = pairadd_sv(vp, key, res_sv, T_OP_EQ) + ret;
}
return ret;
}
static SV *load_psgi(apr_pool_t *pool, const char *file)
{
dTHX;
SV *app;
char *code;
code = apr_psprintf(pool, "do q\"%s\" or die $@",
ap_escape_quotes(pool, file));
app = eval_pv(code, FALSE);
if (SvTRUE(ERRSV)) {
ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "%s", SvPV_nolen(ERRSV));
CLEAR_ERRSV();
return NULL;
}
if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
"%s does not return an application code reference", file);
return NULL;
}
return app;
}
SV *
Widget_popupItems( Handle self, Bool set, SV * popupItems)
{
dPROFILE;
enter_method;
if ( var-> stage > csFrozen) return nilSV;
if ( !set)
return var-> popupMenu ?
CAbstractMenu( var-> popupMenu)-> get_items( var-> popupMenu, "") : nilSV;
if ( var-> popupMenu == nilHandle) {
if ( SvTYPE( popupItems)) {
HV * profile = newHV();
pset_sv( items, popupItems);
pset_H ( owner, self);
my-> set_popup( self, create_instance( "Prima::Popup"));
sv_free(( SV *) profile);
}
}
else
CAbstractMenu( var-> popupMenu)-> set_items( var-> popupMenu, popupItems);
return popupItems;
}
apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
SV *avrv)
{
AV *av;
apr_array_header_t *array;
int i, av_size;
if (!(SvROK(avrv) && (SvTYPE(SvRV(avrv)) == SVt_PVAV))) {
Perl_croak(aTHX_ "Not an array reference");
}
av = (AV*)SvRV(avrv);
av_size = av_len(av);
array = apr_array_make(p, av_size+1, sizeof(char *));
for (i = 0; i <= av_size; i++) {
SV *sv = *av_fetch(av, i, FALSE);
char **entry = (char **)apr_array_push(array);
*entry = apr_pstrdup(p, SvPV_nolen(sv));
}
return array;
}
int sv2constant(SV * svconstant, const char * context) {
AV * avparam;
int val = 0;
SV **tmpsv;
int i;
if (svconstant == NULL) {
return 0;
} else if (!SvOK(svconstant)) {
return 0;
} else if (SvPOK(svconstant) || SvIOK(svconstant)) {
if (!scalar2constant(svconstant, context, &val))
warn("Unknow value '%s' in '%s'", SvPV_nolen(svconstant), context);
} else if (SvTYPE(SvRV(svconstant)) == SVt_PVAV) {
avparam = (AV*) SvRV(svconstant);
for (i = 0; i <= av_len(avparam); i++) {
tmpsv = av_fetch(avparam, i, 0);
if (!scalar2constant(*tmpsv, context, &val))
warn("Unknow value '%s' in '%s' from array", SvPV_nolen(*tmpsv), context);
}
} else {
}
return val;
}
GdkRectangle * SvGdkRectangle(SV * data, GdkRectangle * rect)
{
AV * a;
SV ** s;
if ((!data) || (!SvOK(data)) || (!SvRV(data)) || (SvTYPE(SvRV(data)) != SVt_PVAV))
return 0;
a = (AV*)SvRV(data);
if (av_len(a) != 3)
croak("rectangle must have four elements");
if (!rect)
rect = alloc_temp(sizeof(GdkRectangle));
rect->x = SvIV(*av_fetch(a, 0, 0));
rect->y = SvIV(*av_fetch(a, 1, 0));
rect->width = SvIV(*av_fetch(a, 2, 0));
rect->height = SvIV(*av_fetch(a, 3, 0));
return rect;
}
static OP *parser_callback(pTHX_ GV *namegv, SV *psobj, U32 *flagsp) {
dSP;
SV *args_generator;
SV *statement = NULL;
I32 count;
/* call the parser callback
* it should take no arguments and return a coderef which, when called,
* produces the arguments to the keyword function
* the optree we want to generate is for something like
* mykeyword($code->())
* where $code is the thing returned by the parser function
*/
PUSHMARK(SP);
mXPUSHp(GvNAME(namegv), GvNAMELEN(namegv));
PUTBACK;
count = call_sv(psobj, G_ARRAY);
SPAGAIN;
if (count > 1) {
statement = POPs;
}
args_generator = SvREFCNT_inc(POPs);
PUTBACK;
if (!SvROK(args_generator) || SvTYPE(SvRV(args_generator)) != SVt_PVCV) {
croak("The parser function for %s must return a coderef, not %"SVf,
GvNAME(namegv), args_generator);
}
if (SvTRUE(statement)) {
*flagsp |= CALLPARSER_STATEMENT;
}
return newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, newSVOP(OP_CONST, 0, args_generator)));
}
/*
* convert perl HV to job_desc_msg_t
* return 0 on success, -1 on failure
*/
int
hv_to_job_desc_msg(HV *hv, job_desc_msg_t *job_desc)
{
SV **svp;
HV *environ_hv;
AV *argv_av;
SV *val;
char *env_key, *env_val;
I32 klen;
STRLEN vlen;
int num_keys, i;
slurm_init_job_desc_msg(job_desc);
FETCH_FIELD(hv, job_desc, account, charp, FALSE);
FETCH_FIELD(hv, job_desc, acctg_freq, charp, FALSE);
FETCH_FIELD(hv, job_desc, alloc_node, charp, FALSE);
FETCH_FIELD(hv, job_desc, alloc_resp_port, uint16_t, FALSE);
FETCH_FIELD(hv, job_desc, alloc_sid, uint32_t, FALSE);
/* argv, argc */
if((svp = hv_fetch(hv, "argv", 4, FALSE))) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
argv_av = (AV*)SvRV(*svp);
job_desc->argc = av_len(argv_av) + 1;
if (job_desc->argc > 0) {
Newz(0, job_desc->argv, (int32_t)(job_desc->argc + 1), char*);
for(i = 0; i < job_desc->argc; i ++) {
if((svp = av_fetch(argv_av, i, FALSE)))
*(job_desc->argv + i) = (char*) SvPV_nolen(*svp);
else {
Perl_warn(aTHX_ "error fetching `argv' of job descriptor");
free_job_desc_msg_memory(job_desc);
return -1;
}
}
}
} else {
I32 p5_get_type(PerlInterpreter *my_perl, SV *sv) {
int is_hash;
PERL_SET_CONTEXT(my_perl);
if (p5_is_object(my_perl, sv)) {
return 1;
}
else if (p5_is_sub_ref(my_perl, sv)) {
return 2;
}
else if (p5_SvNOK(my_perl, sv)) {
return 3;
}
else if (p5_SvIOK(my_perl, sv)) {
return 4;
}
else if (p5_SvPOK(my_perl, sv)) {
return 5;
}
else if (p5_is_array(my_perl, sv)) {
return 6;
}
else if ((is_hash = p5_is_hash(my_perl, sv)) > 0) {
return 6 + is_hash;
}
else if (p5_is_undef(my_perl, sv)) {
return 9;
}
else if (p5_is_scalar_ref(my_perl, sv)) {
return 10;
}
else if (SvTYPE(sv) == SVt_PVGV) {
return 11;
}
else {
return 0;
}
}
SV *
PerlFMM_bufmagic(PerlFMM *self, SV *buf)
{
unsigned char *buffer;
char *type;
int rc;
SV *ret;
/* rt #28040, allow RV to SVs to be passed here */
if (SvROK(buf) && SvTYPE(SvRV(buf)) == SVt_PV) {
buffer = (unsigned char *) SvPV_nolen( SvRV( buf ) );
} else {
buffer = (unsigned char *) SvPV_nolen(buf);
}
FMM_SET_ERROR(self, NULL);
Newz(1234, type, BUFSIZ, char);
rc = fmm_bufmagic(self, &buffer, &type);
ret = FMM_RESULT(type, rc);
Safefree(type);
return ret;
}
USER_OBJECT_
RS_getHV(USER_OBJECT_ name, USER_OBJECT_ convert, USER_OBJECT_ interpreter)
{
USER_OBJECT_ ans = NULL_USER_OBJECT;
HV *table;
dTHX;
if(!IS_CHARACTER(name)) {
SV *tmp = getForeignPerlReference(name);
if(tmp == NULL || SvTYPE(tmp) != SVt_PVHV) {
PROBLEM "non-array reference passed to RS_getHV"
ERROR;
}
table = (HV*) tmp;
} else {
table = get_hv(CHAR_DEREF(STRING_ELT(name,0)), FALSE);
}
if(table != NULL) {
if(TYPEOF(convert) == LGLSXP || TYPEOF(convert) == INTSXP) {
unsigned int depth;
depth = (TYPEOF(convert) == LGLSXP ? LOGICAL(convert)[0] : INTEGER(convert)[0]);
if(depth) {
ans = fromPerlHV(table, depth);
} else {
/* ans = fromPerl((SV*) table); */
ans = makeForeignPerlReference((SV*) table, makeRSPerlClassVector("PerlHashReference"), &exportReferenceTable);
}
} else {
ans = directConvertFromPerl((SV*) table, convert);
}
}
return(ans);
}
Point *
Drawable_polypoints( SV * points, char * procName, int mod, int * n_points)
{
AV * av;
int i, count;
Point * p;
if ( !SvROK( points) || ( SvTYPE( SvRV( points)) != SVt_PVAV)) {
warn("RTC0050: Invalid array reference passed to %s", procName);
return nil;
}
av = ( AV *) SvRV( points);
count = av_len( av) + 1;
if ( count % mod) {
warn("RTC0051: Drawable::%s: Number of elements in an array must be a multiple of %d",
procName, mod);
return nil;
}
count /= 2;
if ( count < 2) return nil;
if (!( p = allocn( Point, count))) return false;
for ( i = 0; i < count; i++)
{
SV** psvx = av_fetch( av, i * 2, 0);
SV** psvy = av_fetch( av, i * 2 + 1, 0);
if (( psvx == nil) || ( psvy == nil)) {
free( p);
warn("RTC0052: Array panic on item pair %d on Drawable::%s", i, procName);
return nil;
}
p[ i]. x = SvIV( *psvx);
p[ i]. y = SvIV( *psvy);
}
*n_points = count;
return p;
}
/*
* Gets the content from hashes
*/
static int get_hv_content(TALLOC_CTX *ctx, REQUEST *request, HV *my_hv, VALUE_PAIR **vps,
const char *hash_name, const char *list_name)
{
SV *res_sv, **av_sv;
AV *av;
char *key;
I32 key_len, len, i, j;
int ret = 0;
*vps = NULL;
for (i = hv_iterinit(my_hv); i > 0; i--) {
res_sv = hv_iternextsv(my_hv,&key,&key_len);
if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) {
av = (AV*)SvRV(res_sv);
len = av_len(av);
for (j = 0; j <= len; j++) {
av_sv = av_fetch(av, j, 0);
ret = pairadd_sv(ctx, request, vps, key, *av_sv, T_OP_ADD, hash_name, list_name) + ret;
}
} else ret = pairadd_sv(ctx, request, vps, key, res_sv, T_OP_EQ, hash_name, list_name) + ret;
}
return ret;
}
/* converts a siglevel string or hashref into bitflags. */
alpm_siglevel_t
p2c_siglevel(SV *sig)
{
char *str;
STRLEN len;
alpm_siglevel_t ret;
HV *hv;
if(SvPOK(sig)){
str = SvPV(sig, len);
if(len == 7 && strncmp(str, "default", len) == 0){
return ALPM_SIG_USE_DEFAULT;
}else {
/* XXX: might not be null terminated? */
croak("Unrecognized global signature level string: %s", str);
}
}else if(SvROK(sig) && SvTYPE(SvRV(sig)) == SVt_PVHV){
hv = (HV*)SvRV(sig);
ret = fetch_trustmask(hv, "pkg");
ret |= fetch_trustmask(hv, "db") << OFFSET_DB;
return ret;
}
croak("A global signature level must be a string or hash reference");
}
static SV *
plperl_create_sub(char *s, bool trusted)
{
dSP;
SV *subref;
int count;
char *compile_sub;
if (trusted && !plperl_safe_init_done)
{
plperl_safe_init();
SPAGAIN;
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
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?
*/
if (trusted && plperl_use_strict)
compile_sub = "::mk_strict_safefunc";
else if (plperl_use_strict)
compile_sub = "::mk_strict_unsafefunc";
else if (trusted)
compile_sub = "::mksafefunc";
else
compile_sub = "::mkunsafefunc";
count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
if (count != 1)
{
PUTBACK;
FREETMPS;
LEAVE;
elog(ERROR, "didn't get a return item from mksafefunc");
}
if (SvTRUE(ERRSV))
{
(void) POPs;
PUTBACK;
FREETMPS;
LEAVE;
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("creation of Perl function failed: %s",
strip_trailing_ws(SvPV(ERRSV, PL_na)))));
}
/*
* need to make a deep copy of the return. it comes off the stack as a
* temporary.
*/
subref = newSVsv(POPs);
if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
{
PUTBACK;
FREETMPS;
LEAVE;
/*
* subref is our responsibility because it is not mortal
*/
SvREFCNT_dec(subref);
elog(ERROR, "didn't get a code ref");
}
PUTBACK;
FREETMPS;
LEAVE;
return subref;
}
static Datum
plperl_func_handler(PG_FUNCTION_ARGS)
{
plperl_proc_desc *prodesc;
SV *perlret;
Datum retval;
ReturnSetInfo *rsi;
SV *array_ret = NULL;
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
plperl_current_prodesc = prodesc;
plperl_current_caller_info = fcinfo;
plperl_current_tuple_store = 0;
plperl_current_tuple_desc = 0;
rsi = (ReturnSetInfo *) fcinfo->resultinfo;
if (prodesc->fn_retisset)
{
/* Check context before allowing the call to go through */
if (!rsi || !IsA(rsi, ReturnSetInfo) ||
(rsi->allowedModes & SFRM_Materialize) == 0 ||
rsi->expectedDesc == NULL)
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("set-valued function called in context that "
"cannot accept a set")));
}
perlret = plperl_call_perl_func(prodesc, fcinfo);
/************************************************************
* Disconnect from SPI manager and then create the return
* values datum (if the input function does a palloc for it
* this must not be allocated in the SPI memory context
* because SPI_finish would free it).
************************************************************/
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
if (prodesc->fn_retisset)
{
/*
* If the Perl function returned an arrayref, we pretend that it
* called return_next() for each element of the array, to handle old
* SRFs that didn't know about return_next(). Any other sort of return
* value is an error.
*/
if (SvTYPE(perlret) == SVt_RV &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
{
int i = 0;
SV **svp = 0;
AV *rav = (AV *) SvRV(perlret);
while ((svp = av_fetch(rav, i, FALSE)) != NULL)
{
plperl_return_next(*svp);
i++;
}
}
else if (SvTYPE(perlret) != SVt_NULL)
{
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("set-returning Perl function must return "
"reference to array or use return_next")));
}
rsi->returnMode = SFRM_Materialize;
if (plperl_current_tuple_store)
{
rsi->setResult = plperl_current_tuple_store;
rsi->setDesc = plperl_current_tuple_desc;
}
retval = (Datum) 0;
}
else if (SvTYPE(perlret) == SVt_NULL)
{
/* Return NULL if Perl code returned undef */
if (rsi && IsA(rsi, ReturnSetInfo))
rsi->isDone = ExprEndResult;
fcinfo->isnull = true;
retval = (Datum) 0;
}
else if (prodesc->fn_retistuple)
{
/* Return a perl hash converted to a Datum */
TupleDesc td;
AttInMetadata *attinmeta;
HeapTuple tup;
if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
SvTYPE(SvRV(perlret)) != SVt_PVHV)
{
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("composite-returning Perl function "
"must return reference to hash")));
}
/* XXX should cache the attinmeta data instead of recomputing */
if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
{
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("function returning record called in context "
"that cannot accept type record")));
}
attinmeta = TupleDescGetAttInMetadata(td);
tup = plperl_build_tuple_result((HV *) SvRV(perlret), attinmeta);
retval = HeapTupleGetDatum(tup);
}
else
{
/* Return a perl string converted to a Datum */
char *val;
if (prodesc->fn_retisarray && SvROK(perlret) &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
{
array_ret = plperl_convert_to_pg_array(perlret);
SvREFCNT_dec(perlret);
perlret = array_ret;
}
val = SvPV(perlret, PL_na);
retval = FunctionCall3(&prodesc->result_in_func,
CStringGetDatum(val),
ObjectIdGetDatum(prodesc->result_typioparam),
Int32GetDatum(-1));
}
if (array_ret == NULL)
SvREFCNT_dec(perlret);
return retval;
}
/*
* Note: plperl_return_next is called both in Postgres and Perl contexts.
* We report any errors in Postgres fashion (via ereport). If called in
* Perl context, it is SPI.xs's responsibility to catch the error and
* convert to a Perl error. We assume (perhaps without adequate justification)
* that we need not abort the current transaction if the Perl code traps the
* error.
*/
void
plperl_return_next(SV *sv)
{
plperl_proc_desc *prodesc = plperl_current_prodesc;
FunctionCallInfo fcinfo = plperl_current_caller_info;
ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
MemoryContext cxt;
HeapTuple tuple;
TupleDesc tupdesc;
if (!sv)
return;
if (!prodesc->fn_retisset)
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("cannot use return_next in a non-SETOF function")));
if (prodesc->fn_retistuple &&
!(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("setof-composite-returning Perl function "
"must call return_next with reference to hash")));
cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
if (!plperl_current_tuple_store)
plperl_current_tuple_store =
tuplestore_begin_heap(true, false, work_mem);
if (prodesc->fn_retistuple)
{
TypeFuncClass rettype;
AttInMetadata *attinmeta;
rettype = get_call_result_type(fcinfo, NULL, &tupdesc);
tupdesc = CreateTupleDescCopy(tupdesc);
attinmeta = TupleDescGetAttInMetadata(tupdesc);
tuple = plperl_build_tuple_result((HV *) SvRV(sv), attinmeta);
}
else
{
Datum ret;
bool isNull;
tupdesc = CreateTupleDescCopy(rsi->expectedDesc);
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
{
char *val = SvPV(sv, PL_na);
ret = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(val),
ObjectIdGetDatum(prodesc->result_typioparam),
Int32GetDatum(-1));
isNull = false;
}
else
{
ret = (Datum) 0;
isNull = true;
}
tuple = heap_form_tuple(tupdesc, &ret, &isNull);
}
if (!plperl_current_tuple_desc)
plperl_current_tuple_desc = tupdesc;
tuplestore_puttuple(plperl_current_tuple_store, tuple);
heap_freetuple(tuple);
MemoryContextSwitchTo(cxt);
}
static HeapTuple
plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{
SV **svp;
HV *hvNew;
HeapTuple rtup;
SV *val;
char *key;
I32 klen;
int slotsused;
int *modattrs;
Datum *modvalues;
char *modnulls;
TupleDesc tupdesc;
tupdesc = tdata->tg_relation->rd_att;
svp = hv_fetch(hvTD, "new", 3, FALSE);
if (!svp)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("$_TD->{new} does not exist")));
if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("$_TD->{new} is not a hash reference")));
hvNew = (HV *) SvRV(*svp);
modattrs = palloc(tupdesc->natts * sizeof(int));
modvalues = palloc(tupdesc->natts * sizeof(Datum));
modnulls = palloc(tupdesc->natts * sizeof(char));
slotsused = 0;
hv_iterinit(hvNew);
while ((val = hv_iternextsv(hvNew, &key, &klen)))
{
int attn = SPI_fnumber(tupdesc, key);
if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("Perl hash contains nonexistent column \"%s\"",
key)));
if (SvOK(val) && SvTYPE(val) != SVt_NULL)
{
Oid typinput;
Oid typioparam;
FmgrInfo finfo;
/* XXX would be better to cache these lookups */
getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid,
&typinput, &typioparam);
fmgr_info(typinput, &finfo);
modvalues[slotsused] = FunctionCall3(&finfo,
CStringGetDatum(SvPV(val, PL_na)),
ObjectIdGetDatum(typioparam),
Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod));
modnulls[slotsused] = ' ';
}
else
{
modvalues[slotsused] = (Datum) 0;
modnulls[slotsused] = 'n';
}
modattrs[slotsused] = attn;
slotsused++;
}
hv_iterinit(hvNew);
rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
modattrs, modvalues, modnulls);
pfree(modattrs);
pfree(modvalues);
pfree(modnulls);
if (rtup == NULL)
elog(ERROR, "SPI_modifytuple failed: %s",
SPI_result_code_string(SPI_result));
return rtup;
}
SV *
DeadCode(pTHX)
{
#ifdef PURIFY
return Nullsv;
#else
SV* sva;
SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
AV* padlist = CvPADLIST(cv), *argav;
SV** svp;
SV** pad;
int i = 0, j, levelm, totm = 0, levelref, totref = 0;
int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
int dumpit = 0;
if (CvXSUB(sv)) {
continue; /* XSUB */
}
if (!CvGV(sv)) {
continue; /* file-level scope. */
}
if (!CvROOT(cv)) {
/* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
continue; /* autoloading stub. */
}
do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
if (CvDEPTH(cv)) {
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
svp = AvARRAY(padlist);
while (++i <= AvFILL(padlist)) { /* Depth. */
SV **args;
pad = AvARRAY((AV*)svp[i]);
argav = (AV*)pad[0];
if (!argav || (SV*)argav == &PL_sv_undef) {
PerlIO_printf(Perl_debug_log, " closure-template\n");
continue;
}
args = AvARRAY(argav);
levelm = levels = levelref = levelas = 0;
levela = sizeof(SV*) * (AvMAX(argav) + 1);
if (AvREAL(argav)) {
for (j = 0; j < AvFILL(argav); j++) {
if (SvROK(args[j])) {
PerlIO_printf(Perl_debug_log, " ref in args!\n");
levelref++;
}
/* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
levelas += SvLEN(args[j])/SvREFCNT(args[j]);
}
}
}
for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
if (SvROK(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
else if (SvTYPE(pad[j]) >= SVt_PVAV) {
if (!SvPADMY(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
}
else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
levels++;
levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
/* Dump(pad[j],4); */
}
}
PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
i, levelref, levelm, levels, levela, levelas);
totm += levelm;
tota += levela;
totas += levelas;
tots += levels;
totref += levelref;
if (dumpit)
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
}
if (AvFILL(padlist) > 1) {
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
totref, totm, tots, tota, totas);
}
tref += totref;
tm += totm;
ts += tots;
ta += tota;
tas += totas;
}
}
}
PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
return ret;
#endif /* !PURIFY */
}
static Datum
plperl_trigger_handler(PG_FUNCTION_ARGS)
{
plperl_proc_desc *prodesc;
SV *perlret;
Datum retval;
SV *svTD;
HV *hvTD;
/* Connect to SPI manager */
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
plperl_current_prodesc = prodesc;
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
hvTD = (HV *) SvRV(svTD);
/************************************************************
* Disconnect from SPI manager and then create the return
* values datum (if the input function does a palloc for it
* this must not be allocated in the SPI memory context
* because SPI_finish would free it).
************************************************************/
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL))
{
/* undef result means go ahead with original tuple */
TriggerData *trigdata = ((TriggerData *) fcinfo->context);
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
retval = (Datum) trigdata->tg_trigtuple;
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
retval = (Datum) trigdata->tg_newtuple;
else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
retval = (Datum) trigdata->tg_trigtuple;
else
retval = (Datum) 0; /* can this happen? */
}
else
{
HeapTuple trv;
char *tmp;
tmp = SvPV(perlret, PL_na);
if (pg_strcasecmp(tmp, "SKIP") == 0)
trv = NULL;
else if (pg_strcasecmp(tmp, "MODIFY") == 0)
{
TriggerData *trigdata = (TriggerData *) fcinfo->context;
if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
trv = plperl_modify_tuple(hvTD, trigdata,
trigdata->tg_trigtuple);
else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
trv = plperl_modify_tuple(hvTD, trigdata,
trigdata->tg_newtuple);
else
{
ereport(WARNING,
(errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
errmsg("ignoring modified tuple in DELETE trigger")));
trv = NULL;
}
}
else
{
ereport(ERROR,
(errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
errmsg("result of Perl trigger function must be undef, "
"\"SKIP\" or \"MODIFY\"")));
trv = NULL;
}
retval = PointerGetDatum(trv);
}
SvREFCNT_dec(svTD);
if (perlret)
SvREFCNT_dec(perlret);
return retval;
}
void perl_signal_args_to_c(
void (*callback)(void *, void **), void *cb_arg,
int signal_id, SV **args, size_t n_args)
{
union {
int v_int;
unsigned long v_ulong;
GSList *v_gslist;
GList *v_glist;
} saved_args[SIGNAL_MAX_ARGUMENTS];
void *p[SIGNAL_MAX_ARGUMENTS];
PERL_SIGNAL_ARGS_REC *rec;
size_t n;
if (!(rec = perl_signal_args_find(signal_id))) {
const char *name = signal_get_id_str(signal_id);
if (!name) {
croak("%d is not a known signal id", signal_id);
}
croak("\"%s\" is not a registered signal", name);
}
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
void *c_arg;
SV *arg = args[n];
if (!SvOK(arg)) {
c_arg = NULL;
} else if (strcmp(rec->args[n], "string") == 0) {
c_arg = SvPV_nolen(arg);
} else if (strcmp(rec->args[n], "int") == 0) {
c_arg = (void *)SvIV(arg);
} else if (strcmp(rec->args[n], "ulongptr") == 0) {
saved_args[n].v_ulong = SvUV(arg);
c_arg = &saved_args[n].v_ulong;
} else if (strcmp(rec->args[n], "intptr") == 0) {
saved_args[n].v_int = SvIV(SvRV(arg));
c_arg = &saved_args[n].v_int;
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList *gl;
int is_str;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
gl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **px = av_fetch(av, count, 0);
SV *x = px ? *px : NULL;
gl = g_list_prepend(
gl,
x == NULL ? NULL :
is_str ? g_strdup(SvPV_nolen(x)) :
irssi_ref_object(x)
);
}
saved_args[n].v_glist = gl;
c_arg = &saved_args[n].v_glist;
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
GSList *gsl;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
gsl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **x = av_fetch(av, count, 0);
gsl = g_slist_prepend(
gsl,
x == NULL ? NULL :
irssi_ref_object(*x)
);
}
c_arg = saved_args[n].v_gslist = gsl;
} else {
c_arg = irssi_ref_object(arg);
}
p[n] = c_arg;
}
for (; n < SIGNAL_MAX_ARGUMENTS; ++n) {
p[n] = NULL;
}
callback(cb_arg, p);
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
SV *arg = args[n];
if (!SvOK(arg)) {
continue;
}
if (strcmp(rec->args[n], "intptr") == 0) {
SV *t = SvRV(arg);
SvIOK_only(t);
SvIV_set(t, saved_args[n].v_int);
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
g_slist_free(saved_args[n].v_gslist);
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
int is_iobject, is_str;
AV *av;
GList *gl, *tmp;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = (AV *)SvRV(arg);
av_clear(av);
gl = saved_args[n].v_glist;
for (tmp = gl; tmp != NULL; tmp = tmp->next) {
av_push(av,
is_iobject ? iobject_bless((SERVER_REC *)tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data)
);
}
if (is_str) {
g_list_foreach(gl, (GFunc)g_free, NULL);
}
g_list_free(gl);
}
}
}
GV *
Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
{
register const char *name = nambeg;
register GV *gv = 0;
GV**gvp;
I32 len;
register const char *namend;
HV *stash = 0;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
name++;
for (namend = name; *namend; namend++) {
if ((*namend == ':' && namend[1] == ':')
|| (*namend == '\'' && namend[1]))
{
if (!stash)
stash = PL_defstash;
if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
if (len > 0) {
char smallbuf[256];
char *tmpbuf;
if (len + 3 < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(601, tmpbuf, len+3, char);
Copy(name, tmpbuf, len, char);
tmpbuf[len++] = ':';
tmpbuf[len++] = ':';
tmpbuf[len] = '\0';
gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
gv = gvp ? *gvp : Nullgv;
if (gv && gv != (GV*)&PL_sv_undef) {
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
else
GvMULTI_on(gv);
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
if (!gv || gv == (GV*)&PL_sv_undef)
return Nullgv;
if (!(stash = GvHV(gv)))
stash = GvHV(gv) = newHV();
if (!HvNAME(stash))
HvNAME(stash) = savepvn(nambeg, namend - nambeg);
}
if (*namend == ':')
namend++;
namend++;
name = namend;
if (!*name)
return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
}
}
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
AV* av;
GV* topgv;
GV* gv;
GV** gvp;
CV* cv;
if (!stash)
return 0;
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
topgv = Nullgv;
else {
topgv = *gvp;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
if ((cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
return topgv;
/* Stale cached entry: junk it */
SvREFCNT_dec(cv);
GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
else if (GvCVGEN(topgv) == PL_sub_generation)
return 0; /* cache indicates sub doesn't exist */
}
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
char* packname = HvNAME(stash);
STRLEN packlen = strlen(packname);
if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
GvAV(gv) = (AV*)SvREFCNT_inc(av);
}
}
}
if (av) {
SV** svp = AvARRAY(av);
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
(level >= 0) ? level + 1 : level - 1);
if (gv)
goto gotcha;
}
}
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
HV* lastchance;
if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
if ((gv = gv_fetchmeth(lastchance, name, len,
(level >= 0) ? level + 1 : level - 1)))
{
gotcha:
/*
* Cache method in topgv if:
* 1. topgv has no synonyms (else inheritance crosses wires)
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv &&
GvREFCNT(topgv) == 1 &&
(cv = GvCV(gv)) &&
(CvROOT(cv) || CvXSUB(cv)))
{
if ((cv = GvCV(topgv)))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
GvCVGEN(topgv) = PL_sub_generation;
}
return gv;
}
else if (topgv && GvREFCNT(topgv) == 1) {
/* cache the fact that the method is not defined */
GvCVGEN(topgv) = PL_sub_generation;
}
}
}
return 0;
}
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
HV* ostash = stash;
if (stash && SvTYPE(stash) < SVt_PVHV)
stash = Nullhv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else {
/* don't autovifify if ->NoSuchStash::method */
stash = gv_stashpvn(origname, nsplit - origname, FALSE);
/* however, explicit calls to Pkg::SUPER::method may
happen, and may require autovivification to work */
if (!stash && (nsplit - origname) >= 7 &&
strnEQ(nsplit - 7, "::SUPER", 7) &&
gv_stashpvn(origname, nsplit - origname - 7, FALSE))
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
ostash = stash;
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(ostash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_nolen((SV*)stash);
stash = Nullhv;
}
else {
packname = HvNAME(stash);
}
}
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
packname, (int)len, name);
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
