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