Commit | Line | Data |
a0d0e21e |
1 | #!./perl |
2 | |
c9beb3f5 |
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. |
fb73857a |
21 | |
c9beb3f5 |
22 | BEGIN { |
23 | chdir 't' if -d 't'; |
24 | @INC = '../lib'; |
b5fe401b |
25 | require './test.pl'; |
c9beb3f5 |
26 | } |
27 | |
28 | use strict; |
a0d0e21e |
29 | |
b5fe401b |
30 | my $Perl = which_perl; |
31 | |
a0d0e21e |
32 | $|=1; |
33 | |
c9beb3f5 |
34 | my @prgs = (); |
35 | while(<DATA>) { |
36 | if(m/^#{8,}\s*(.*)/) { |
37 | push @prgs, ['', $1]; |
38 | } |
39 | else { |
40 | $prgs[-1][0] .= $_; |
41 | } |
42 | } |
a0d0e21e |
43 | print "1..", scalar @prgs, "\n"; |
44 | |
c9beb3f5 |
45 | my $tmpfile = "misctmp000"; |
a0d0e21e |
46 | 1 while -f ++$tmpfile; |
ed6b3797 |
47 | END { while($tmpfile && unlink $tmpfile){} } |
a0d0e21e |
48 | |
c9beb3f5 |
49 | my $test = 1; |
50 | foreach my $prog (@prgs) { |
51 | my($raw_prog, $name) = @$prog; |
68dc0745 |
52 | |
a0d0e21e |
53 | my $switch; |
c9beb3f5 |
54 | if ($raw_prog =~ s/^\s*(-\w.*)//){ |
fb73857a |
55 | $switch = $1; |
a0d0e21e |
56 | } |
c9beb3f5 |
57 | |
58 | my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog); |
59 | |
648cac19 |
60 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
c9beb3f5 |
61 | |
62 | # VMS adjustments |
63 | if( $^O eq 'VMS' ) { |
64 | $prog =~ s#/dev/null#NL:#; |
65 | |
66 | # VMS file locking |
67 | $prog =~ s{if \(-e _ and -f _ and -r _\)} |
68 | {if (-e _ and -f _)} |
69 | } |
ed6b3797 |
70 | |
648cac19 |
71 | print TEST $prog, "\n"; |
72 | close TEST or die "Cannot close $tmpfile: $!"; |
73 | |
c9beb3f5 |
74 | my $results; |
ad20d923 |
75 | if ($^O eq 'MacOS') { |
b5fe401b |
76 | $results = `$Perl -I::lib -MMac::err=unix $switch $tmpfile`; |
be708cc0 |
77 | } |
68dc0745 |
78 | else { |
b5fe401b |
79 | $results = `$Perl "-I../lib" $switch $tmpfile 2>&1`; |
68dc0745 |
80 | } |
c9beb3f5 |
81 | my $status = $?; |
82 | |
83 | # Clean up the results into something a bit more predictable. |
a0d0e21e |
84 | $results =~ s/\n+$//; |
648cac19 |
85 | $results =~ s/at\s+misctmp\d+\s+line/at - line/g; |
86 | $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; |
c9beb3f5 |
87 | |
88 | # bison says 'parse error' instead of 'syntax error', |
89 | # various yaccs may or may not capitalize 'syntax'. |
2a8ee232 |
90 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
c9beb3f5 |
91 | |
765ebaf2 |
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 | } |
c9beb3f5 |
99 | |
a0d0e21e |
100 | $expected =~ s/\n+$//; |
c9beb3f5 |
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"; |
a0d0e21e |
107 | } |
c9beb3f5 |
108 | printf "%sok %d%s\n", ($ok ? '' : "not "), $test, |
109 | length $name ? " - $name" : $name; |
110 | $test++; |
a0d0e21e |
111 | } |
112 | |
113 | __END__ |
2ace3117 |
114 | ######## |
44a8e56a |
115 | $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" |
116 | EXPECT |
117 | a := b := c |
118 | ######## |
36477c24 |
119 | $cusp = ~0 ^ (~0 >> 1); |
85e0ebd8 |
120 | use integer; |
36477c24 |
121 | $, = " "; |
85e0ebd8 |
122 | print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; |
36477c24 |
123 | EXPECT |
85e0ebd8 |
124 | 7 0 0 8 ! |
36477c24 |
125 | ######## |
a0d0e21e |
126 | $foo=undef; $foo->go; |
127 | EXPECT |
72b5445b |
128 | Can't call method "go" on an undefined value at - line 1. |
a0d0e21e |
129 | ######## |
130 | BEGIN |
131 | { |
132 | "foo"; |
133 | } |
134 | ######## |
a0d0e21e |
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 | ######## |
648cac19 |
141 | chop ($str .= <DATA>); |
a0d0e21e |
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 | ######## |
68dc0745 |
151 | system './perl -ne "print if eof" /dev/null' |
a0d0e21e |
152 | ######## |
648cac19 |
153 | chop($file = <DATA>); |
a0d0e21e |
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 |
f1612b5c |
165 | Can't modify hash dereference in repeat (x) at - line 1, near "0;" |
3fe9a6f1 |
166 | Execution of - aborted due to compilation errors. |
a0d0e21e |
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 | ⊂ |
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. |
a7adf1f0 |
259 | ######## |
260 | { |
261 | package foo; |
262 | sub PRINT { |
263 | shift; |
264 | print join(' ', reverse @_)."\n"; |
265 | } |
46fc3d4c |
266 | sub PRINTF { |
267 | shift; |
268 | my $fmt = shift; |
269 | print sprintf($fmt, @_)."\n"; |
270 | } |
a7adf1f0 |
271 | sub TIEHANDLE { |
272 | bless {}, shift; |
273 | } |
58f51617 |
274 | sub READLINE { |
275 | "Out of inspiration"; |
276 | } |
a7adf1f0 |
277 | sub DESTROY { |
278 | print "and destroyed as well\n"; |
2ae324a7 |
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 | } |
a7adf1f0 |
290 | } |
291 | { |
292 | local(*FOO); |
293 | tie(*FOO,'foo'); |
294 | print FOO "sentence.", "reversed", "a", "is", "This"; |
58f51617 |
295 | print "-- ", <FOO>, " --\n"; |
2ae324a7 |
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"; |
46fc3d4c |
301 | printf "%s is number %d\n", "Perl", 1; |
a7adf1f0 |
302 | } |
303 | EXPECT |
304 | This is a reversed sentence. |
58f51617 |
305 | -- Out of inspiration -- |
2ae324a7 |
306 | foo->can(READ)(string 10 1) |
307 | Don't GETC, Get Perl |
46fc3d4c |
308 | Perl is number 1 |
a7adf1f0 |
309 | and destroyed as well |
a6006777 |
310 | ######## |
311 | my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" |
312 | EXPECT |
313 | 2 2 2 |
314 | ######## |
8ff950ac |
315 | # used to attach defelem magic to all immortal values, |
8b530633 |
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 | ######## |
a6006777 |
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 | ######## |
8ebc5c01 |
334 | print "ok\n" if ("\0" lt "\xFF"); |
a6006777 |
335 | EXPECT |
336 | ok |
337 | ######## |
9731f9ce |
338 | open(H,'run/kill_perl.t'); # must be in the 't' directory |
a6006777 |
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 | ######## |
d53f8f1c |
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 | ######## |
44a8e56a |
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 |
774d564b |
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); |
1ca7b98a |
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'; |
c277df42 |
411 | ######## |
412 | /(?{"{"})/ # Check it outside of eval too |
413 | EXPECT |
2cd61cdb |
414 | Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern |
7253e4e3 |
415 | Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. |
c277df42 |
416 | ######## |
417 | /(?{"{"}})/ # Check it outside of eval too |
418 | EXPECT |
d98d5fff |
419 | Unmatched right curly bracket at (re_eval 1) line 1, at end of line |
c277df42 |
420 | syntax error at (re_eval 1) line 1, near ""{"}" |
2cd61cdb |
421 | Compilation failed in regexp at - line 1. |
0da4822f |
422 | ######## |
ff689196 |
423 | BEGIN { @ARGV = qw(a b c d e) } |
0da4822f |
424 | BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } |
425 | END { print "end <",shift,">\nargv <@ARGV>\n" } |
426 | INIT { print "init <",shift,">\n" } |
7d30b5c4 |
427 | CHECK { print "check <",shift,">\n" } |
0da4822f |
428 | EXPECT |
ff689196 |
429 | argv <a b c d e> |
0da4822f |
430 | begin <a> |
7d30b5c4 |
431 | check <b> |
ff689196 |
432 | init <c> |
433 | end <d> |
434 | argv <e> |
4599a1de |
435 | ######## |
3500f679 |
436 | -l |
437 | # fdopen from a system descriptor to a system descriptor used to close |
438 | # the former. |
439 | open STDERR, '>&=STDOUT' or die $!; |
75642110 |
440 | select STDOUT; $| = 1; print fileno STDOUT or die $!; |
441 | select STDERR; $| = 1; print fileno STDERR or die $!; |
3500f679 |
442 | EXPECT |
443 | 1 |
444 | 2 |
445 | ######## |
20408e3c |
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 | ######## |
51ae5c03 |
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 |
ded8aa31 |
486 | sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } |
51ae5c03 |
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 | ######## |
ebf99b04 |
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. |
8feb4e9f |
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 |
dfad63ad |
548 | ######## |
549 | re(); |
550 | sub re { |
14455d6c |
551 | my $re = join '', eval 'qr/(??{ $obj->method })/'; |
dfad63ad |
552 | $re; |
553 | } |
554 | EXPECT |
1aff0e91 |
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 |
7399586d |
569 | ######## |
570 | -w |
571 | if (@ARGV) { print "" } |
572 | else { |
573 | if ($x == 0) { print "" } else { print $x } |
574 | } |
575 | EXPECT |
b89fed5f |
576 | Use of uninitialized value in numeric eq (==) at - line 4. |
1d76a5c3 |
577 | ######## |
578 | $x = sub {}; |
579 | foo(); |
580 | sub foo { eval { return }; } |
581 | print "ok\n"; |
582 | EXPECT |
583 | ok |
07447971 |
584 | ######## |
b0f2b690 |
585 | # moved to op/lc.t |
07447971 |
586 | EXPECT |
92d29cee |
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 |
6a7129a1 |
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. |
00c29ff8 |
600 | ######## |
601 | print qw(ab a\b a\\b); |
602 | EXPECT |
603 | aba\ba\b |
dd8482fc |
604 | ######## |
c71fccf1 |
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 | ######## |
2090ab20 |
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 | ######## |
dd8482fc |
629 | # This test is here instead of pragma/locale.t because |
630 | # the bug depends on in the internal state of the locale |
631 | # settings and pragma/locale messes up that state pretty badly. |
632 | # We need a "fresh run". |
c9f931b8 |
633 | BEGIN { |
634 | eval { require POSIX }; |
635 | if ($@) { |
636 | exit(0); # running minitest? |
637 | } |
638 | } |
dd8482fc |
639 | use Config; |
640 | my $have_setlocale = $Config{d_setlocale} eq 'define'; |
dd8482fc |
641 | $have_setlocale = 0 if $@; |
642 | # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" |
643 | # and mingw32 uses said silly CRT |
2986a63f |
644 | $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); |
dd8482fc |
645 | exit(0) unless $have_setlocale; |
646 | my @locales; |
647 | if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { |
648 | while(<LOCALES>) { |
649 | chomp; |
650 | push(@locales, $_); |
651 | } |
652 | close(LOCALES); |
653 | } |
654 | exit(0) unless @locales; |
655 | for (@locales) { |
656 | use POSIX qw(locale_h); |
657 | use locale; |
88e7acd2 |
658 | setlocale(LC_NUMERIC, $_) or next; |
dd8482fc |
659 | my $s = sprintf "%g %g", 3.1, 3.1; |
660 | next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; |
661 | print "$_ $s\n"; |
662 | } |
663 | EXPECT |
b927783e |
664 | ######## |
665 | die qr(x) |
666 | EXPECT |
667 | (?-xism:x) at - line 1. |
668 | ######## |
7ef822cd |
669 | # 20001210.003 mjd@plover.com |
670 | format REMITOUT_TOP = |
671 | FOO |
672 | . |
673 | |
674 | format REMITOUT = |
675 | BAR |
676 | . |
677 | |
678 | # This loop causes a segv in 5.6.0 |
679 | for $lineno (1..61) { |
680 | write REMITOUT; |
681 | } |
682 | |
683 | print "It's OK!"; |
684 | EXPECT |
685 | It's OK! |
cb55de95 |
686 | ######## |
687 | # Inaba Hiroto |
688 | reset; |
689 | if (0) { |
690 | if ("" =~ //) { |
691 | } |
692 | } |
693 | ######## |
694 | # Nicholas Clark |
695 | $ENV{TERM} = 0; |
696 | reset; |
697 | // if 0; |
698 | ######## |
699 | # Vadim Konovalov |
700 | use strict; |
701 | sub new_pmop($) { |
702 | my $pm = shift; |
703 | return eval "sub {shift=~/$pm/}"; |
704 | } |
705 | new_pmop "abcdef"; reset; |
706 | new_pmop "abcdef"; reset; |
707 | new_pmop "abcdef"; reset; |
708 | new_pmop "abcdef"; reset; |
880649cd |
709 | ######## |
710 | # David Dyck |
711 | # coredump in 5.7.1 |
712 | close STDERR; die; |
713 | EXPECT |
dba9804b |
714 | ######## |
99799961 |
715 | -w |
716 | "x" =~ /(\G?x)?/; # core dump in 20000716.007 |
99799961 |
717 | ######## |
dba9804b |
718 | # Bug 20010515.004 |
719 | my @h = 1 .. 10; |
720 | bad(@h); |
721 | sub bad { |
722 | undef @h; |
723 | print "O"; |
724 | print for @_; |
725 | print "K"; |
726 | } |
727 | EXPECT |
728 | OK |
97b9a4cb |
729 | ######## |
730 | # Bug 20010506.041 |
731 | "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n"; |
732 | EXPECT |
733 | ok |
0b490c9c |
734 | ######## |
735 | # Bug 20010422.005 |
736 | {s//${}/; //} |
737 | EXPECT |
2172ddaf |
738 | syntax error at - line 2, near "${}" |
0b490c9c |
739 | Execution of - aborted due to compilation errors. |
585602fa |
740 | ######## |
741 | # Bug 20010528.007 |
742 | "\x{" |
743 | EXPECT |
744 | Missing right brace on \x{} at - line 2, within string |
745 | Execution of - aborted due to compilation errors. |
08b362fd |
746 | ######## |
747 | my $foo = Bar->new(); |
748 | my @dst; |
749 | END { |
750 | ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/; |
751 | print $_, "\n"; |
752 | } |
753 | package Bar; |
754 | sub new { |
755 | my Bar $self = bless [], Bar; |
756 | eval '$self'; |
757 | return $self; |
758 | } |
759 | sub DESTROY { |
760 | push @dst, "$_[0]"; |
761 | } |
762 | EXPECT |
763 | Bar=ARRAY(0x...) |
1f96ff2a |
764 | ######## |
6ee35fb7 |
765 | # 20010407.008 sprintf removes utf8-ness |
766 | $a = sprintf "\x{1234}"; |
767 | printf "%x %d\n", unpack("U*", $a), length($a); |
9efebafb |
768 | $a = sprintf "%s", "\x{5678}"; |
769 | printf "%x %d\n", unpack("U*", $a), length($a); |
6ee35fb7 |
770 | $a = sprintf "\x{1234}%s", "\x{5678}"; |
771 | printf "%x %x %d\n", unpack("U*", $a), length($a); |
772 | EXPECT |
773 | 1234 1 |
9efebafb |
774 | 5678 1 |
6ee35fb7 |
775 | 1234 5678 2 |
7c8c5f1c |
776 | ######## found by Markov chain stress testing |
1f96ff2a |
777 | eval "a.b.c.d.e.f;sub" |
778 | EXPECT |
c9beb3f5 |
779 | |
780 | ######## perlbug ID 20010831.001 |
781 | ($a, b) = (1, 2); |
782 | EXPECT |
783 | Can't modify constant item in list assignment at - line 1, near ");" |
784 | Execution of - aborted due to compilation errors. |
f8d0fd74 |
785 | ######## tying a bareword causes a segfault in 5.6.1 |
786 | tie FOO, "Foo"; |
787 | EXPECT |
788 | Can't modify constant item in tie at - line 1, near ""Foo";" |
789 | Execution of - aborted due to compilation errors. |
abfc75a9 |
790 | ######## undefing constant causes a segfault in 5.6.1 [ID 20010906.019] |
791 | undef foo; |
792 | EXPECT |
793 | Can't modify constant item in undef operator at - line 1, near "foo;" |
794 | Execution of - aborted due to compilation errors. |
8bfdd7d9 |
795 | ######## (?{...}) compilation bounces on PL_rs |
796 | -0 |
797 | { |
798 | /(?{ $x })/; |
799 | # { |
800 | } |
801 | BEGIN { print "ok\n" } |
802 | EXPECT |
803 | ok |
c74e71c7 |
804 | ######## read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054] |
805 | read($bla, FILE, 1); |
806 | EXPECT |
807 | Can't modify constant item in read at - line 1, near "1)" |
808 | Execution of - aborted due to compilation errors. |
80071be7 |
809 | ######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155] |
810 | # This only happens if the filename is 11 characters or less. |
811 | $foo = \-f "blah"; |
812 | print "ok" if ref $foo && !$$foo; |
813 | EXPECT |
814 | ok |
15a59b2d |
815 | ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1 |
816 | print "ok" if 'X' =~ /\X/; |
817 | EXPECT |
818 | ok |