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