1#!./perl 2 3# ** DO NOT ADD ANY MORE TESTS HERE ** 4# Instead, put the test in the appropriate test file and use the 5# fresh_perl_is()/fresh_perl_like() functions in t/test.pl. 6 7# This is for tests that will normally cause segfaults, and other nasty 8# errors that might kill the interpreter and for some reason you can't 9# use an eval(). 10# 11# New tests are added to the bottom. For example. 12# 13# ######## perlbug ID 20020831.001 14# ($a, b) = (1,2) 15# EXPECT 16# Can't modify constant item in list assignment - at line 1 17# 18# to test that the code "($a, b) = (1,2)" causes the appropriate syntax 19# error, rather than just segfaulting as reported in perlbug ID 20# 20020831.001 21 22BEGIN { 23 chdir 't' if -d 't'; 24 @INC = '../lib'; 25 require './test.pl'; # for which_perl() etc 26} 27 28use strict; 29 30my $Perl = which_perl(); 31 32$|=1; 33 34my @prgs = (); 35while(<DATA>) { 36 if(m/^#{8,}\s*(.*)/) { 37 push @prgs, ['', $1]; 38 } 39 else { 40 $prgs[-1][0] .= $_; 41 } 42} 43plan tests => scalar @prgs; 44 45foreach my $prog (@prgs) { 46 my($raw_prog, $name) = @$prog; 47 48 my $switch; 49 if ($raw_prog =~ s/^\s*(-\w.*)//){ 50 $switch = $1; 51 } 52 53 my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog); 54 55 if ($prog =~ /^\# SKIP: (.+)/m) { 56 if (eval $1) { 57 ok(1, "Skip: $1"); 58 next; 59 } 60 } 61 62 $expected =~ s/\n+$//; 63 64 fresh_perl_is($prog, $expected, { switches => [$switch] }, $name); 65} 66 67__END__ 68######## 69$a = ":="; split /($a)/o, "a:=b:=c"; print "@_" 70EXPECT 71a := b := c 72######## 73$cusp = ~0 ^ (~0 >> 1); 74use integer; 75$, = " "; 76print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; 77EXPECT 787 0 0 8 ! 79######## 80$foo=undef; $foo->go; 81EXPECT 82Can't call method "go" on an undefined value at - line 1. 83######## 84BEGIN 85 { 86 "foo"; 87 } 88######## 89$array[128]=1 90######## 91$x=0x0eabcd; print $x->ref; 92EXPECT 93Can't call method "ref" without a package or object reference at - line 1. 94######## 95chop ($str .= <DATA>); 96######## 97close ($banana); 98######## 99$x=2;$y=3;$x<$y ? $x : $y += 23;print $x; 100EXPECT 10125 102######## 103eval {sub bar {print "In bar";}} 104######## 105system './perl -ne "print if eof" /dev/null' unless $^O eq 'MacOS' 106######## 107chop($file = <DATA>); 108######## 109package N; 110sub new {my ($obj,$n)=@_; bless \$n} 111$aa=new N 1; 112$aa=12345; 113print $aa; 114EXPECT 11512345 116######## 117%@x=0; 118EXPECT 119Can't modify hash dereference in repeat (x) at - line 1, near "0;" 120Execution of - aborted due to compilation errors. 121######## 122$_="foo"; 123printf(STDOUT "%s\n", $_); 124EXPECT 125foo 126######## 127push(@a, 1, 2, 3,) 128######## 129quotemeta "" 130######## 131for ("ABCDE") { 132 ⊂ 133s/./&sub($&)/eg; 134print;} 135sub sub {local($_) = @_; 136$_ x 4;} 137EXPECT 138Modification of a read-only value attempted at - line 3. 139######## 140package FOO;sub new {bless {FOO => BAR}}; 141package main; 142use strict vars; 143my $self = new FOO; 144print $$self{FOO}; 145EXPECT 146BAR 147######## 148$_="foo"; 149s/.{1}//s; 150print; 151EXPECT 152oo 153######## 154print scalar ("foo","bar") 155EXPECT 156bar 157######## 158sub by_number { $a <=> $b; };# inline function for sort below 159$as_ary{0}="a0"; 160@ordered_array=sort by_number keys(%as_ary); 161######## 162sub NewShell 163{ 164 local($Host) = @_; 165 my($m2) = $#Shells++; 166 $Shells[$m2]{HOST} = $Host; 167 return $m2; 168} 169 170sub ShowShell 171{ 172 local($i) = @_; 173} 174 175&ShowShell(&NewShell(beach,Work,"+0+0")); 176&ShowShell(&NewShell(beach,Work,"+0+0")); 177&ShowShell(&NewShell(beach,Work,"+0+0")); 178######## 179 { 180 package FAKEARRAY; 181 182 sub TIEARRAY 183 { print "TIEARRAY @_\n"; 184 die "bomb out\n" unless $count ++ ; 185 bless ['foo'] 186 } 187 sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } 188 sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } 189 sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } 190 } 191 192eval 'tie @h, FAKEARRAY, fred' ; 193tie @h, FAKEARRAY, fred ; 194EXPECT 195TIEARRAY FAKEARRAY fred 196TIEARRAY FAKEARRAY fred 197DESTROY 198######## 199BEGIN { die "phooey\n" } 200EXPECT 201phooey 202BEGIN failed--compilation aborted at - line 1. 203######## 204BEGIN { 1/$zero } 205EXPECT 206Illegal division by zero at - line 1. 207BEGIN failed--compilation aborted at - line 1. 208######## 209BEGIN { undef = 0 } 210EXPECT 211Modification of a read-only value attempted at - line 1. 212BEGIN failed--compilation aborted at - line 1. 213######## 214{ 215 package foo; 216 sub PRINT { 217 shift; 218 print join(' ', reverse @_)."\n"; 219 } 220 sub PRINTF { 221 shift; 222 my $fmt = shift; 223 print sprintf($fmt, @_)."\n"; 224 } 225 sub TIEHANDLE { 226 bless {}, shift; 227 } 228 sub READLINE { 229 "Out of inspiration"; 230 } 231 sub DESTROY { 232 print "and destroyed as well\n"; 233 } 234 sub READ { 235 shift; 236 print STDOUT "foo->can(READ)(@_)\n"; 237 return 100; 238 } 239 sub GETC { 240 shift; 241 print STDOUT "Don't GETC, Get Perl\n"; 242 return "a"; 243 } 244} 245{ 246 local(*FOO); 247 tie(*FOO,'foo'); 248 print FOO "sentence.", "reversed", "a", "is", "This"; 249 print "-- ", <FOO>, " --\n"; 250 my($buf,$len,$offset); 251 $buf = "string"; 252 $len = 10; $offset = 1; 253 read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; 254 getc(FOO) eq "a" or die "foo->GETC failed"; 255 printf "%s is number %d\n", "Perl", 1; 256} 257EXPECT 258This is a reversed sentence. 259-- Out of inspiration -- 260foo->can(READ)(string 10 1) 261Don't GETC, Get Perl 262Perl is number 1 263and destroyed as well 264######## 265my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" 266EXPECT 2672 2 2 268######## 269# used to attach defelem magic to all immortal values, 270# which made restore of local $_ fail. 271foo(2>1); 272sub foo { bar() for @_; } 273sub bar { local $_; } 274print "ok\n"; 275EXPECT 276ok 277######## 278@a = ($a, $b, $c, $d) = (5, 6); 279print "ok\n" 280 if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); 281EXPECT 282ok 283######## 284print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); 285EXPECT 286ok 287######## 288print "ok\n" if ("\0" lt "\xFF"); 289EXPECT 290ok 291######## 292open(H,$^O eq 'MacOS' ? ':run:fresh_perl.t' : 'run/fresh_perl.t'); # must be in the 't' directory 293stat(H); 294print "ok\n" if (-e _ and -f _ and -r _); 295EXPECT 296ok 297######## 298sub thing { 0 || return qw(now is the time) } 299print thing(), "\n"; 300EXPECT 301nowisthetime 302######## 303$ren = 'joy'; 304$stimpy = 'happy'; 305{ local $main::{ren} = *stimpy; print $ren, ' ' } 306print $ren, "\n"; 307EXPECT 308happy joy 309######## 310$stimpy = 'happy'; 311{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' } 312print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; 313EXPECT 314happy joy 315######## 316package p; 317sub func { print 'really ' unless wantarray; 'p' } 318sub groovy { 'groovy' } 319package main; 320print p::func()->groovy(), "\n" 321EXPECT 322really groovy 323######## 324@list = ([ 'one', 1 ], [ 'two', 2 ]); 325sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } 326print scalar(map &func($_), 1 .. 3), " ", 327 scalar(map scalar &func($_), 1 .. 3), "\n"; 328EXPECT 3292 3 330######## 331($k, $s) = qw(x 0); 332@{$h{$k}} = qw(1 2 4); 333for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } 334print "bogus\n" unless $s == 7; 335######## 336my $a = 'outer'; 337eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; 338eval { my $x = 'peace'; eval q[ print "$x\n" ] } 339EXPECT 340inner peace 341######## 342-w 343$| = 1; 344sub foo { 345 print "In foo1\n"; 346 eval 'sub foo { print "In foo2\n" }'; 347 print "Exiting foo1\n"; 348} 349foo; 350foo; 351EXPECT 352In foo1 353Subroutine foo redefined at (eval 1) line 1. 354Exiting foo1 355In foo2 356######## 357$s = 0; 358map {#this newline here tickles the bug 359$s += $_} (1,2,4); 360print "eat flaming death\n" unless ($s == 7); 361######## 362sub foo { local $_ = shift; split; @_ } 363@x = foo(' x y z '); 364print "you die joe!\n" unless "@x" eq 'x y z'; 365######## 366/(?{"{"})/ # Check it outside of eval too 367EXPECT 368Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern 369Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. 370######## 371/(?{"{"}})/ # Check it outside of eval too 372EXPECT 373Unmatched right curly bracket at (re_eval 1) line 1, at end of line 374syntax error at (re_eval 1) line 1, near ""{"}" 375Compilation failed in regexp at - line 1. 376######## 377BEGIN { @ARGV = qw(a b c d e) } 378BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } 379END { print "end <",shift,">\nargv <@ARGV>\n" } 380INIT { print "init <",shift,">\n" } 381CHECK { print "check <",shift,">\n" } 382EXPECT 383argv <a b c d e> 384begin <a> 385check <b> 386init <c> 387end <d> 388argv <e> 389######## 390-l 391# fdopen from a system descriptor to a system descriptor used to close 392# the former. 393open STDERR, '>&=STDOUT' or die $!; 394select STDOUT; $| = 1; print fileno STDOUT or die $!; 395select STDERR; $| = 1; print fileno STDERR or die $!; 396EXPECT 3971 3982 399######## 400-w 401sub testme { my $a = "test"; { local $a = "new test"; print $a }} 402EXPECT 403Can't localize lexical variable $a at - line 2. 404######## 405package X; 406sub ascalar { my $r; bless \$r } 407sub DESTROY { print "destroyed\n" }; 408package main; 409*s = ascalar X; 410EXPECT 411destroyed 412######## 413package X; 414sub anarray { bless [] } 415sub DESTROY { print "destroyed\n" }; 416package main; 417*a = anarray X; 418EXPECT 419destroyed 420######## 421package X; 422sub ahash { bless {} } 423sub DESTROY { print "destroyed\n" }; 424package main; 425*h = ahash X; 426EXPECT 427destroyed 428######## 429package X; 430sub aclosure { my $x; bless sub { ++$x } } 431sub DESTROY { print "destroyed\n" }; 432package main; 433*c = aclosure X; 434EXPECT 435destroyed 436######## 437package X; 438sub any { bless {} } 439my $f = "FH000"; # just to thwart any future optimisations 440sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } 441sub DESTROY { print "destroyed\n" } 442package main; 443$x = any X; # to bump sv_objcount. IO objs aren't counted?? 444*f = afh X; 445EXPECT 446destroyed 447destroyed 448######## 449BEGIN { 450 $| = 1; 451 $SIG{__WARN__} = sub { 452 eval { print $_[0] }; 453 die "bar\n"; 454 }; 455 warn "foo\n"; 456} 457EXPECT 458foo 459bar 460BEGIN failed--compilation aborted at - line 8. 461######## 462package X; 463@ISA='Y'; 464sub new { 465 my $class = shift; 466 my $self = { }; 467 bless $self, $class; 468 my $init = shift; 469 $self->foo($init); 470 print "new", $init; 471 return $self; 472} 473sub DESTROY { 474 my $self = shift; 475 print "DESTROY", $self->foo; 476} 477package Y; 478sub attribute { 479 my $self = shift; 480 my $var = shift; 481 if (@_ == 0) { 482 return $self->{$var}; 483 } elsif (@_ == 1) { 484 $self->{$var} = shift; 485 } 486} 487sub AUTOLOAD { 488 $AUTOLOAD =~ /::([^:]+)$/; 489 my $method = $1; 490 splice @_, 1, 0, $method; 491 goto &attribute; 492} 493package main; 494my $x = X->new(1); 495for (2..3) { 496 my $y = X->new($_); 497 print $y->foo; 498} 499print $x->foo; 500EXPECT 501new1new22DESTROY2new33DESTROY31DESTROY1 502######## 503re(); 504sub re { 505 my $re = join '', eval 'qr/(??{ $obj->method })/'; 506 $re; 507} 508EXPECT 509######## 510use strict; 511my $foo = "ZZZ\n"; 512END { print $foo } 513EXPECT 514ZZZ 515######## 516eval ' 517use strict; 518my $foo = "ZZZ\n"; 519END { print $foo } 520'; 521EXPECT 522ZZZ 523######## 524-w 525if (@ARGV) { print "" } 526else { 527 if ($x == 0) { print "" } else { print $x } 528} 529EXPECT 530Use of uninitialized value in numeric eq (==) at - line 4. 531######## 532$x = sub {}; 533foo(); 534sub foo { eval { return }; } 535print "ok\n"; 536EXPECT 537ok 538######## 539# moved to op/lc.t 540EXPECT 541######## 542sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } 543my $x = "foo"; 544{ f } continue { print $x, "\n" } 545EXPECT 546foo 547######## 548sub C () { 1 } 549sub M { $_[0] = 2; } 550eval "C"; 551M(C); 552EXPECT 553Modification of a read-only value attempted at - line 2. 554######## 555print qw(ab a\b a\\b); 556EXPECT 557aba\ba\b 558######## 559# lexicals declared after the myeval() definition should not be visible 560# within it 561sub myeval { eval $_[0] } 562my $foo = "ok 2\n"; 563myeval('sub foo { local $foo = "ok 1\n"; print $foo; }'); 564die $@ if $@; 565foo(); 566print $foo; 567EXPECT 568ok 1 569ok 2 570######## 571# lexicals outside an eval"" should be visible inside subroutine definitions 572# within it 573eval <<'EOT'; die $@ if $@; 574{ 575 my $X = "ok\n"; 576 eval 'sub Y { print $X }'; die $@ if $@; 577 Y(); 578} 579EOT 580EXPECT 581ok 582######## 583# This test is here instead of lib/locale.t because 584# the bug depends on in the internal state of the locale 585# settings and pragma/locale messes up that state pretty badly. 586# We need a "fresh run". 587BEGIN { 588 eval { require POSIX }; 589 if ($@) { 590 exit(0); # running minitest? 591 } 592} 593use Config; 594my $have_setlocale = $Config{d_setlocale} eq 'define'; 595$have_setlocale = 0 if $@; 596# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" 597# and mingw32 uses said silly CRT 598$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); 599exit(0) unless $have_setlocale; 600my @locales; 601if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { 602 while(<LOCALES>) { 603 chomp; 604 push(@locales, $_); 605 } 606 close(LOCALES); 607} 608exit(0) unless @locales; 609for (@locales) { 610 use POSIX qw(locale_h); 611 use locale; 612 setlocale(LC_NUMERIC, $_) or next; 613 my $s = sprintf "%g %g", 3.1, 3.1; 614 next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; 615 print "$_ $s\n"; 616} 617EXPECT 618######## 619die qr(x) 620EXPECT 621(?-xism:x) at - line 1. 622######## 623# 20001210.003 mjd@plover.com 624format REMITOUT_TOP = 625FOO 626. 627 628format REMITOUT = 629BAR 630. 631 632# This loop causes a segv in 5.6.0 633for $lineno (1..61) { 634 write REMITOUT; 635} 636 637print "It's OK!"; 638EXPECT 639It's OK! 640######## 641# Inaba Hiroto 642reset; 643if (0) { 644 if ("" =~ //) { 645 } 646} 647######## 648# Nicholas Clark 649$ENV{TERM} = 0; 650reset; 651// if 0; 652######## 653# Vadim Konovalov 654use strict; 655sub new_pmop($) { 656 my $pm = shift; 657 return eval "sub {shift=~/$pm/}"; 658} 659new_pmop "abcdef"; reset; 660new_pmop "abcdef"; reset; 661new_pmop "abcdef"; reset; 662new_pmop "abcdef"; reset; 663######## 664# David Dyck 665# coredump in 5.7.1 666close STDERR; die; 667EXPECT 668######## 669-w 670"x" =~ /(\G?x)?/; # core dump in 20000716.007 671######## 672# Bug 20010515.004 673my @h = 1 .. 10; 674bad(@h); 675sub bad { 676 undef @h; 677 print "O"; 678 print for @_; 679 print "K"; 680} 681EXPECT 682OK 683######## 684# Bug 20010506.041 685"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n"; 686EXPECT 687ok 688######## 689# Bug 20010422.005 690{s//${}/; //} 691EXPECT 692syntax error at - line 2, near "${}" 693Execution of - aborted due to compilation errors. 694######## 695# Bug 20010528.007 696"\x{" 697EXPECT 698Missing right brace on \x{} at - line 2, within string 699Execution of - aborted due to compilation errors. 700######## 701my $foo = Bar->new(); 702my @dst; 703END { 704 ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/; 705 print $_, "\n"; 706} 707package Bar; 708sub new { 709 my Bar $self = bless [], Bar; 710 eval '$self'; 711 return $self; 712} 713sub DESTROY { 714 push @dst, "$_[0]"; 715} 716EXPECT 717Bar=ARRAY(0x...) 718######## 719######## found by Markov chain stress testing 720eval "a.b.c.d.e.f;sub" 721EXPECT 722 723######## perlbug ID 20010831.001 724($a, b) = (1, 2); 725EXPECT 726Can't modify constant item in list assignment at - line 1, near ");" 727Execution of - aborted due to compilation errors. 728######## tying a bareword causes a segfault in 5.6.1 729tie FOO, "Foo"; 730EXPECT 731Can't modify constant item in tie at - line 1, near ""Foo";" 732Execution of - aborted due to compilation errors. 733######## undefing constant causes a segfault in 5.6.1 [ID 20010906.019] 734undef foo; 735EXPECT 736Can't modify constant item in undef operator at - line 1, near "foo;" 737Execution of - aborted due to compilation errors. 738######## (?{...}) compilation bounces on PL_rs 739-0 740{ 741 /(?{ $x })/; 742 # { 743} 744BEGIN { print "ok\n" } 745EXPECT 746ok 747######## read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054] 748read($bla, FILE, 1); 749EXPECT 750Can't modify constant item in read at - line 1, near "1)" 751Execution of - aborted due to compilation errors. 752######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155] 753# This only happens if the filename is 11 characters or less. 754$foo = \-f "blah"; 755print "ok" if ref $foo && !$$foo; 756EXPECT 757ok 758######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1 759print "ok" if 'X' =~ /\X/; 760EXPECT 761ok 762######## segfault in 5.6.1 within peep() 763@a = (1..9); 764@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a; 765print join '', @a, "\n"; 766EXPECT 767123456789 768######## [ID 20020104.007] "coredump on dbmclose" 769package Foo; 770eval { require AnyDBM_File }; # not all places have dbm* functions 771if ($@) { 772 print "ok\n"; 773 exit 0; 774} 775package Foo; 776sub new { 777 my $proto = shift; 778 my $class = ref($proto) || $proto; 779 my $self = {}; 780 bless($self,$class); 781 my %LT; 782 dbmopen(%LT, "dbmtest", 0666) || 783 die "Can't open dbmtest because of $!\n"; 784 $self->{'LT'} = \%LT; 785 return $self; 786} 787sub DESTROY { 788 my $self = shift; 789 dbmclose(%{$self->{'LT'}}); 790 1 while unlink 'dbmtest'; 791 1 while unlink <dbmtest.*>; 792 print "ok\n"; 793} 794package main; 795$test = Foo->new(); # must be package var 796EXPECT 797ok 798######## example from Camel 5, ch. 15, pp.406 (with my) 799# SKIP: ord "A" == 193 # EBCDIC 800use strict; 801use utf8; 802my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph 803$人++; # a child is born 804print $人, "\n"; 805EXPECT 8063 807######## example from Camel 5, ch. 15, pp.406 (with our) 808# SKIP: ord "A" == 193 # EBCDIC 809use strict; 810use utf8; 811our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph 812$人++; # a child is born 813print $人, "\n"; 814EXPECT 8153 816######## example from Camel 5, ch. 15, pp.406 (with package vars) 817# SKIP: ord "A" == 193 # EBCDIC 818use utf8; 819$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph 820$人++; # a child is born 821print $人, "\n"; 822EXPECT 8233 824######## example from Camel 5, ch. 15, pp.406 (with use vars) 825# SKIP: ord "A" == 193 # EBCDIC 826use strict; 827use utf8; 828use vars qw($人); 829$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph 830$人++; # a child is born 831print $人, "\n"; 832EXPECT 8333 834######## 835# test that closures generated by eval"" hold on to the CV of the eval"" 836# for their entire lifetime 837$code = eval q[ 838 sub { eval '$x = "ok 1\n"'; } 839]; 840&{$code}(); 841print $x; 842EXPECT 843ok 1 844######## [ID 20020623.009] nested eval/sub segfaults 845$eval = eval 'sub { eval "sub { %S }" }'; 846$eval->({}); 847