/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
- * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * 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.
/*
* '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"]
*/
/*
#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)
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) {
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
}
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)))
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;
{
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;
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) {
if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
{
- const char *pname;
- av_push(av, newSVpvs(pname = "NDBM_File"));
- gv_stashpvn(pname, 9, GV_ADD);
- av_push(av, newSVpvs(pname = "DB_File"));
- gv_stashpvn(pname, 7, GV_ADD);
- av_push(av, newSVpvs(pname = "GDBM_File"));
- gv_stashpvn(pname, 9, GV_ADD);
- av_push(av, newSVpvs(pname = "SDBM_File"));
- gv_stashpvn(pname, 9, GV_ADD);
- av_push(av, newSVpvs(pname = "ODBM_File"));
- 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;
case ')':
case '<':
case '>':
- case ',':
case '\\':
case '/':
case '\001': /* $^A */
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);
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((const SV *)stash, PERL_MAGIC_overload_table))
PUSHs(MUTABLE_SV(cv));
PUTBACK;
- if ((PL_op = Perl_pp_entersub(aTHX)))
+ if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
CALLRUNOPS(aTHX);
LEAVE;
SPAGAIN;
/*
=for apidoc is_gv_magical_sv
-Returns C<TRUE> 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<TRUE> if given the name of a magical GV.
Currently only useful internally when determining if a GV should be
=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;
case ')':
case '<':
case '>':
- case ',':
case '\\':
case '/':
case '|':
projects / p5sagit/p5-mst-13.2.git / blobdiff