Front page | perl.perl5.porters |
Postings from August 2008
[PATCH] 'overloading' pragma
Thread Next
From:
Yuval Kogman
Date:
August 9, 2008 05:41
Subject:
[PATCH] 'overloading' pragma
Message ID:
1218285644-44651-1-git-send-email-nothingmuch@woobling.org
---
gv.c | 20 +++++++++++
lib/overloading.pm | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++
lib/overloading.t | 74 ++++++++++++++++++++++++++++++++++++++++
overload.pl | 45 ++++++++++++++++++++++++-
perl.h | 2 +
5 files changed, 235 insertions(+), 1 deletions(-)
create mode 100644 lib/overloading.pm
create mode 100644 lib/overloading.t
diff --git a/gv.c b/gv.c
index da79403..91b74a0 100644
--- a/gv.c
+++ b/gv.c
@@ -1851,6 +1851,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 ( len > (STRLEN)offset && 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))
diff --git a/lib/overloading.pm b/lib/overloading.pm
new file mode 100644
index 0000000..be166fc
--- /dev/null
+++ b/lib/overloading.pm
@@ -0,0 +1,95 @@
+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 ) = @_;
+
+ $^H |= 0x01000000;
+
+ if ( @ops ) {
+ vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops);
+ }
+}
+
+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 0000000..9a78615
--- /dev/null
+++ b/lib/overloading.t
@@ -0,0 +1,74 @@
+#./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ require "./test.pl";
+ plan(tests => 18);
+}
+
+{
+ 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" );
+
+ use Scalar::Util qw(refaddr);
+ is( 0 + $x, refaddr($x), "no numification" );
+}
+
+{
+ no overloading '""';
+
+ is( "$x", overload::StrVal($x), "no stringification" );
+ is( 0 + $x, 42, "numifies" );
+
+ 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 69808c6..eadfa8f 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,49 @@ 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 -*-
+#
+# overload_numbers.pm
+#
+# Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 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 +141,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 7e66b56..c5ff9c2 100644
--- a/perl.h
+++ b/perl.h
@@ -4624,6 +4624,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
--
1.5.6.1.108.g660379
Thread Next
-
[PATCH] 'overloading' pragma
by Yuval Kogman