X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Foverload.t;h=1f9bc1ba2f0ff48cbdf34d00c2c0d56c31d188df;hb=d00e3d8a4128dcffa1eb58ae423543a07d0589f8;hp=cf553ceb86c0f7c027fb0aca7c5616cde486d891;hpb=dd2eae666980a8d8bd145f2f6cc632a45513f9ce;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/overload.t b/lib/overload.t
index cf553ce..1f9bc1b 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -31,7 +31,7 @@ use overload (
 
 qw(
 ""	stringify
-0+	numify)			# Order of arguments unsignificant
+0+	numify)			# Order of arguments insignificant
 );
 
 sub new {
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" }	# Not needed, additional overhead
 package main;
 
 $| = 1;
-use Test::More tests=>503;
+use Test::More tests => 577;
 
 
 $a = new Oscalar "087";
@@ -361,6 +361,13 @@ is(($aII << 3), '_<<_087_<<_');
 }
 is($int, 9);
 is($out, 1024);
+is($int, 9);
+{
+  BEGIN { overload::constant 'integer' => sub {$int++; shift()+1}; }
+  eval q{$out = 42};
+}
+is($int, 10);
+is($out, 43);
 
 $foo = 'foo';
 $foo1 = 'f\'o\\o';
@@ -744,10 +751,10 @@ else {
 		    }, 'deref';
   # Hash:
   my @cont = sort %$deref;
-  if ("\t" eq "\011") { # ascii
+  if ("\t" eq "\011") { # ASCII
       is("@cont", '23 5 fake foo');
   } 
-  else {                # ebcdic alpha-numeric sort order
+  else {                # EBCDIC alpha-numeric sort order
       is("@cont", 'fake foo 23 5');
   }
   my @keys = sort keys %$deref;
@@ -986,7 +993,7 @@ unless ($aaa) {
   main::is("$int_x", 1054);
 }
 
-# make sure that we don't inifinitely recurse
+# make sure that we don't infinitely recurse
 {
   my $c = 0;
   package Recurse;
@@ -1125,13 +1132,13 @@ like ($@, qr/zap/);
     like(overload::StrVal(sub{1}),    qr/^CODE\(0x[0-9a-f]+\)$/);
     like(overload::StrVal(\*GLOB),    qr/^GLOB\(0x[0-9a-f]+\)$/);
     like(overload::StrVal(\$o),       qr/^REF\(0x[0-9a-f]+\)$/);
-    like(overload::StrVal(qr/a/),     qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
+    like(overload::StrVal(qr/a/),     qr/^Regexp=REGEXP\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($o),        qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($of),       qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/);
     like(overload::StrVal($no),       qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
 }
 
-# These are all check that overloaded values rather than reference addressess
+# These are all check that overloaded values rather than reference addresses
 # are what is getting tested.
 my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
 my ($ein, $zwei) = (1, 2);
@@ -1212,7 +1219,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     my $obj;
     $obj = bless {name => 'cool'}, 'Sklorsh';
     $obj->delete;
-    ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexist namespace');
+    ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexistent namespace');
 
     $obj = bless {name => 'cool'}, 'Sklorsh';
     $obj->delete_with_self;
@@ -1225,3 +1232,262 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     ok(!$b, "Expect overloaded boolean");
     ok(!$a, "Expect overloaded boolean");
 }
+
+{
+    package Flrbbbbb;
+    use overload
+	bool	 => sub { shift->{truth} eq 'yes' },
+	'0+'	 => sub { shift->{truth} eq 'yes' ? '1' : '0' },
+	'!'	 => sub { shift->{truth} eq 'no' },
+	fallback => 1;
+
+    sub new { my $class = shift; bless { truth => shift }, $class }
+
+    package main;
+
+    my $yes = Flrbbbbb->new('yes');
+    my $x;
+    $x = 1 if $yes;			is($x, 1);
+    $x = 2 unless $yes;			is($x, 1);
+    $x = 3 if !$yes;			is($x, 1);
+    $x = 4 unless !$yes;		is($x, 4);
+
+    my $no = Flrbbbbb->new('no');
+    $x = 0;
+    $x = 1 if $no;			is($x, 0);
+    $x = 2 unless $no;			is($x, 2);
+    $x = 3 if !$no;			is($x, 3);
+    $x = 4 unless !$no;			is($x, 3);
+
+    $x = 0;
+    $x = 1 if !$no && $yes;		is($x, 1);
+    $x = 2 unless !$no && $yes;		is($x, 1);
+    $x = 3 if $no || !$yes;		is($x, 1);
+    $x = 4 unless $no || !$yes;		is($x, 4);
+
+    $x = 0;
+    $x = 1 if !$no || !$yes;		is($x, 1);
+    $x = 2 unless !$no || !$yes;	is($x, 1);
+    $x = 3 if !$no && !$yes;		is($x, 1);
+    $x = 4 unless !$no && !$yes;	is($x, 4);
+}
+
+{
+    use Scalar::Util 'weaken';
+
+    package Shklitza;
+    use overload '""' => sub {"CLiK KLAK"};
+
+    package Ksshfwoom;
+
+    package main;
+
+    my ($obj, $ref);
+    $obj = bless do {my $a; \$a}, 'Shklitza';
+    $ref = $obj;
+
+    is ($obj, "CLiK KLAK");
+    is ($ref, "CLiK KLAK");
+
+    weaken $ref;
+    is ($ref, "CLiK KLAK");
+
+    bless $obj, 'Ksshfwoom';
+
+    like ($obj, qr/^Ksshfwoom=/);
+    like ($ref, qr/^Ksshfwoom=/);
+
+    undef $obj;
+    is ($ref, undef);
+}
+
+{
+    package bit;
+    # bit operations have overloadable assignment variants too
+
+    sub new { bless \$_[1], $_[0] }
+
+    use overload
+          "&=" => sub { bit->new($_[0]->val . ' & ' . $_[1]->val) }, 
+          "^=" => sub { bit->new($_[0]->val . ' ^ ' . $_[1]->val) },
+          "|"  => sub { bit->new($_[0]->val . ' | ' . $_[1]->val) }, # |= by fallback
+          ;
+
+    sub val { ${$_[0]} }
+
+    package main;
+
+    my $a = bit->new(my $va = 'a');
+    my $b = bit->new(my $vb = 'b');
+
+    $a &= $b;
+    is($a->val, 'a & b', "overloaded &= works");
+
+    my $c = bit->new(my $vc = 'c');
+
+    $b ^= $c;
+    is($b->val, 'b ^ c', "overloaded ^= works");
+
+    my $d = bit->new(my $vd = 'd');
+
+    $c |= $d;
+    is($c->val, 'c | d', "overloaded |= (by fallback) works");
+}
+
+{
+    # comparison operators with nomethod
+    my $warning = "";
+    my $method;
+
+    package nomethod_false;
+    use overload nomethod => sub { $method = 'nomethod'; 0 };
+
+    package nomethod_true;
+    use overload nomethod => sub { $method= 'nomethod'; 'true' };
+
+    package main;
+    local $^W = 1;
+    local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+    my $f = bless [], 'nomethod_false';
+    ($warning, $method) = ("", "");
+    is($f eq 'whatever', 0, 'nomethod makes eq return 0');
+    is($method, 'nomethod');
+
+    my $t = bless [], 'nomethod_true';
+    ($warning, $method) = ("", "");
+    is($t eq 'whatever', 'true', 'nomethod makes eq return "true"');
+    is($method, 'nomethod');
+    is($warning, "", 'nomethod eq need not return number');
+
+    eval q{ 
+        package nomethod_false;
+        use overload cmp => sub { $method = 'cmp'; 0 };
+    };
+    $f = bless [], 'nomethod_false';
+    ($warning, $method) = ("", "");
+    ok($f eq 'whatever', 'eq falls back to cmp (nomethod not called)');
+    is($method, 'cmp');
+
+    eval q{
+        package nomethod_true;
+        use overload cmp => sub { $method = 'cmp'; 'true' };
+    };
+    $t = bless [], 'nomethod_true';
+    ($warning, $method) = ("", "");
+    ok($t eq 'whatever', 'eq falls back to cmp (nomethod not called)');
+    is($method, 'cmp');
+    like($warning, qr/isn't numeric/, 'cmp should return number');
+
+}
+
+{
+    # Subtle bug pre 5.10, as a side effect of the overloading flag being
+    # stored on the reference rather than the referent. Despite the fact that
+    # objects can only be accessed via references (even internally), the
+    # referent actually knows that it's blessed, not the references. So taking
+    # a new, unrelated, reference to it gives an object. However, the
+    # overloading-or-not flag was on the reference prior to 5.10, and taking
+    # a new reference didn't (use to) copy it.
+
+    package kayo;
+
+    use overload '""' => sub {${$_[0]}};
+
+    sub Pie {
+	return "$_[0], $_[1]";
+    }
+
+    package main;
+
+    my $class = 'kayo';
+    my $string = 'bam';
+    my $crunch_eth = bless \$string, $class;
+
+    is("$crunch_eth", $string);
+    is ($crunch_eth->Pie("Meat"), "$string, Meat");
+
+    my $wham_eth = \$string;
+
+    is("$wham_eth", $string,
+       'This reference did not have overloading in 5.8.8 and earlier');
+    is ($crunch_eth->Pie("Apple"), "$string, Apple");
+
+    my $class = ref $wham_eth;
+    $class =~ s/=.*//;
+
+    # Bless it back into its own class!
+    bless $wham_eth, $class;
+
+    is("$wham_eth", $string);
+    is ($crunch_eth->Pie("Blackbird"), "$string, Blackbird");
+}
+
+{
+    package numify_int;
+    use overload "0+" => sub { $_[0][0] += 1; 42 };
+    package numify_self;
+    use overload "0+" => sub { $_[0][0]++; $_[0] };
+    package numify_other;
+    use overload "0+" => sub { $_[0][0]++; $_[0][1] = bless [], 'numify_int' };
+    package numify_by_fallback;
+    use overload fallback => 1;
+
+    package main;
+    my $o = bless [], 'numify_int';
+    is(int($o), 42, 'numifies to integer');
+    is($o->[0], 1, 'int() numifies only once');
+
+    my $aref = [];
+    my $num_val = int($aref);
+    my $r = bless $aref, 'numify_self';
+    is(int($r), $num_val, 'numifies to self');
+    is($r->[0], 1, 'int() numifies once when returning self');
+
+    my $s = bless [], 'numify_other';
+    is(int($s), 42, 'numifies to numification of other object');
+    is($s->[0], 1, 'int() numifies once when returning other object');
+    is($s->[1][0], 1, 'returned object numifies too');
+
+    my $m = bless $aref, 'numify_by_fallback';
+    is(int($m), $num_val, 'numifies to usual reference value');
+    is(abs($m), $num_val, 'numifies to usual reference value');
+    is(-$m, -$num_val, 'numifies to usual reference value');
+    is(0+$m, $num_val, 'numifies to usual reference value');
+    is($m+0, $num_val, 'numifies to usual reference value');
+    is($m+$m, 2*$num_val, 'numifies to usual reference value');
+    is(0-$m, -$num_val, 'numifies to usual reference value');
+    is(1*$m, $num_val, 'numifies to usual reference value');
+    is($m/1, $num_val, 'numifies to usual reference value');
+    is($m%100, $num_val%100, 'numifies to usual reference value');
+    is($m**1, $num_val, 'numifies to usual reference value');
+
+    is(abs($aref), $num_val, 'abs() of ref');
+    is(-$aref, -$num_val, 'negative of ref');
+    is(0+$aref, $num_val, 'ref addition');
+    is($aref+0, $num_val, 'ref addition');
+    is($aref+$aref, 2*$num_val, 'ref addition');
+    is(0-$aref, -$num_val, 'subtraction of ref');
+    is(1*$aref, $num_val, 'multiplicaton of ref');
+    is($aref/1, $num_val, 'division of ref');
+    is($aref%100, $num_val%100, 'modulo of ref');
+    is($aref**1, $num_val, 'exponentiation of ref');
+}
+
+{
+    package CopyConstructorFallback;
+    use overload
+        '++'        => sub { "$_[0]"; $_[0] },
+        fallback    => 1;
+    sub new { bless {} => shift }
+
+    package main;
+
+    my $o = CopyConstructorFallback->new;
+    my $x = $o++; # would segfault
+    my $y = ++$o;
+    is($x, $o, "copy constructor falls back to assignment (postinc)");
+    is($y, $o, "copy constructor falls back to assignment (preinc)");
+}
+
+# EOF