#!./perl
# ** DO NOT ADD ANY MORE TESTS HERE **
# Instead, put the test in the appropriate test file and use the
# This is for tests that used to abnormally cause segfaults, and other nasty
# errors that might kill the interpreter and for some reason you can't
# use an eval().
BEGIN {
chdir 't' if -d 't';
}
use strict;
$|=1;
my @prgs = ();
while(<DATA>) {
if(m/^#{8,}\s*(.*)/) {
}
else {
$prgs[-1][0] .= $_;
}
}
my $switch;
$switch = $1;
}
if (eval $1) {
next;
}
}
$expected =~ s/\n+$//;
}
########
a := b := c
########
use integer;
$, = " ";
7 0 0 8 !
########
Can't call method "go" on an undefined value at - line 1.
########
BEGIN
{
"foo";
}
########
$array[128]=1
########
$x=0x0eabcd; print $x->ref;
EXPECT
########
########
########
$x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
25
########
eval 'sub bar {print "In bar"}';
########
########
########
package N;
$aa=12345;
print $aa;
12345
########
$_="foo";
########
push(@a, 1, 2, 3,)
########
quotemeta ""
########
for ("ABCDE") {
⊂
print;}
sub sub {local($_) = @_;
$_ x 4;}
########
########
$_="foo";
s/.{1}//s;
print;
########
########
########
sub NewShell
{
return $m2;
}
sub ShowShell
{
local($i) = @_;
}
########
{
sub TIEARRAY
{ print "TIEARRAY @_\n";
}
}
eval 'tie @h, FAKEARRAY, fred' ;
########
########
########
########
{
sub PRINT {
shift;
}
sub PRINTF {
shift;
my $fmt = shift;
}
sub TIEHANDLE {
bless {}, shift;
}
sub READLINE {
"Out of inspiration";
}
sub DESTROY {
print "and destroyed as well\n";
}
sub READ {
shift;
return 100;
}
sub GETC {
shift;
return "a";
}
}
{
}
-- Out of inspiration --
Don't GETC, Get Perl
Perl is number 1
and destroyed as well
########
my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
EXPECT
2 2 2
########
# used to attach defelem magic to all immortal values,
# which made restore of local $_ fail.
foo(2>1);
sub foo { bar() for @_; }
sub bar { local $_; }
print "ok\n";
EXPECT
ok
########
@a = ($a, $b, $c, $d) = (5, 6);
print "ok\n"
if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
EXPECT
ok
########
print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
EXPECT
ok
########
print "ok\n" if ("\0" lt "\xFF");
EXPECT
ok
########
stat(H);
print "ok\n" if (-e _ and -f _ and -r _);
EXPECT
ok
########
sub thing { 0 || return qw(now is the time) }
print thing(), "\n";
EXPECT
nowisthetime
########
{ local $main::{ren} = *stimpy; print $ren, ' ' }
print $ren, "\n";
EXPECT
happy joy
########
EXPECT
happy joy
########
package p;
package main;
print p::func()->groovy(), "\n"
EXPECT
really groovy
########
sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
print scalar(map &func($_), 1 .. 3), " ",
scalar(map scalar &func($_), 1 .. 3), "\n";
EXPECT
2 3
########
($k, $s) = qw(x 0);
@{$h{$k}} = qw(1 2 4);
for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
print "bogus\n" unless $s == 7;
########
EXPECT
inner peace
########
-w
$| = 1;
sub foo {
print "In foo1\n";
print "Exiting foo1\n";
}
foo;
foo;
EXPECT
In foo1
Subroutine foo redefined at (eval 1) line 1.
Exiting foo1
In foo2
########
$s = 0;
map {#this newline here tickles the bug
$s += $_} (1,2,4);
print "eat flaming death\n" unless ($s == 7);
########
sub foo { local $_ = shift; split; @_ }
@x = foo(' x y z ');
print "you die joe!\n" unless "@x" eq 'x y z';
########
/(?{"{"})/ # Check it outside of eval too
EXPECT
Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
########
/(?{"{"}})/ # Check it outside of eval too
EXPECT
Unmatched right curly bracket at (re_eval 1) line 1, at end of line
syntax error at (re_eval 1) line 1, near ""{"}"
Compilation failed in regexp at - line 1.
########
BEGIN { @ARGV = qw(a b c d e) }
BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
END { print "end <",shift,">\nargv <@ARGV>\n" }
INIT { print "init <",shift,">\n" }
CHECK { print "check <",shift,">\n" }
EXPECT
argv <a b c d e>
begin <a>
check <b>
init <c>
end <d>
argv <e>
########
-l
# fdopen from a system descriptor to a system descriptor used to close
# the former.
select STDOUT; $| = 1; print fileno STDOUT or die $!;
select STDERR; $| = 1; print fileno STDERR or die $!;
EXPECT
1
2
########
-w
sub testme { my $a = "test"; { local $a = "new test"; print $a }}
EXPECT
########
package X;
*s = ascalar X;
########
package X;
*a = anarray X;
########
package X;
*h = ahash X;
########
package X;
*c = aclosure X;
########
package X;
my $f = "FH000"; # just to thwart any future optimisations
$x = any X; # to bump sv_objcount. IO objs aren't counted??
*f = afh X;
########
BEGIN {
$| = 1;
eval { print $_[0] };
};
}
########
package X;
sub new {
my $class = shift;
my $self = { };
my $init = shift;
return $self;
}
sub DESTROY {
my $self = shift;
}
package Y;
sub attribute {
my $self = shift;
my $var = shift;
if (@_ == 0) {
} elsif (@_ == 1) {
}
}
sub AUTOLOAD {
my $method = $1;
goto &attribute;
}
for (2..3) {
print $y->foo;
}
print $x->foo;
########
sub re {
$re;
}
########
use strict;
########
eval '
use strict;
my $foo = "ZZZ\n";
END { print $foo }
';
########
-w
else {
if ($x == 0) { print "" } else { print $x }
}
########
$x = sub {};
print "ok\n";
########
########
sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
my $x = "foo";
{ f } continue { print $x, "\n" }
########
sub C () { 1 }
sub M { $_[0] = 2; }
eval "C";
M(C);
########
########
# lexicals declared after the myeval() definition should not be visible
# within it
sub myeval { eval $_[0] }
die $@ if $@;
print $foo;
ok 1
ok 2
########
# lexicals outside an eval"" should be visible inside subroutine definitions
# within it
{
my $X = "ok\n";
Y();
}
########
# the bug depends on in the internal state of the locale
# We need a "fresh run".
BEGIN {
eval { require POSIX };
if ($@) {
exit(0); # running minitest?
}
}
use Config;
$have_setlocale = 0 if $@;
# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
# and mingw32 uses said silly CRT
my @locales;
}
}
use locale;
print "$_ $s\n";
}
########
# [ID 20001202.002] and change #8066 added 'at -e line 1';
# reversed again as a result of [perl #17763]
(?-xism:x)
########
# 20001210.003 mjd@plover.com
.
.
# This loop causes a segv in 5.6.0
}
print "It's OK!";
It's OK!
########
# Inaba Hiroto
reset;
if (0) {
if ("" =~ //) {
}
}
########
# Nicholas Clark
$ENV{TERM} = 0;
reset;
// if 0;
########
# Vadim Konovalov
use strict;
sub new_pmop($) {
my $pm = shift;
return eval "sub {shift=~/$pm/}";
}
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
########
# David Dyck
# coredump in 5.7.1
close STDERR; die;
EXPECT
########
-w
"x" =~ /(\G?x)?/; # core dump in 20000716.007
########
# Bug 20010515.004
my @h = 1 .. 10;
bad(@h);
sub bad {
undef @h;
print "O";
print for @_;
print "K";
}
EXPECT
OK
########
# Bug 20010506.041
"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
EXPECT
ok
########
my $foo = Bar->new();
my @dst;
END {
($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
print $_, "\n";
}
package Bar;
sub new {
my Bar $self = bless [], Bar;
return $self;
}
sub DESTROY {
push @dst, "$_[0]";
}
EXPECT
Bar=ARRAY(0x...)
######## (?{...}) compilation bounces on PL_rs
-0
{
/(?{ $x })/;
# {
}
BEGIN { print "ok\n" }
EXPECT
ok
######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
# This only happens if the filename is 11 characters or less.
$foo = \-f "blah";
print "ok" if ref $foo && !$$foo;
EXPECT
ok
######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
print "ok" if 'X' =~ /\X/;
EXPECT
ok
######## segfault in 5.6.1 within peep()
@a = (1..9);
@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
print join '', @a, "\n";
EXPECT
123456789
######## [ID 20020104.007] "coredump on dbmclose"
package Foo;
eval { require AnyDBM_File }; # not all places have dbm* functions
if ($@) {
print "ok\n";
exit 0;
}
package Foo;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless($self,$class);
my %LT;
dbmopen(%LT, "dbmtest", 0666) ||
$self->{'LT'} = \%LT;
return $self;
}
sub DESTROY {
my $self = shift;
dbmclose(%{$self->{'LT'}});
1 while unlink 'dbmtest';
1 while unlink <dbmtest.*>;
}
package main;
$test = Foo->new(); # must be package var
EXPECT
ok
######## example from Camel 5, ch. 15, pp.406 (with my)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with our)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with package vars)
# SKIP: ord "A" == 193 # EBCDIC
use utf8;
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with use vars)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
use vars qw($人);
$人++; # a child is born
print $人, "\n";
EXPECT
3
########
# test that closures generated by eval"" hold on to the CV of the eval""
# for their entire lifetime
$code = eval q[
];
&{$code}();
print $x;
EXPECT
ok 1
$eval->({});
######## [perl #17951] Strange UTF error
-W
# Newsgroups: comp.lang.perl.moderated
# Subject: Strange UTF error
# Date: Fri, 11 Oct 2002 16:19:58 -0400
# Message-ID: <pan.2002.10.11.20.19.48.407190@mail630.gsfc.nasa.gov>
utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN)
# matching is actually irrelevant: avoiding several dozen of these
# Illegal hexadecimal digit ' ' ignored at /usr/lib/perl5/5.8.0/utf8_heavy.pl line 152
# is what matters.
/^([[:digit:]]+)/;
EXPECT
######## [perl #20667] unicode regex vs non-unicode regex
$toto = 'Hello';
$toto =~ /\w/; # this line provokes the problem!
$name = 'A B';
# utf8::upgrade($name) if @ARGV;
if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
} else {
}
EXPECT
It's good! >A< >B<
######## [perl #8760] strangness with utf8 and warn
EXPECT
foo at - line 1.
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
-lw
BEGIN {
eval 'require Fcntl';
}
if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
} else {
use File::Glob;
}
EXPECT
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
-lw
BEGIN {
eval 'require Fcntl';
}
if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
} else {
use File::Glob;
use File::Glob;
}
EXPECT
######## "Segfault using HTML::Entities", Richard Jolly <richardjolly@mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6@mac.com> in perl-unicode@perl.org
-lw
BEGIN {
eval 'require Encode';
if ($@) { exit 0 } # running minitest?
}
# Test case cut down by jhi
$SIG{__WARN__} = sub { $@ = shift };
use Encode;
Encode::_utf8_on($t);
$t =~ s/([^a])//ge;
$@ =~ s/ at .*/ at/;
print $@
EXPECT
Malformed UTF-8 character (unexpected end of string) at