X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=c22f73aa6570c9a9a2bd1864a4421ead091d06d9;hb=c1413a7f3faf8fb1e44dd192e26d2ae52b8817ce;hp=58e6f8f0916bbe7243dee323a08a5986506d1bb7;hpb=139d0ce69f7cc12a8ffc1a75bbb5c65306d08d35;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 58e6f8f..c22f73a 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, 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.
@@ -103,11 +103,6 @@ Perl_gv_IOadd(pTHX_ register GV *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;
@@ -1853,6 +1848,27 @@ 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((const SV *)stash, PERL_MAGIC_overload_table))
@@ -1962,6 +1978,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	   break;
 	 case int_amg:
 	 case iter_amg:			/* XXXX Eventually should do to_gv. */
+	 case ftest_amg:		/* XXXX Eventually should do to_gv. */
 	     /* FAIL safe */
 	     return NULL;	/* Delegate operation to standard mechanisms. */
 	     break;
@@ -2210,25 +2227,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 /*
 =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
@@ -2243,13 +2241,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;