#!./perl
# Add new tests to the end with format:
-# "########\n# test description\nTest code\nEXPECT\nWarn or die msgs (if any)\n"
+# ########
+#
+# # test description
+# Test code
+# EXPECT
+# Warn or die msgs (if any) at - line 1234
#
-# This test script does NOT test the output of the test code. It ONLY
-# checks warnings or croaks. Todo tests should have TODO as the start
-# of the description. Note also that warnings are not enabled: if you
-# need to test a perl warning, enable its class in your test.
chdir 't' if -d 't';
@INC = '../lib';
$|=1;
-# catch warnings into fatal errors
-$SIG{__WARN__} = sub { die "WARNING: @_" } ;
-$SIG{__DIE__} = sub { die @_ };
-
undef $/;
@prgs = split /^########\n/m, <DATA>;
-print "1..", scalar @prgs, "\n";
+require './test.pl';
+plan(tests => scalar @prgs);
for (@prgs){
++$i;
my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
print("not ok $i # bad test format\n"), next
unless defined $expected;
- my ($testname) = $prog =~ /^\n?(# .*)\n/;
+ my ($testname) = $prog =~ /^# (.*)\n/m;
$testname ||= '';
- eval "$prog" ;
- $status = $?;
- $results = $@ ;
+ $TODO = $testname =~ s/^TODO //;
$results =~ s/\n+$//;
$expected =~ s/\n+$//;
- if ( $status || ($expected eq '') != ($results eq '') ||
- $results !~ /^(WARNING: )?$expected/){
- print STDERR "STATUS: $status\n";
- print STDERR "PROG: $prog\n";
- print STDERR "EXPECTED:\n$expected\n";
- print STDERR "GOT:\n$results\n";
- print "not ok $i $testname\n";
- }
- else {
- print "ok $i $testname\n";
- }
+
+ fresh_perl_is($prog, $expected, {}, $testname);
}
__END__
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
-untie attempted while 1 inner references still exist
+untie attempted while 1 inner references still exist at - line 6.
########
# strict behaviour, with 1 extra references via tied generating an error
$a = tied %h;
untie %h;
EXPECT
-untie attempted while 1 inner references still exist
+untie attempted while 1 inner references still exist at - line 7.
########
# strict behaviour, with 1 extra references which are destroyed
EXPECT
########
-# strict error behaviour, with 2 extra references
+# strict error behaviour, with 2 extra references
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
untie %h;
EXPECT
-untie attempted while 2 inner references still exist
+untie attempted while 2 inner references still exist at - line 7.
########
# strict behaviour, check scope of strictness.
untie %H;
EXPECT
########
+
# Forbidden aggregate self-ties
sub Self::TIEHASH { bless $_[1], $_[0] }
{
tie %c, 'Self', \%c;
}
EXPECT
-Self-ties of arrays and hashes are not supported
+Self-ties of arrays and hashes are not supported at - line 6.
########
+
# Allowed scalar self-ties
my $destroyed = 0;
sub Self::TIESCALAR { bless $_[1], $_[0] }
my $c = 42;
tie $c, 'Self', \$c;
}
-die "self-tied scalar not DESTROYd" unless $destroyed == 1;
+die "self-tied scalar not DESTROYed" unless $destroyed == 1;
EXPECT
########
-# Allowed glob self-ties
+
+# TODO Allowed glob self-ties
my $destroyed = 0;
+my $printed = 0;
sub Self2::TIEHANDLE { bless $_[1], $_[0] }
sub Self2::DESTROY { $destroyed = 1; }
+sub Self2::PRINT { $printed = 1; }
{
use Symbol;
my $c = gensym;
tie *$c, 'Self2', $c;
+ print $c 'Hello';
}
-die "self-tied glob not DESTROYd" unless $destroyed == 1;
+die "self-tied glob not PRINTed" unless $printed == 1;
+die "self-tied glob not DESTROYed" unless $destroyed == 1;
EXPECT
########
+
# Allowed IO self-ties
my $destroyed = 0;
sub Self3::TIEHANDLE { bless $_[1], $_[0] }
my $c = geniosym;
tie *$c, 'Self3', $c;
}
-die "self-tied IO not DESTROYd" unless $destroyed == 1;
+die "self-tied IO not DESTROYed" unless $destroyed == 1;
EXPECT
########
+
# Interaction of tie and vec
my ($a, $b);
die unless $a eq $b;
EXPECT
########
+
# correct unlocalisation of tied hashes (patch #16431)
use Tie::Hash ;
tie %tied, Tie::StdHash;
{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
EXPECT
+########
+
+# An attempt at lvalueable barewords broke this
+tie FH, 'main';
+EXPECT
+Can't modify constant item in tie at - line 3, near "'main';"
+Execution of - aborted due to compilation errors.
+########
+# localizing tied hash slices
+$ENV{FooA} = 1;
+$ENV{FooB} = 2;
+print exists $ENV{FooA} ? 1 : 0, "\n";
+print exists $ENV{FooB} ? 2 : 0, "\n";
+print exists $ENV{FooC} ? 3 : 0, "\n";
+{
+ local @ENV{qw(FooA FooC)};
+ print exists $ENV{FooA} ? 4 : 0, "\n";
+ print exists $ENV{FooB} ? 5 : 0, "\n";
+ print exists $ENV{FooC} ? 6 : 0, "\n";
+}
+print exists $ENV{FooA} ? 7 : 0, "\n";
+print exists $ENV{FooB} ? 8 : 0, "\n";
+print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
+EXPECT
+1
+2
+0
+4
+5
+6
+7
+8
+0