X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Foverload.t;h=39333cff87a1dcb7aad456b477fcc50fbf981be9;hb=b595cd4b73a6e1bd45865d6446c34d4019c740d1;hp=78548605f3b404ddcf7717c48cbda77eab826a0c;hpb=b1fbf5c3d1dc6dd7934002da04dede2ae2e3ef65;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/overload.t b/lib/overload.t index 7854860..39333cf 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=>497; +use Test::More tests => 607; $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); @@ -1175,8 +1182,412 @@ foreach my $op (qw(<=> == != < <= > >=)) { } { + { + package QRonly; + use overload qr => sub { qr/x/ }, fallback => 1; + } + { + my $x = bless [], "QRonly"; + + # like tries to be too clever, and decides that $x-stringified + # doesn't look like a regex + ok("x" =~ $x, "qr-only matches"); + ok("y" !~ $x, "qr-only doesn't match what it shouldn't"); + ok("xx" =~ /x$x/, "qr-only matches with concat"); + like("$x", qr/^QRonly=ARRAY/, "qr-only doesn't have string overload"); + + my $qr = bless qr/y/, "QRonly"; + ok("x" =~ $qr, "qr with qr-overload uses overload"); + ok("y" !~ $qr, "qr with qr-overload uses overload"); + is("$qr", "".qr/y/, "qr with qr-overload stringify"); + + my $rx = $$qr; + ok("y" =~ $rx, "bare rx with qr-overload doesn't overload match"); + ok("x" !~ $rx, "bare rx with qr-overload doesn't overload match"); + is("$rx", "".qr/y/, "bare rx with qr-overload stringify"); + } + { + package QRandSTR; + use overload qr => sub { qr/x/ }, q/""/ => sub { "y" }; + } + { + my $x = bless [], "QRandSTR"; + ok("x" =~ $x, "qr+str uses qr for match"); + ok("y" !~ $x, "qr+str uses qr for match"); + ok("xx" =~ /x$x/, "qr+str uses qr for match with concat"); + is("$x", "y", "qr+str uses str for stringify"); + + my $qr = bless qr/z/, "QRandSTR"; + is("$qr", "y", "qr with qr+str uses str for stringify"); + ok("xx" =~ /x$x/, "qr with qr+str uses qr for match"); + + my $rx = $$qr; + ok("z" =~ $rx, "bare rx with qr+str doesn't overload match"); + is("$rx", "".qr/z/, "bare rx with qr+str doesn't overload stringify"); + } + { + package QRany; + use overload qr => sub { $_[0]->(@_) }; + + package QRself; + use overload qr => sub { $_[0] }; + } + { + my $rx = bless sub { ${ qr/x/ } }, "QRany"; + ok("x" =~ $rx, "qr overload accepts a bare rx"); + ok("y" !~ $rx, "qr overload accepts a bare rx"); + + my $str = bless sub { "x" }, "QRany"; + ok(!eval { "x" =~ $str }, "qr overload doesn't accept a string"); + like($@, qr/^Overloaded qr did not return a REGEXP/, "correct error"); + + my $oqr = bless qr/z/, "QRandSTR"; + my $oqro = bless sub { $oqr }, "QRany"; + ok("z" =~ $oqro, "qr overload doesn't recurse"); + + my $qrs = bless qr/z/, "QRself"; + ok("z" =~ $qrs, "qr overload can return self"); + } + { + package STRonly; + use overload q/""/ => sub { "x" }; + + package STRonlyFB; + use overload q/""/ => sub { "x" }, fallback => 1; + } + { + my $fb = bless [], "STRonlyFB"; + ok("x" =~ $fb, "qr falls back to \"\""); + ok("y" !~ $fb, "qr falls back to \"\""); + + my $nofb = bless [], "STRonly"; + ok("x" =~ $nofb, "qr falls back even without fallback"); + ok("y" !~ $nofb, "qr falls back even without fallback"); + } +} + +{ my $twenty_three = 23; # Check that constant overloading propagates into evals BEGIN { overload::constant integer => sub { 23 } } is(eval "17", $twenty_three); } + +{ + package Sklorsh; + use overload + bool => sub { shift->is_cool }; + + sub is_cool { + $_[0]->{name} eq 'cool'; + } + + sub delete { + undef %{$_[0]}; + bless $_[0], 'Brap'; + return 1; + } + + sub delete_with_self { + my $self = shift; + undef %$self; + bless $self, 'Brap'; + return 1; + } + + package Brap; + + 1; + + package main; + + my $obj; + $obj = bless {name => 'cool'}, 'Sklorsh'; + $obj->delete; + ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexistent namespace'); + + $obj = bless {name => 'cool'}, 'Sklorsh'; + $obj->delete_with_self; + ok (eval {if ($obj) {1}; 1}, $@); + + my $a = $b = {name => 'hot'}; + bless $b, 'Sklorsh'; + is(ref $a, 'Sklorsh'); + is(ref $b, 'Sklorsh'); + 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 (bug 41546) + 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'); + +} + +{ + # nomethod called for '!' after attempted fallback + my $nomethod_called = 0; + + package nomethod_not; + use overload nomethod => sub { $nomethod_called = 'yes'; }; + + package main; + my $o = bless [], 'nomethod_not'; + my $res = ! $o; + + is($nomethod_called, 'yes', "nomethod() is called for '!'"); + is($res, 'yes', "nomethod(..., '!') return value propagates"); +} + +{ + # 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