if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
Perl_croak(aTHX_ "Bad symbol for filehandle");
if (!GvIOp(gv)) {
-#ifdef GV_SHARED_CHECK
- if (GvSHARED(gv)) {
- Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE(gv)) {
+ Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
}
#endif
GvIOp(gv) = newIO();
tmpbuf = smallbuf;
else
New(603, tmpbuf, tmplen + 1, char);
+ /* This is where the debugger's %{"::_<$filename"} hash is created */
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
- CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
+ CvFILE_set_from_cop(GvCV(gv), PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
CvOWNER(GvCV(gv)) = 0;
if (!CvMUTEXP(GvCV(gv))) {
New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(GvCV(gv)));
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
return 0;
}
- if (!HvNAME(stash))
- Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
- static char autoload[] = "AUTOLOAD";
- static STRLEN autolen = 8;
+ char autoload[] = "AUTOLOAD";
+ STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
- SvPVX(cv) = (char *)name; /* cast to loose constness warning */
+ SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
sv_lock((SV *)varstash);
#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
sv_lock(varsv);
#endif
sv_setpv(varsv, HvNAME(stash));
strEQ(name, "ARGVOUT")))
global = TRUE;
}
- else if (*name == '_' && !name[1])
+ else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__")))
global = TRUE;
if (global)
break;
case '&':
- if (len > 1)
- break;
- PL_sawampersand = TRUE;
- goto ro_magicalize;
-
case '`':
- if (len > 1)
- break;
- PL_sawampersand = TRUE;
- goto ro_magicalize;
-
case '\'':
- if (len > 1)
- break;
+ if (
+ len > 1 ||
+ sv_type == SVt_PVAV ||
+ sv_type == SVt_PVHV ||
+ sv_type == SVt_PVCV ||
+ sv_type == SVt_PVFM ||
+ sv_type == SVt_PVIO
+ ) { break; }
PL_sawampersand = TRUE;
goto ro_magicalize;
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
- case '\005': /* $^E */
case '\006': /* $^F */
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
+ case '\016': /* $^N */
case '\020': /* $^P */
- case '\024': /* $^T */
if (len > 1)
break;
goto magicalize;
break;
sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
goto magicalize;
+ case '\005': /* $^E && $^ENCODING */
+ if (len > 1 && strNE(name, "\005NCODING"))
+ break;
+ goto magicalize;
+
case '\017': /* $^O & $^OPEN */
if (len > 1 && strNE(name, "\017PEN"))
break;
if (len > 1)
break;
goto ro_magicalize;
+ case '\024': /* $^T, ${^TAINT} */
+ if (len == 1)
+ goto magicalize;
+ else if (strEQ(name, "\024AINT"))
+ goto ro_magicalize;
+ else
+ break;
case '\027': /* $^W & $^WARNING_BITS */
if (len > 1 && strNE(name, "\027ARNING_BITS")
&& strNE(name, "\027IDE_SYSTEM_CALLS"))
case '7':
case '8':
case '9':
+ /* ensures variable is only digits */
+ /* ${"1foo"} fails this test (and is thus writeable) */
+ /* added by japhy, but borrowed from is_gv_magical */
+
+ if (len > 1) {
+ const char *end = name + len;
+ while (--end > name) {
+ if (!isDIGIT(*end)) return gv;
+ }
+ }
+
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
- (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
+ (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
{
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- STRLEN n_a;
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
/* GvSV contains the name of the method. */
- GV *ngv;
+ GV *ngv = Nullgv;
DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
- SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
+ SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
if (!SvPOK(GvSV(gv))
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
FALSE)))
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
MAGIC *mg;
- CV *cv;
+ CV *cv=NULL;
CV **cvp=NULL, **ocvp=NULL;
- AMT *amtp, *oamtp;
- int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
+ AMT *amtp=NULL, *oamtp=NULL;
+ int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
- HV* stash;
+#ifdef DEBUGGING
+ int fl=0;
+#endif
+ HV* stash=NULL;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
- && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),
- PERL_MAGIC_overload_table))
+ && (stash = SvSTASH(SvRV(left)))
+ && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
- (fl = 1, cv = cvp[off=method])))) {
+ (
+#ifdef DEBUGGING
+ fl = 1,
+#endif
+ cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
- && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),
- PERL_MAGIC_overload_table))
+ && (stash = SvSTASH(SvRV(right)))
+ && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
force_cpy = force_cpy || assign;
}
}
+#ifdef DEBUGGING
if (!notfound) {
- DEBUG_o( Perl_deb(aTHX_
- "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
- AMG_id2name(off),
- method+assignshift==off? "" :
- " (initially `",
- method+assignshift==off? "" :
- AMG_id2name(method+assignshift),
- method+assignshift==off? "" : "')",
- flags & AMGf_unary? "" :
- lr==1 ? " for right argument": " for left argument",
- flags & AMGf_unary? " for argument" : "",
- HvNAME(stash),
- fl? ",\n\tassignment variant used": "") );
+ DEBUG_o(Perl_deb(aTHX_
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+ AMG_id2name(off),
+ method+assignshift==off? "" :
+ " (initially `",
+ method+assignshift==off? "" :
+ AMG_id2name(method+assignshift),
+ method+assignshift==off? "" : "')",
+ flags & AMGf_unary? "" :
+ lr==1 ? " for right argument": " for left argument",
+ flags & AMGf_unary? " for argument" : "",
+ stash ? HvNAME(stash) : "null",
+ fl? ",\n\tassignment variant used": "") );
}
+#endif
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
CATCH_SET(oldcatch);
if (postpr) {
- int ans;
+ int ans=0;
switch (method) {
case le_amg:
case sle_amg:
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\014': /* $^L */
+ case '\016': /* $^N */
case '\020': /* $^P */
case '\023': /* $^S */
- case '\024': /* $^T */
case '\026': /* $^V */
if (len == 1)
goto yes;
break;
+ case '\024': /* $^T, ${^TAINT} */
+ if (len == 1 || strEQ(name, "\024AINT"))
+ goto yes;
+ break;
case '1':
case '2':
case '3':
https://perl5.git.perl.org / perl5.git / blobdiff