Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

276 lines (220 sloc) 6.609 kB
use Test;
# Tests for auto-increment and auto-decrement operators
# originally from Perl 5, by way of t/operators/auto.t
plan 79;
#L<S03/Autoincrement precedence>
my $base = 10000;
my $x = 10000;
is(0 + ++$x - 1, $base, '0 + ++$x - 1');
is(0 + $x-- - 1, $base, '0 + $x-- - 1');
is(1 * $x, $base, '1 * $x');
is(0 + $x-- - 0, $base, '0 + $x-- - 0');
is(1 + $x, $base, '1 + $x');
is(1 + $x++, $base, '1 + $x++');
is(0 + $x, $base, '0 + $x');
is(0 + --$x + 1, $base, '0 + --$x + 1');
is(0 + ++$x + 0, $base, '0 + ++$x + 0');
is($x, $base, '$x');
my @x;
@x[0] = 10000;
is(0 + ++@x[0] - 1, $base, '0 + ++@x[0] - 1');
is(0 + @x[0]-- - 1, $base, '0 + @x[0]-- - 1');
is(1 * @x[0], $base, '1 * @x[0]');
is(0 + @x[0]-- - 0, $base, '0 + @x[0]-- - 0');
is(1 + @x[0], $base, '1 + @x[0]');
is(1 + @x[0]++, $base, '1 + @x[0]++');
is(0 + @x[0], $base, '0 + @x[0]');
is(0 + ++@x[0] - 1, $base, '0 + ++@x[0] - 1');
is(0 + --@x[0] + 0, $base, '0 + --@x[0] + 0');
is(@x[0], $base, '@x[0]');
my %z;
%z{0} = 10000;
is(0 + ++%z{0} - 1, $base, '0 + ++%z{0} - 1');
is(0 + %z{0}-- - 1, $base, '0 + %z{0}-- - 1');
is(1 * %z{0}, $base, '1 * %z{0}');
is(0 + %z{0}-- - 0, $base, '0 + %z{0}-- - 0');
is(1 + %z{0}, $base, '1 + %z{0}');
is(1 + %z{0}++, $base, '1 + %z{0}++');
is(0 + %z{0}, $base, '0 + %z{0}');
is(0 + ++%z{0} - 1, $base, '0 + ++%z{0} - 1');
is(0 + --%z{0} + 0, $base, '0 + --%z{0} + 0');
is(%z{0}, $base, '%z{0}');
# Increment of a Str
#L<S03/Autoincrement precedence/Increment of a>
# XXX: these need to be re-examined and extended per changes to S03.
# Also, see the thread at
# http://www.nntp.perl.org/group/perl.perl6.compiler/2007/06/msg1598.html
# which prompted many of the changes to Str autoincrement/autodecrement.
{
# These are the ranges specified in S03.
# They might be handy for some DDT later.
my @rangechar = (
[ 'A', 'Z' ],
[ 'a', 'z' ],
[ "\x[391]", "\x[3a9]" ],
[ "\x[3b1]", "\x[3c9]" ],
[ "\x[5d0]", "\x[5ea]" ],
[ '0', '9' ],
[ "\x[660]", "\x[669]" ],
[ "\x[966]", "\x[96f]" ],
[ "\x[9e6]", "\x[9ef]" ],
[ "\x[a66]", "\x[a6f]" ],
[ "\x[ae6]", "\x[aef]" ],
[ "\x[b66]", "\x[b6f]" ],
);
}
{
my $x;
$x = "123.456";
is( ++$x, "124.456", "'123.456'++ is '124.456' (NOT 123.457)" );
$x = "124.456";
is( --$x, "123.456", "'124.456'-- is '123.456'" );
}
{
my $x;
$x = "/tmp/pix000.jpg";
is( ++$x, "/tmp/pix001.jpg", "'/tmp/pix000.jpg'++ is '/tmp/pix001.jpg'" );
$x = "/tmp/pix001.jpg";
is( --$x, "/tmp/pix000.jpg", "'/tmp/pix001.jpg'-- is '/tmp/pix000.jpg'" );
}
{
my $x;
# EBCDIC check (i and j not contiguous)
$x = "zi";
is( ++$x, "zj", "'zi'++ is 'zj'" );
$x = "zj";
is( --$x, "zi", "'zj'-- is 'zi'" );
$x = "zr";
# EBCDIC check (r and s not contiguous)
is( ++$x, "zs", "'zr'++ is 'zs'" );
$x = "zs";
is( --$x, "zr", "'zs'-- is 'zr'" );
}
#?niecza skip "Failure NYI"
{
my $foo;
$foo = 'A00';
ok(--$foo ~~ Failure, "Decrement of 'A00' should fail");
# TODO: Check that the Failure is "Decrement out of range" and not
# some other unrelated error (for the fail tests above).
}
{
my $foo;
$foo = "\x[3a1]";
is( ++$foo, "\x[3a3]", 'there is no \\x[3a2]' );
}
{
my $foo = "K\x[3c9]";
is( ++$foo, "L\x[3b1]", "increment 'K\x[3c9]'" );
}
{
my $x;
is ++$x, 1, 'Can autoincrement a Mu variable (prefix)';
my $y;
$y++;
is $y, 1, 'Can autoincrement a Mu variable (postfix)';
}
{
class Incrementor {
has $.value;
method succ() {
Incrementor.new( value => $.value + 42);
}
}
my $o = Incrementor.new( value => 0 );
$o++;
is $o.value, 42, 'Overriding succ catches postfix increment';
++$o;
is $o.value, 84, 'Overriding succ catches prefix increment';
}
{
class Decrementor {
has $.value;
method pred() {
Decrementor.new( value => $.value - 42);
}
}
my $o = Decrementor.new( value => 100 );
$o--;
is $o.value, 58, 'Overriding pred catches postfix decrement';
--$o;
is $o.value, 16, 'Overriding pred catches prefix decrement';
}
{
# L<S03/Autoincrement precedence/Increment of a>
my $x = "b";
is $x.succ, 'c', '.succ for Str';
is $x.pred, 'a', '.pred for Str';
my $y = 1;
is $y.succ, 2, '.succ for Int';
is $y.pred, 0, '.pred for Int';
my $z = Num.new();
is $z.succ, 1 , '.succ for Num';
is $z.pred, -1, '.pred for Num'
}
# RT #63644
eval-dies-ok 'my $a; $a++ ++;', 'parse error for "$a++ ++"';
# RT #99731
{
$_ = 4;
.++;
is $_, 5, 'increment of $_ via .++';
}
# RT #113816 - autoincrement of bools
{
my Bool $x;
my $y;
#postincrement tests
$x = Bool;
$y = $x++;
is $y, False, "Bool postincrement returns Bool";
is $x, True, "Bool postincrement sets True";
$x = False;
$y = $x++;
is $y, False, "False postincrement returns False";
is $x, True, "False postincrement sets True";
$x = True;
$y = $x++;
is $y, True, "True postincrement returns True";
is $x, True, "True postincrement sets True";
#postdecrement tests
$x = Bool;
$y = $x--;
is $y, False, "Bool postdecrement returns Bool";
is $x, False, "Bool postdecrement sets False";
$x = False;
$y = $x--;
is $y, False, "False postdecrement returns False";
is $x, False, "False postdecrement sets False";
$x = True;
$y = $x--;
is $y, True, "True postdecrement returns True";
is $x, False, "True postdecrement sets False";
#preincrement tests
$x = Bool;
$y = ++$x;
is $y, True, "Bool preincrement returns True";
is $x, True, "Bool postincrement sets True";
$x = False;
$y = ++$x;
is $y, True, "False preincrement returns True";
is $x, True, "False postincrement sets True";
$x = True;
$y = ++$x;
is $y, True, "True preincrement returns True";
is $x, True, "True postincrement sets True";
#predecrement tests
$x = Bool;
$y = --$x;
is $y, False, "Bool predecrement returns False";
is $x, False, "Bool postdecrement sets False";
$x = False;
$y = --$x;
is $y, False, "False predecrement returns False";
is $x, False, "False postdecrement sets False";
$x = True;
$y = --$x;
is $y, False, "True predecrement returns False";
is $x, False, "True postdecrement sets False";
};
# vim: ft=perl6
Jump to Line
Something went wrong with that request. Please try again.