develooper 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


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About