/* gv.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
{
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
Perl_croak(aTHX_ "Bad symbol for filehandle");
- if (!GvIOp(gv))
+ if (!GvIOp(gv)) {
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE(gv)) {
+ Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
+ }
+#endif
GvIOp(gv) = newIO();
+ }
return 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');
+ hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
- sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
+ sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
LEAVE;
PL_sub_generation++;
- CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
- CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
+ CvGV(GvCV(gv)) = gv;
+ 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);
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
-accessible via @ISA and @UNIVERSAL.
+accessible via @ISA and UNIVERSAL::.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
GV** gvp;
CV* cv;
- if (!stash)
- return 0;
+ /* UNIVERSAL methods should be callable without a stash */
+ if (!stash) {
+ level = -1; /* probably appropriate */
+ if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
+ return 0;
+ }
+
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
/* ->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
- stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+ /* don't autovifify if ->NoSuchStash::method */
+ stash = gv_stashpvn(origname, nsplit - origname, FALSE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
GV* vargv;
SV* varsv;
+ if (!stash)
+ return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
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))
+ if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
+#ifndef USE_5005THREADS
+ 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;
+ }
+#endif
+
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
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));
return gv;
}
+/* The "gv" parameter should be the glob known to Perl code as *!
+ * The scalar must already have been magicalized.
+ */
+STATIC void
+S_require_errno(pTHX_ GV *gv)
+{
+ HV* stash = gv_stashpvn("Errno",5,FALSE);
+
+ if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+ dSP;
+ PUTBACK;
+ ENTER;
+ save_scalar(gv); /* keep the value of $! */
+ require_pv("Errno.pm");
+ LEAVE;
+ SPAGAIN;
+ stash = gv_stashpvn("Errno",5,FALSE);
+ if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+ Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
+ }
+}
+
/*
=for apidoc gv_stashpv
if (add) {
GvMULTI_on(gv);
gv_init_sv(gv, sv_type);
+ if (*name=='!' && sv_type == SVt_PVHV && len==1)
+ require_errno(gv);
}
return gv;
} else if (add & GV_NOINIT) {
gv_init(gv, stash, name, len, add & GV_ADDMULTI);
gv_init_sv(gv, sv_type);
- if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
+ if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
+ : (PL_dowarn & G_WARN_ON ) ) )
GvMULTI_on(gv) ;
/* set up magic where warranted */
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
GvMULTI_on(gv);
- sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
+ sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
/* NOTE: No support for tied ISA */
if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
- hv_magic(hv, Nullgv, 'A');
+ hv_magic(hv, Nullgv, PERL_MAGIC_overload);
}
break;
case 'S':
HV *hv;
I32 i;
if (!PL_psig_ptr) {
- int sig_num[] = { SIG_NUM };
- New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
- New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
+ Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
+ Newz(73, PL_psig_name, SIG_SIZE, SV*);
+ Newz(73, PL_psig_pend, SIG_SIZE, int);
}
GvMULTI_on(gv);
hv = GvHVn(gv);
- hv_magic(hv, Nullgv, 'S');
- for (i = 1; PL_sig_name[i]; i++) {
+ hv_magic(hv, Nullgv, PERL_MAGIC_sig);
+ for (i = 1; i < SIG_SIZE; i++) {
SV ** init;
init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
if (init)
sv_setsv(*init, &PL_sv_undef);
PL_psig_ptr[i] = 0;
PL_psig_name[i] = 0;
+ PL_psig_pend[i] = 0;
}
}
break;
case '!':
if (len > 1)
break;
- if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
- HV* stash = gv_stashpvn("Errno",5,FALSE);
- if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
- dSP;
- PUTBACK;
- require_pv("Errno.pm");
- SPAGAIN;
- stash = gv_stashpvn("Errno",5,FALSE);
- if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
- Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
- }
- }
- goto magicalize;
+
+ /* If %! has been used, automatically load Errno.pm.
+ The require will itself set errno, so in order to
+ preserve its value we have to set up the magic
+ now (rather than going to magicalize)
+ */
+
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+
+ if (sv_type == SVt_PVHV)
+ require_errno(gv);
+
+ break;
case '-':
if (len > 1)
break;
else {
AV* av = GvAVn(gv);
- sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
+ sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
goto magicalize;
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;
else {
AV* av = GvAVn(gv);
- sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
+ sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
/* FALL THROUGH */
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:
- sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
break;
case '\014': /* $^L */
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 */
* module, don't bother warning */
if (file
&& PERL_FILE_IS_ABSOLUTE(file)
- && (instr(file, "/lib/") || instr(file, ".pm")))
+#ifdef MACOS_TRADITIONAL
+ && (instr(file, ":lib:")
+#else
+ && (instr(file, "/lib/")
+#endif
+ || instr(file, ".pm")))
{
continue;
}
}
#endif /* Microport 2.4 hack */
+int
+Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
+{
+ AMT *amtp = (AMT*)mg->mg_ptr;
+ if (amtp && AMT_AMAGIC(amtp)) {
+ int i;
+ for (i = 1; i < NofAMmeth; i++) {
+ CV *cv = amtp->table[i];
+ if (cv != Nullcv) {
+ SvREFCNT_dec((SV *) cv);
+ amtp->table[i] = Nullcv;
+ }
+ }
+ }
+ return 0;
+}
+
/* Updates and caches the CV's */
bool
{
GV* gv;
CV* cv;
- MAGIC* mg=mg_find((SV*)stash,'c');
+ 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)
- return AMT_AMAGIC(amtp);
- if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
- int i;
- for (i=1; i<NofAMmeth; i++) {
- if (amtp->table[i]) {
- SvREFCNT_dec(amtp->table[i]);
- }
- }
- }
- sv_unmagic((SV*)stash, 'c');
+ return AMT_OVERLOADED(amtp);
+ sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
+ Zero(&amt,1,AMT);
amt.was_ok_am = PL_amagic_generation;
amt.was_ok_sub = PL_sub_generation;
amt.fallback = AMGfallNO;
amt.flags = 0;
{
- int filled = 0;
- int i;
- const char *cp;
+ int filled = 0, have_ovl = 0;
+ int i, lim = 1;
SV* sv = NULL;
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
sv = GvSV(gv);
if (!gv)
- goto no_table;
+ lim = DESTROY_amg; /* Skip overloading entries. */
else if (SvTRUE(sv))
amt.fallback=AMGfallYES;
else if (SvOK(sv))
amt.fallback=AMGfallNEVER;
- for (i = 1; i < NofAMmeth; i++) {
- char *cooky = PL_AMG_names[i];
- char *cp = AMG_id2name(i); /* Human-readable form, for debugging */
+ for (i = 1; i < lim; i++)
+ amt.table[i] = Nullcv;
+ for (; i < NofAMmeth; i++) {
+ char *cooky = (char*)PL_AMG_names[i];
+ /* Human-readable form, for debugging: */
+ char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
STRLEN l = strlen(cooky);
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
GV *ngv;
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)))
cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
GvNAME(CvGV(cv))) );
filled = 1;
+ if (i < DESTROY_amg)
+ have_ovl = 1;
}
amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
if (filled) {
AMT_AMAGIC_on(&amt);
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
- return TRUE;
+ if (have_ovl)
+ AMT_OVERLOADED_on(&amt);
+ sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
+ (char*)&amt, sizeof(AMT));
+ return have_ovl;
}
}
/* Here we have no table: */
- no_table:
+ /* no_table: */
AMT_AMAGIC_off(&amt);
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
+ sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
+ (char*)&amt, sizeof(AMTS));
return FALSE;
}
+
+CV*
+Perl_gv_handler(pTHX_ HV *stash, I32 id)
+{
+ MAGIC *mg;
+ AMT *amtp;
+
+ if (!stash)
+ return Nullcv;
+ mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
+ if (!mg) {
+ do_update:
+ Gv_AMupdate(stash);
+ mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
+ }
+ amtp = (AMT*)mg->mg_ptr;
+ if ( amtp->was_ok_am != PL_amagic_generation
+ || amtp->was_ok_sub != PL_sub_generation )
+ goto do_update;
+ if (AMT_AMAGIC(amtp))
+ return amtp->table[id];
+ return Nullcv;
+}
+
+
SV*
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))),'c'))
+ && (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) {
lr = 1;
}
break;
+ case int_amg:
case iter_amg: /* XXXX Eventually should do to_gv. */
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
- && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
+ && (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 */
https://perl5.git.perl.org / perl5.git / blobdiff