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; }