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