diff options
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | gv.c | 20 | ||||
| -rw-r--r-- | lib/overload/numbers.pm | 159 | ||||
| -rw-r--r-- | lib/overloading.pm | 99 | ||||
| -rw-r--r-- | lib/overloading.t | 86 | ||||
| -rw-r--r-- | overload.pl | 44 | ||||
| -rw-r--r-- | perl.h | 2 |
7 files changed, 412 insertions, 1 deletions
@@ -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 @@ -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 @@ -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 |