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;
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!CvROOT(cv))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN(WARN_DEPRECATED) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
/*
* 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;
#ifdef USE_THREADS
sv_lock((SV *)varstash);
#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
#ifdef USE_THREADS
sv_lock(varsv);
#endif
sv_setpv(varsv, HvNAME(stash));
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
{
SV *sv;
apr_status_t rc;
apr_size_t size;
apr_file_t *file;
size = r->finfo.size;
sv = newSV(size);
/* XXX: could have checked whether r->finfo.filehand is valid and
* save the apr_file_open call, but apache gives us no API to
* check whether filehand is valid. we can't test whether it's
* NULL or not, as it may contain garbagea
*/
rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
APR_OS_DEFAULT, r->pool);
SLURP_SUCCESS("opening");
rc = apr_file_read(file, SvPVX(sv), &size);
SLURP_SUCCESS("reading");
MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);
if (r->finfo.size != size) {
SvREFCNT_dec(sv);
Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
size, (apr_size_t)r->finfo.size, r->filename);
}
rc = apr_file_close(file);
SLURP_SUCCESS("closing");
SvPVX(sv)[size] = '\0';
SvCUR_set(sv, size);
SvPOK_on(sv);
if (tainted) {
SvTAINTED_on(sv);
}
else {
SvTAINTED_off(sv);
}
return newRV_noinc(sv);
}
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;
}
