/* Remove a package from %INC */
static void modperl_package_delete_from_inc(pTHX_ const char *package)
{
int len;
char *filename = package2filename(package, &len);
(void)hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
free(filename);
}
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
GV *gv;
if (!PL_defstash)
return Nullgv;
tmplen = strlen(name) + 2;
if (tmplen < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(603, tmpbuf, tmplen + 1, char);
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv)) {
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
return gv;
}
PERL_STATIC_INLINE void
xs_incset(pTHX_ const char *const unixname, const STRLEN unixlen, SV* xsfile)
{
HV *inchv = GvHVn(PL_incgv);
#if 0
SV** const svp = hv_fetch(inchv, unixname, unixlen, 0);
if (!svp)
#endif
(void)hv_store(inchv, unixname, unixlen, SvREFCNT_inc_simple_NN(xsfile), 0);
}
MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name)
{
SV **svp;
int len;
char *filename = package2filename(name, &len);
svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
free(filename);
return (svp && *svp != &PL_sv_undef) ? 1 : 0;
}
STATIC void
S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
{
switch (sv_type) {
case SVt_PVIO:
(void)GvIOn(gv);
break;
case SVt_PVAV:
(void)GvAVn(gv);
break;
case SVt_PVHV:
(void)GvHVn(gv);
break;
}
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
char** e;
static char* misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash of if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((SV*)GvHV(PL_envgv), PERL_MAGIC_env))) {
bool was_tainted = PL_tainted;
char *name = GvENAME(PL_envgv);
PL_tainted = TRUE;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
PL_tainted = was_tainted;
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
while (1) {
if (i)
(void)sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, strlen(name), FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN n_a;
bool was_tainted = PL_tainted;
char *t = SvPV(*svp, n_a);
char *e = t + n_a;
PL_tainted = was_tainted;
if (t < e && isALNUM(*t))
t++;
while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
const char* const *e;
static const char* const misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
#ifdef WIN32
"PERL5SHELL", /* used for system() on Windows */
#endif
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash or if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
const bool was_tainted = TAINT_get;
const char * const name = GvENAME(PL_envgv);
TAINT;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
STRLEN len = 8; /* strlen(name) */
while (1) {
if (i)
len = my_sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN len;
const bool was_tainted = TAINT_get;
const char *t = SvPV_const(*svp, len);
const char * const e = t + len;
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
if (t < e && isWORDCHAR(*t))
t++;
while (t < e && (isWORDCHAR(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
char** e;
static char* misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
NULL
};
if (!PL_envgv)
return;
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
while (1) {
if (i)
(void)sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, strlen(name), FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN n_a;
bool was_tainted = PL_tainted;
char *t = SvPV(*svp, n_a);
char *e = t + n_a;
PL_tainted = was_tainted;
if (t < e && isALNUM(*t))
t++;
while (t < e && (isALNUM(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
STATIC SV *
S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
{
AV* av;
GV* gv;
GV** gvp;
HV* hv = Nullhv;
SV* subgen = Nullsv;
if (!stash)
return &PL_sv_undef;
if (strEQ(HvNAME(stash), name))
return &PL_sv_yes;
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HvNAME(stash));
gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
&& (hv = GvHV(gv)))
{
if (SvIV(subgen) == PL_sub_generation) {
SV* sv;
SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
name, HvNAME(stash)) );
return sv;
}
}
else {
DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
HvNAME(stash)) );
hv_clear(hv);
sv_setiv(subgen, PL_sub_generation);
}
}
gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
if (!hv || !subgen) {
gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
gv = *gvp;
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
if (!hv)
hv = GvHVn(gv);
if (!subgen) {
subgen = newSViv(PL_sub_generation);
GvSV(gv) = subgen;
}
}
if (hv) {
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_SYNTAX,
"Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
(void)hv_store(hv,name,len,&PL_sv_yes,0);
return &PL_sv_yes;
}
}
(void)hv_store(hv,name,len,&PL_sv_no,0);
}
}
return boolSV(strEQ(name, "UNIVERSAL"));
}