'overloading' pragma

7 files changed, 412 insertions, 1 deletions

diff --git a/MANIFEST b/MANIFEST
index 6cdbe99ec7..217fd957d0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2547,6 +2547,9 @@ lib/open.t			See if the open pragma works
 lib/overload64.t		See if operator overloading works with 64-bit ints
 lib/overload.pm			Module for overloading perl operators
 lib/overload.t			See if operator overloading works
+lib/overload/numbers.pm		Helper for overloading pragma
+lib/overloading.pm		Pragma to lexically control overloading
+lib/overloading.t		Tests for overloading.pm
 lib/Package/Constants.pm	Package::Constants
 lib/Package/Constants/t/01_list.t	Package::Constants tests
 lib/Params/Check.pm	Params::Check
diff --git a/gv.c b/gv.c
index 74a9b2ecad..d64965d509 100644
--- a/gv.c
+++ b/gv.c
@@ -1853,6 +1853,26 @@ 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 */
+	  const int offset = method / 8;
+	  const int bit    = method % 7;
+	  STRLEN len;
+	  char *pv = SvPV(lex_mask, len);
+
+	  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))
diff --git a/lib/overload/numbers.pm b/lib/overload/numbers.pm
new file mode 100644
index 0000000000..b76875891a
--- /dev/null
+++ b/lib/overload/numbers.pm
@@ -0,0 +1,159 @@
+# -*- buffer-read-only: t -*-
+#
+#   lib/overload/numbers.pm
+#
+#   Copyright (C) 2008 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.
+#
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+# This file is built by overload.pl
+#
+
+package overload::numbers;
+
+our @names = qw#
+    ()
+    (${}
+    (@{}
+    (%{}
+    (*{}
+    (&{}
+    (++
+    (--
+    (bool
+    (0+
+    (""
+    (!
+    (=
+    (abs
+    (neg
+    (<>
+    (int
+    (<
+    (<=
+    (>
+    (>=
+    (==
+    (!=
+    (lt
+    (le
+    (gt
+    (ge
+    (eq
+    (ne
+    (nomethod
+    (+
+    (+=
+    (-
+    (-=
+    (*
+    (*=
+    (/
+    (/=
+    (%
+    (%=
+    (**
+    (**=
+    (<<
+    (<<=
+    (>>
+    (>>=
+    (&
+    (&=
+    (|
+    (|=
+    (^
+    (^=
+    (<=>
+    (cmp
+    (~
+    (atan2
+    (cos
+    (sin
+    (exp
+    (log
+    (sqrt
+    (x
+    (x=
+    (.
+    (.=
+    (~~
+    DESTROY
+#;
+
+our @enums = qw#
+    fallback
+    to_sv
+    to_av
+    to_hv
+    to_gv
+    to_cv
+    inc
+    dec
+    bool_
+    numer
+    string
+    not
+    copy
+    abs
+    neg
+    iter
+    int
+    lt
+    le
+    gt
+    ge
+    eq
+    ne
+    slt
+    sle
+    sgt
+    sge
+    seq
+    sne
+    nomethod
+    add
+    add_ass
+    subtr
+    subtr_ass
+    mult
+    mult_ass
+    div
+    div_ass
+    modulo
+    modulo_ass
+    pow
+    pow_ass
+    lshift
+    lshift_ass
+    rshift
+    rshift_ass
+    band
+    band_ass
+    bor
+    bor_ass
+    bxor
+    bxor_ass
+    ncmp
+    scmp
+    compl
+    atan2
+    cos
+    sin
+    exp
+    log
+    sqrt
+    repeat
+    repeat_ass
+    concat
+    concat_ass
+    smart
+    DESTROY
+#;
+
+{ my $i; our %names = map { $_ => ++$i } @names }
+
+{ my $i; our %enums = map { $_ => ++$i } @enums }
+
diff --git a/lib/overloading.pm b/lib/overloading.pm
new file mode 100644
index 0000000000..23551ded13
--- /dev/null
+++ b/lib/overloading.pm
@@ -0,0 +1,99 @@
+package overloading;
+use warnings;
+
+use Carp ();
+
+our $VERSION = '0.01';
+
+require 5.011000;
+
+sub _ops_to_nums {
+    require overload::numbers;
+
+    map { exists $overload::numbers::names{"($_"}
+	? $overload::numbers::names{"($_"}
+	: Carp::croak("'$_' is not a valid overload")
+    } @_;
+}
+
+sub import {
+    my ( $class, @ops ) = @_;
+
+    if ( @ops ) {
+	if ( $^H{overloading} ) {
+	    vec($^H{overloading} , $_, 1) = 0 for _ops_to_nums(@ops);
+	}
+
+	if ( $^H{overloading} !~ /[^\0]/ ) {
+	    delete $^H{overloading};
+	    $^H &= ~0x01000000;
+	}
+    } else {
+	delete $^H{overloading};
+	$^H &= ~0x01000000;
+    }
+}
+
+sub unimport {
+    my ( $class, @ops ) = @_;
+
+    if ( exists $^H{overloading} or not $^H & 0x01000000 ) {
+	if ( @ops ) {
+	    vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops);
+	} else {
+	    delete $^H{overloading};
+	}
+    }
+
+    $^H |= 0x01000000;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+overloading - perl pragma to lexically control overloading
+
+=head1 SYNOPSIS
+
+    {
+	no overloading;
+	my $str = "$object"; # doesn't call strirngification overload
+    }
+
+    # it's lexical, so this stringifies:
+    warn "$object";
+
+    # it can be enabled per op
+    no overloading qw("");
+    warn "$object"
+
+    # and also reenabled
+    use overloading;
+
+=head1 DESCRIPTION
+
+This pragma allows you to lexically disable or enable overloading.
+
+=over 6
+
+=item C<no overloading>
+
+Disables overloading entirely in the current lexical scope.
+
+=item C<no overloading @ops>
+
+Disables only specific overloads in the current lexical scopes.
+
+=item C<use overloading>
+
+Reenables overloading in the current lexical scope.
+
+=item C<use overloading @ops>
+
+Reenables overloading only for specific ops in the current lexical scope.
+
+=back
+
+=cut
diff --git a/lib/overloading.t b/lib/overloading.t
new file mode 100644
index 0000000000..8121cc8b41
--- /dev/null
+++ b/lib/overloading.t
@@ -0,0 +1,86 @@
+#./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+BEGIN {
+    require "./test.pl";
+    plan(tests => 22);
+}
+
+use Scalar::Util qw(refaddr);
+
+{
+    package Stringifies;
+
+    use overload (
+	fallback => 1,
+	'""' => sub { "foo" },
+	'0+' => sub { 42 },
+    );
+
+    sub new { bless {}, shift };
+}
+
+my $x = Stringifies->new;
+
+is( "$x", "foo", "stringifies" );
+is( 0 + $x, 42, "numifies" );
+
+{
+    no overloading;
+    is( "$x", overload::StrVal($x), "no stringification" );
+    is( 0 + $x, refaddr($x), "no numification" );
+
+    {
+	no overloading '""';
+	is( "$x", overload::StrVal($x), "no stringification" );
+	is( 0 + $x, refaddr($x), "no numification" );
+    }
+}
+
+{
+    no overloading '""';
+
+    is( "$x", overload::StrVal($x), "no stringification" );
+    is( 0 + $x, 42, "numifies" );
+
+    {
+	no overloading;
+	is( "$x", overload::StrVal($x), "no stringification" );
+	is( 0 + $x, refaddr($x), "no numification" );
+    }
+
+    use overloading '""';
+
+    is( "$x", "foo", "stringifies" );
+    is( 0 + $x, 42, "numifies" );
+
+    no overloading '0+';
+    is( "$x", "foo", "stringifies" );
+    is( 0 + $x, refaddr($x), "no numification" );
+
+    {
+	no overloading '""';
+	is( "$x", overload::StrVal($x), "no stringification" );
+	is( 0 + $x, refaddr($x), "no numification" );
+
+	{
+	    use overloading;
+	    is( "$x", "foo", "stringifies" );
+	    is( 0 + $x, 42, "numifies" );
+	}
+    }
+
+    is( "$x", "foo", "stringifies" );
+    is( 0 + $x, refaddr($x), "no numification" );
+
+
+    BEGIN { ok(exists($^H{overloading}), "overloading hint present") }
+
+    use overloading;
+
+    BEGIN { ok(!exists($^H{overloading}), "overloading hint removed") }
+}
diff --git a/overload.pl b/overload.pl
index 69808c6221..01dd550e4e 100644
--- a/overload.pl
+++ b/overload.pl
@@ -12,6 +12,8 @@ BEGIN {
 
 use strict;
 
+use File::Spec::Functions qw(catdir catfile);;
+
 my (@enums, @names);
 while (<DATA>) {
   next if /^#/;
@@ -21,9 +23,48 @@ while (<DATA>) {
   push @names, $name;
 }
 
-safer_unlink ('overload.h', 'overload.c');
+safer_unlink ('overload.h', 'overload.c', catfile(qw(lib overload numbers.pm)));
 my $c = safer_open("overload.c");
 my $h = safer_open("overload.h");
+mkdir("lib/overload") unless -d catdir(qw(lib overload));
+my $p = safer_open(catfile(qw(lib overload numbers.pm)));
+
+
+select $p;
+
+{
+local $" = "\n    ";
+print <<"EOF";
+# -*- buffer-read-only: t -*-
+#
+#   lib/overload/numbers.pm
+#
+#   Copyright (C) 2008 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.
+#
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+# This file is built by overload.pl
+#
+
+package overload::numbers;
+
+our \@names = qw#
+    @names
+#;
+
+our \@enums = qw#
+    @enums
+#;
+
+{ my \$i; our %names = map { \$_ => ++\$i } \@names }
+
+{ my \$i; our %enums = map { \$_ => ++\$i } \@enums }
+
+EOF
+}
+
 
 sub print_header {
   my $file = shift;
@@ -99,6 +140,7 @@ EOT
 
 safer_close($h);
 safer_close($c);
+safer_close($p);
 
 __DATA__
 # Fallback should be the first
diff --git a/perl.h b/perl.h
index c6008bb587..13de9050e7 100644
--- a/perl.h
+++ b/perl.h
@@ -4659,6 +4659,8 @@ enum {		/* pass one of these to get_vtbl */
 #define HINT_FILETEST_ACCESS	0x00400000 /* filetest pragma */
 #define HINT_UTF8		0x00800000 /* utf8 pragma */
 
+#define HINT_NO_AMAGIC		0x01000000 /* overloading pragma */
+
 /* The following are stored in $^H{sort}, not in PL_hints */
 #define HINT_SORT_SORT_BITS	0x000000FF /* allow 256 different ones */
 #define HINT_SORT_QUICKSORT	0x00000001