From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

#!/usr/bin/perl
use strict;
my $defer = String::Defer->new(\my $targ);
my @defer = ($defer);
sub overload_ok {
my ($what, $want) = @_;
my $got = eval $what;
unless (ok defined $got, "$what succeeds") {
diag "\$\@: $@";
return;
}
is $got, $want, "$what is correct";
is_plain $got, "$what is not an object";
}
sub overload_nok {
my ($what, $want) = @_;
my $got = eval $what;
my $err = $@;
ok !defined $got, "$what fails"
or diag "GOT: $got";
like $err, $want, "$what gives correct error"
or diag "\$\@: $err";
}
$targ = 3;
overload_ok @$_ for (
['$defer + 4', 7 ],
['$defer - 5', -2 ],
['$defer * 3', 9 ],
['$defer / 2', 1.5 ],
['$defer % 2', 1 ],
['$defer ** 3', 27 ],
['$defer << 2', 12 ],
['$defer >> 1', 1 ],
['$defer x 3', 333 ], # XXX this should defer
# . is tested in defer.t
['$defer < 2', "" ],
['$defer <= 3', 1 ],
['$defer > 2', 1 ],
['$defer >= 4', "" ],
['$defer == 3', 1 ],
['$defer != 3', "" ],
['$defer <=> 4', -1 ],
['$defer lt 29', "" ],
['$defer le 3', 1 ],
['$defer gt 20', 1 ],
['$defer ge 4', "" ],
['$defer eq "x"', "" ],
['$defer ne "x"', 1 ],
['$defer cmp 29', 1 ],
['$defer & 1', "3" & 1 ], # bitwise ops use string form
['$defer | 1', "3" | 1 ],
['$defer ^ 1', "3" ^ 1 ],
['-$defer', -3 ],
['!$defer', "" ],
['~$defer', ~"3" ],
['atan2 $defer, 4', atan2(3,4) ],
['atan2 4, $defer', atan2(4,3) ],
['cos $defer', cos(3) ],
['sin $defer', sin(3) ],
['exp $defer', exp(3) ],
['log $defer', log(3) ],
['sqrt $defer', sqrt(3) ],
);
$targ = -2.6;
overload_ok @$_ for (
['abs $defer', 2.6 ],
['int $defer', -2 ],
);
# "" is tested in defer.t
# this is a test for 0+
$targ = 3;
overload_ok '"x" x $defer', "xxx";
$targ = 1;
overload_ok '$defer ? "ok" : "nok"', "ok";
$targ = 0;
overload_ok '$defer ? "ok" : "nok"', "nok";
$targ = "X*";
overload_ok '"XXX" =~ $defer', 1;
overload_ok '"AXXX" =~ /A$defer/', 1;
overload_ok '"xxx" =~ /$defer/i', 1;
$targ = "Build.PL";
overload_ok '-f $defer', 1;
$targ = "*uild.PL";
overload_ok '<$defer[0]>', "Build.PL";
$targ = "DATA";
overload_nok @$_ for (
['<$defer>', qr/Not a GLOB reference/ ],
['$$defer', qr/Not a SCALAR reference/ ],
( $] >= 5.010 ? (
['%$defer', qr/Not a HASH reference/ ],
) : (
['%$defer', qr/Can't coerce array into hash/ ],
) ),
['$defer->()', qr/Not a CODE reference/ ],
['*$defer', qr/Not a GLOB reference/ ],
);
SKIP: {
$] < 5.010 and skip "No smartmatch before 5.10", 1;
$] == 5.010 and skip "Smartmatch broken in 5.10.0", 1;
$targ = "XXX";
overload_ok '$defer ~~ "XXX"', 1;
}
our $VALTODO;
sub mutate_ok {
my ($what, $want) = @_;
my $val = $defer;
my $got = eval $what;
unless (ok defined $got, "$what succeeds") {
diag "\$\@: $@";
return;
}
TODO: {
local $TODO = $VALTODO;
is $val, $want, "$what is correct";
}
is_plain $val, "$what gives plain value";
is_defer $defer, "$what leaves object alone";
$got;
}
$targ = 4;
mutate_ok @$_ for (
['$val += 3', 7 ],
['$val -= 3', 1 ],
['$val *= 3', 12 ],
['$val /= 2', 2 ],
['$val %= 2', 0 ],
['$val **= 3', 64 ],
['$val <<= 3', 32 ],
['$val >>= 2', 1 ],
['$val x= 3', 444 ], # XXX this should defer
# .= is tested in defer.t
['$val &= 3', "4" & 3 ],
['$val |= 3', "4" | 3 ],
['$val ^= 3', "4" | 3 ],
);
{
local $VALTODO = "++ and -- act on refaddr??";
for (
['++$val', 5 ],
['--$val', 3 ],
) {
my ($what, $want) = @$_;
my $got = mutate_ok $what, $want
or next;
TODO: {
local $TODO = $VALTODO;
is $got, $want, "$what returns new value";
}
is_plain $got, "$what returns a plain value";
}
for (
['$val++', 5 ],
['$val--', 3 ],
) {
my ($what, $want) = @$_;
my $got = mutate_ok $what, $want
or next;
is $got, 4, "$what returns original value";
is_defer $got, "$what returns an object";
}
}
done_testing;
__DATA__
Data line 1