regcomp.c: generate folded for EXACTF and EXACTFU

[perl5.git] / t / comp / fold.t

#!./perl -w

# Uncomment this for testing, but don't leave it in for "production", as
# we've not yet verified that use works.
# use strict;

print "1..19\n";
my $test = 0;

# Historically constant folding was performed by evaluating the ops, and if
# they threw an exception compilation failed. This was seen as buggy, because
# even illegal constants in unreachable code would cause failure. So now
# illegal expressions are reported at runtime, if the expression is reached,
# making constant folding consistent with many other languages, and purely an
# optimisation rather than a behaviour change.


sub failed {
    my ($got, $expected, $name) = @_;

    print "not ok $test - $name\n";
    my @caller = caller(1);
    print "# Failed test at $caller[1] line $caller[2]\n";
    if (defined $got) {
	print "# Got '$got'\n";
    } else {
	print "# Got undef\n";
    }
    print "# Expected $expected\n";
    return;
}

sub like {
    my ($got, $pattern, $name) = @_;
    $test = $test + 1;
    if (defined $got && $got =~ $pattern) {
	print "ok $test - $name\n";
	# Principle of least surprise - maintain the expected interface, even
	# though we aren't using it here (yet).
	return 1;
    }
    failed($got, $pattern, $name);
}

sub is {
    my ($got, $expect, $name) = @_;
    $test = $test + 1;
    if (defined $got && $got eq $expect) {
	print "ok $test - $name\n";
	return 1;
    }
    failed($got, "'$expect'", $name);
}

sub ok {
    my ($got, $name) = @_;
    $test = $test + 1;
    if ($got) {
	print "ok $test - $name\n";
	return 1;
    }
    failed($got, "a true value", $name);
}

my $a;
$a = eval '$b = 0/0 if 0; 3';
is ($a, 3, 'constants in conditionals don\'t affect constant folding');
is ($@, '', 'no error');

my $b = 0;
$a = eval 'if ($b) {return sqrt -3} 3';
is ($a, 3, 'variables in conditionals don\'t affect constant folding');
is ($@, '', 'no error');

$a = eval q{
	$b = eval q{if ($b) {return log 0} 4};
 	is ($b, 4, 'inner eval folds constant');
	is ($@, '', 'no error');
	5;
};
is ($a, 5, 'outer eval folds constant');
is ($@, '', 'no error');

# warn and die hooks should be disabled during constant folding

{
    my $c = 0;
    local $SIG{__WARN__} = sub { $c++   };
    local $SIG{__DIE__}  = sub { $c+= 2 };
    eval q{
	is($c, 0, "premature warn/die: $c");
	my $x = "a"+5;
	is($c, 1, "missing warn hook");
	is($x, 5, "a+5");
	$c = 0;
	$x = 1/0;
    };
    like ($@, qr/division/, "eval caught division");
    is($c, 2, "missing die hook");
}

# [perl #20444] Constant folding should not change the meaning of match
# operators.
{
 local *_;
 $_="foo"; my $jing = 1;
 ok scalar $jing =~ (1 ? /foo/ : /bar/),
   'lone m// is not bound via =~ after ? : folding';
 ok scalar $jing =~ (0 || /foo/),
   'lone m// is not bound via =~ after || folding';
 ok scalar $jing =~ (1 ? s/foo/foo/ : /bar/),
   'lone s/// is not bound via =~ after ? : folding';
 ok scalar $jing =~ (0 || s/foo/foo/),
   'lone s/// is not bound via =~ after || folding';
 $jing = 3;
 ok scalar $jing =~ (1 ? y/fo// : /bar/),
   'lone y/// is not bound via =~ after ? : folding';
 ok scalar $jing =~ (0 || y/fo//),
   'lone y/// is not bound via =~ after || folding';
}