X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=65419bdfefcc118824f74b832adb8516db63bbec;hb=0598b5ab3697b872539de6ed6dc1522b873602e1;hp=da794039f7b49a1ee9e2b40a4a34bf53dac8028b;hpb=547bb2675d6f6f0c11281a37d160943a92b3a025;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index da79403..65419bd 100644 --- a/gv.c +++ b/gv.c @@ -1,7 +1,7 @@ /* gv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -10,11 +10,13 @@ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure - * of your inquisitiveness, I shall spend all the rest of my days answering + * of your inquisitiveness, I shall spend all the rest of my days in answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. + * + * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* @@ -45,7 +47,7 @@ Perl_gv_SVadd(pTHX_ GV *gv) { PERL_ARGS_ASSERT_GV_SVADD; - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for scalar"); if (!GvSV(gv)) GvSV(gv) = newSV(0); @@ -58,7 +60,7 @@ Perl_gv_AVadd(pTHX_ register GV *gv) { PERL_ARGS_ASSERT_GV_AVADD; - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); @@ -70,7 +72,7 @@ Perl_gv_HVadd(pTHX_ register GV *gv) { PERL_ARGS_ASSERT_GV_HVADD; - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); @@ -84,7 +86,7 @@ Perl_gv_IOadd(pTHX_ register GV *gv) PERL_ARGS_ASSERT_GV_IOADD; - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) { + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { /* * if it walks like a dirhandle, then let's assume that @@ -150,7 +152,7 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, #else sv_setpvn(GvSV(gv), name, namelen); #endif - if (PERLDB_LINE) + if (PERLDB_LINE || PERLDB_SAVESRC) hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) @@ -256,7 +258,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) if (old_type < SVt_PVGV) { if (old_type >= SVt_PV) SvCUR_set(gv, 0); - sv_upgrade((SV*)gv, SVt_PVGV); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); } if (SvLEN(gv)) { if (proto) { @@ -272,7 +274,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvGP(gv) = Perl_newGP(aTHX_ gv); GvSTASH(gv) = stash; if (stash) - Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); gv_name_set(gv, name, len, GV_ADD); if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); @@ -297,7 +299,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; if (proto) { - sv_usepvn_flags((SV*)GvCV(gv), proto, protolen, + sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, SV_HAS_TRAILING_NUL); } } @@ -588,7 +590,7 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) gv_init(gv, stash, "ISA", 3, TRUE); superisa = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)superisa, (SV*)gv, PERL_MAGIC_isa, NULL, 0); + sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); #ifdef USE_ITHREADS av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); #else @@ -618,7 +620,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) GV* gv; HV* ostash = stash; const char * const origname = name; - SV *const error_report = (SV *)stash; + SV *const error_report = MUTABLE_SV(stash); const U32 autoload = flags & GV_AUTOLOAD; const U32 do_croak = flags & GV_CROAK; @@ -669,7 +671,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = (GV*)&PL_sv_yes; + gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); if (!gv && do_croak) { @@ -739,7 +741,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_const((SV*)stash, packname_len); + packname = SvPV_const(MUTABLE_SV(stash), packname_len); stash = NULL; } else { @@ -996,7 +998,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, tmpbuf[len++] = ':'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); gv = gvp ? *gvp : NULL; - if (gv && gv != (GV*)&PL_sv_undef) { + if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else @@ -1004,7 +1006,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } if (tmpbuf != smallbuf) Safefree(tmpbuf); - if (!gv || gv == (GV*)&PL_sv_undef) + if (!gv || gv == (const GV *)&PL_sv_undef) return NULL; if (!(stash = GvHV(gv))) @@ -1019,7 +1021,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, name_cursor++; name = name_cursor; if (name == name_end) - return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE); + return gv + ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); } } len = name_cursor - name; @@ -1080,7 +1083,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || - *gvp == (GV*)&PL_sv_undef || + *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { stash = NULL; @@ -1120,7 +1123,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); - gv = gv_fetchpvn_flags("::", 8, GV_ADDMULTI, SVt_PVHV); + gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); if(!gv) { /* symbol table under destruction */ return NULL; @@ -1135,7 +1138,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (GV*)&PL_sv_undef) + if (!gvp || *gvp == (const GV *)&PL_sv_undef) return NULL; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { @@ -1204,22 +1207,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "SA")) { AV* const av = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0); + sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, + NULL, 0); /* NOTE: No support for tied ISA */ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { - const char *pname; - av_push(av, newSVpvn(pname = "NDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "DB_File",7)); - gv_stashpvn(pname, 7, GV_ADD); - av_push(av, newSVpvn(pname = "GDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "SDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "ODBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); + av_push(av, newSVpvs("NDBM_File")); + gv_stashpvs("NDBM_File", GV_ADD); + av_push(av, newSVpvs("DB_File")); + gv_stashpvs("DB_File", GV_ADD); + av_push(av, newSVpvs("GDBM_File")); + gv_stashpvs("GDBM_File", GV_ADD); + av_push(av, newSVpvs("SDBM_File")); + gv_stashpvs("SDBM_File", GV_ADD); + av_push(av, newSVpvs("ODBM_File")); + gv_stashpvs("ODBM_File", GV_ADD); } } break; @@ -1342,7 +1345,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) @@ -1354,10 +1357,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvMULTI_on(gv); /* no used once warnings here */ { AV* const av = GvAVn(gv); - SV* const avc = (*name == '+') ? (SV*)av : NULL; + SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; - sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0); - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); if (avc) SvREADONLY_on(GvSVn(gv)); SvREADONLY_on(av); @@ -1406,7 +1409,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case ')': case '<': case '>': - case ',': case '\\': case '/': case '\001': /* $^A */ @@ -1421,15 +1423,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\024': /* $^T */ case '\027': /* $^W */ magicalize: - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); break; case '\014': /* $^L */ - sv_setpvn(GvSVn(gv),"\f",1); + sv_setpvs(GvSVn(gv),"\f"); PL_formfeed = GvSVn(gv); break; case ';': - sv_setpvn(GvSVn(gv),"\034",1); + sv_setpvs(GvSVn(gv),"\034"); break; case ']': { @@ -1499,7 +1501,7 @@ Perl_newIO(pTHX) { dVAR; GV *iogv; - IO * const io = (IO*)newSV_type(SVt_PVIO); + IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO)); /* This used to read SvREFCNT(io) = 1; It's not clear why the reference count needed an explicit reset. NWC */ @@ -1511,7 +1513,7 @@ Perl_newIO(pTHX) /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); - SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); return io; } @@ -1531,14 +1533,14 @@ Perl_gv_check(pTHX_ const HV *stash) register GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && - (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } else if (isALPHA(*HeKEY(entry))) { const char *file; - gv = (GV*)HeVAL(entry); + gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; file = GvFILE(gv); @@ -1646,7 +1648,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; if (cv) { - SvREFCNT_dec((SV *) cv); + SvREFCNT_dec(MUTABLE_SV(cv)); amtp->table[i] = NULL; } } @@ -1660,7 +1662,7 @@ bool Perl_Gv_AMupdate(pTHX_ HV *stash) { dVAR; - MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; const struct mro_meta* stash_meta = HvMROMETA(stash); U32 newgen; @@ -1674,7 +1676,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) && amtp->was_ok_sub == newgen) { return (bool)AMT_OVERLOADED(amtp); } - sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); + sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); @@ -1764,16 +1766,16 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (i < DESTROY_amg) have_ovl = 1; } else if (gv) { /* Autoloaded... */ - cv = (CV*)gv; + cv = MUTABLE_CV(gv); filled = 1; } - amt.table[i]=(CV*)SvREFCNT_inc_simple(cv); + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); } if (filled) { AMT_AMAGIC_on(&amt); if (have_ovl) AMT_OVERLOADED_on(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); return have_ovl; } @@ -1781,7 +1783,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* Here we have no table: */ /* no_table: */ AMT_AMAGIC_off(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); return FALSE; } @@ -1802,11 +1804,11 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) stash_meta = HvMROMETA(stash); newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: Gv_AMupdate(stash); - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; @@ -1851,9 +1853,30 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PERL_ARGS_ASSERT_AMAGIC_CALL; + if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { + SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + 0, "overloading", 11, 0, 0); + + if ( !lex_mask || !SvOK(lex_mask) ) + /* overloading lexically disabled */ + return NULL; + else if ( lex_mask && SvPOK(lex_mask) ) { + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return NULL; + } + } + if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (stash = SvSTASH(SvRV(left))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table : NULL)) @@ -1922,7 +1945,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) Hence we can't use SvAMAGIC_on() */ SvFLAGS(newref) |= SVf_AMAGIC; - SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); + SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); return newref; } } @@ -1977,7 +2000,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (stash = SvSTASH(SvRV(right))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : NULL)) @@ -2151,10 +2174,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), AMG_id2namelen(method + assignshift), SVs_TEMP)); } - PUSHs((SV*)cv); + PUSHs(MUTABLE_SV(cv)); PUTBACK; - if ((PL_op = Perl_pp_entersub(aTHX))) + if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; @@ -2208,25 +2231,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* =for apidoc is_gv_magical_sv -Returns C if given the name of a magical GV. Calls is_gv_magical. - -=cut -*/ - -bool -Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags) -{ - STRLEN len; - const char * const temp = SvPV_const(name, len); - - PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; - - return is_gv_magical(temp, len, flags); -} - -/* -=for apidoc is_gv_magical - Returns C if given the name of a magical GV. Currently only useful internally when determining if a GV should be @@ -2241,13 +2245,15 @@ pointers returned by SvPV. =cut */ + bool -Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) +Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) { - PERL_UNUSED_CONTEXT; - PERL_UNUSED_ARG(flags); + STRLEN len; + const char *const name = SvPV_const(name_sv, len); - PERL_ARGS_ASSERT_IS_GV_MAGICAL; + PERL_UNUSED_ARG(flags); + PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; if (len > 1) { const char * const name1 = name + 1; @@ -2325,7 +2331,6 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case ')': case '<': case '>': - case ',': case '\\': case '/': case '|':