Commit | Line | Data |
a0d0e21e |
1 | #!./perl |
2 | |
eeabcb2d |
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 |
8 | # errors that might kill the interpreter and for some reason you can't |
9 | # use an eval(). |
fb73857a |
10 | |
c9beb3f5 |
11 | BEGIN { |
12 | chdir 't' if -d 't'; |
13 | @INC = '../lib'; |
c59238f2 |
14 | require './test.pl'; # for which_perl() etc |
c9beb3f5 |
15 | } |
16 | |
17 | use strict; |
a0d0e21e |
18 | |
c59238f2 |
19 | my $Perl = which_perl(); |
b5fe401b |
20 | |
a0d0e21e |
21 | $|=1; |
22 | |
c9beb3f5 |
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 |
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 |
41 | |
42 | my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog); |
ccecb81f |
43 | $prog .= "\n"; |
44 | $expected = '' unless defined $expected; |
c9beb3f5 |
45 | |
b97a373d |
46 | if ($prog =~ /^\# SKIP: (.+)/m) { |
47 | if (eval $1) { |
48 | ok(1, "Skip: $1"); |
49 | next; |
50 | } |
51 | } |
52 | |
f5cda331 |
53 | $expected =~ s/\n+$//; |
54 | |
ccecb81f |
55 | fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name); |
a0d0e21e |
56 | } |
57 | |
58 | __END__ |
2ace3117 |
59 | ######## |
44a8e56a |
60 | $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" |
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 |
71 | $foo=undef; $foo->go; |
72 | EXPECT |
72b5445b |
73 | Can't call method "go" on an undefined value at - line 1. |
a0d0e21e |
74 | ######## |
75 | BEGIN |
76 | { |
77 | "foo"; |
78 | } |
79 | ######## |
a0d0e21e |
80 | $array[128]=1 |
81 | ######## |
82 | $x=0x0eabcd; print $x->ref; |
83 | EXPECT |
84 | Can't call method "ref" without a package or object reference at - line 1. |
85 | ######## |
648cac19 |
86 | chop ($str .= <DATA>); |
a0d0e21e |
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 |
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 |
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 |
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 |
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 |
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 | ######## |
348 | sub foo { local $_ = shift; split; @_ } |
349 | @x = foo(' x y z '); |
350 | print "you die joe!\n" unless "@x" eq 'x y z'; |
c277df42 |
351 | ######## |
352 | /(?{"{"})/ # Check it outside of eval too |
353 | EXPECT |
7253e4e3 |
354 | Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. |
c277df42 |
355 | ######## |
356 | /(?{"{"}})/ # Check it outside of eval too |
357 | EXPECT |
d98d5fff |
358 | Unmatched right curly bracket at (re_eval 1) line 1, at end of line |
c277df42 |
359 | syntax error at (re_eval 1) line 1, near ""{"}" |
2cd61cdb |
360 | Compilation failed in regexp at - line 1. |
0da4822f |
361 | ######## |
ff689196 |
362 | BEGIN { @ARGV = qw(a b c d e) } |
0da4822f |
363 | BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } |
364 | END { print "end <",shift,">\nargv <@ARGV>\n" } |
365 | INIT { print "init <",shift,">\n" } |
7d30b5c4 |
366 | CHECK { print "check <",shift,">\n" } |
0da4822f |
367 | EXPECT |
ff689196 |
368 | argv <a b c d e> |
0da4822f |
369 | begin <a> |
7d30b5c4 |
370 | check <b> |
ff689196 |
371 | init <c> |
372 | end <d> |
373 | argv <e> |
4599a1de |
374 | ######## |
3500f679 |
375 | -l |
376 | # fdopen from a system descriptor to a system descriptor used to close |
377 | # the former. |
378 | open STDERR, '>&=STDOUT' or die $!; |
75642110 |
379 | select STDOUT; $| = 1; print fileno STDOUT or die $!; |
380 | select STDERR; $| = 1; print fileno STDERR or die $!; |
3500f679 |
381 | EXPECT |
382 | 1 |
383 | 2 |
384 | ######## |
20408e3c |
385 | -w |
386 | sub testme { my $a = "test"; { local $a = "new test"; print $a }} |
387 | EXPECT |
ccecb81f |
388 | Can't localize lexical variable $a at - line 1. |
20408e3c |
389 | ######## |
51ae5c03 |
390 | package X; |
391 | sub ascalar { my $r; bless \$r } |
392 | sub DESTROY { print "destroyed\n" }; |
393 | package main; |
394 | *s = ascalar X; |
395 | EXPECT |
396 | destroyed |
397 | ######## |
398 | package X; |
399 | sub anarray { bless [] } |
400 | sub DESTROY { print "destroyed\n" }; |
401 | package main; |
402 | *a = anarray X; |
403 | EXPECT |
404 | destroyed |
405 | ######## |
406 | package X; |
407 | sub ahash { bless {} } |
408 | sub DESTROY { print "destroyed\n" }; |
409 | package main; |
410 | *h = ahash X; |
411 | EXPECT |
412 | destroyed |
413 | ######## |
414 | package X; |
415 | sub aclosure { my $x; bless sub { ++$x } } |
416 | sub DESTROY { print "destroyed\n" }; |
417 | package main; |
418 | *c = aclosure X; |
419 | EXPECT |
420 | destroyed |
421 | ######## |
422 | package X; |
423 | sub any { bless {} } |
424 | my $f = "FH000"; # just to thwart any future optimisations |
ded8aa31 |
425 | sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } |
51ae5c03 |
426 | sub DESTROY { print "destroyed\n" } |
427 | package main; |
428 | $x = any X; # to bump sv_objcount. IO objs aren't counted?? |
429 | *f = afh X; |
430 | EXPECT |
431 | destroyed |
432 | destroyed |
433 | ######## |
ebf99b04 |
434 | BEGIN { |
435 | $| = 1; |
436 | $SIG{__WARN__} = sub { |
437 | eval { print $_[0] }; |
438 | die "bar\n"; |
439 | }; |
440 | warn "foo\n"; |
441 | } |
442 | EXPECT |
443 | foo |
444 | bar |
445 | BEGIN failed--compilation aborted at - line 8. |
8feb4e9f |
446 | ######## |
447 | package X; |
448 | @ISA='Y'; |
449 | sub new { |
450 | my $class = shift; |
451 | my $self = { }; |
452 | bless $self, $class; |
453 | my $init = shift; |
454 | $self->foo($init); |
455 | print "new", $init; |
456 | return $self; |
457 | } |
458 | sub DESTROY { |
459 | my $self = shift; |
460 | print "DESTROY", $self->foo; |
461 | } |
462 | package Y; |
463 | sub attribute { |
464 | my $self = shift; |
465 | my $var = shift; |
466 | if (@_ == 0) { |
467 | return $self->{$var}; |
468 | } elsif (@_ == 1) { |
469 | $self->{$var} = shift; |
470 | } |
471 | } |
472 | sub AUTOLOAD { |
473 | $AUTOLOAD =~ /::([^:]+)$/; |
474 | my $method = $1; |
475 | splice @_, 1, 0, $method; |
476 | goto &attribute; |
477 | } |
478 | package main; |
479 | my $x = X->new(1); |
480 | for (2..3) { |
481 | my $y = X->new($_); |
482 | print $y->foo; |
483 | } |
484 | print $x->foo; |
485 | EXPECT |
486 | new1new22DESTROY2new33DESTROY31DESTROY1 |
dfad63ad |
487 | ######## |
488 | re(); |
489 | sub re { |
14455d6c |
490 | my $re = join '', eval 'qr/(??{ $obj->method })/'; |
dfad63ad |
491 | $re; |
492 | } |
493 | EXPECT |
1aff0e91 |
494 | ######## |
495 | use strict; |
496 | my $foo = "ZZZ\n"; |
497 | END { print $foo } |
498 | EXPECT |
499 | ZZZ |
500 | ######## |
501 | eval ' |
502 | use strict; |
503 | my $foo = "ZZZ\n"; |
504 | END { print $foo } |
505 | '; |
506 | EXPECT |
507 | ZZZ |
7399586d |
508 | ######## |
509 | -w |
510 | if (@ARGV) { print "" } |
511 | else { |
512 | if ($x == 0) { print "" } else { print $x } |
513 | } |
514 | EXPECT |
ccecb81f |
515 | Use of uninitialized value $x in numeric eq (==) at - line 3. |
1d76a5c3 |
516 | ######## |
517 | $x = sub {}; |
518 | foo(); |
519 | sub foo { eval { return }; } |
520 | print "ok\n"; |
521 | EXPECT |
522 | ok |
07447971 |
523 | ######## |
b0f2b690 |
524 | # moved to op/lc.t |
07447971 |
525 | EXPECT |
92d29cee |
526 | ######## |
527 | sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } |
528 | my $x = "foo"; |
529 | { f } continue { print $x, "\n" } |
530 | EXPECT |
531 | foo |
6a7129a1 |
532 | ######## |
533 | sub C () { 1 } |
534 | sub M { $_[0] = 2; } |
535 | eval "C"; |
536 | M(C); |
537 | EXPECT |
538 | Modification of a read-only value attempted at - line 2. |
00c29ff8 |
539 | ######## |
540 | print qw(ab a\b a\\b); |
541 | EXPECT |
542 | aba\ba\b |
dd8482fc |
543 | ######## |
c71fccf1 |
544 | # lexicals declared after the myeval() definition should not be visible |
545 | # within it |
546 | sub myeval { eval $_[0] } |
547 | my $foo = "ok 2\n"; |
548 | myeval('sub foo { local $foo = "ok 1\n"; print $foo; }'); |
549 | die $@ if $@; |
550 | foo(); |
551 | print $foo; |
552 | EXPECT |
553 | ok 1 |
554 | ok 2 |
555 | ######## |
2090ab20 |
556 | # lexicals outside an eval"" should be visible inside subroutine definitions |
557 | # within it |
558 | eval <<'EOT'; die $@ if $@; |
559 | { |
560 | my $X = "ok\n"; |
561 | eval 'sub Y { print $X }'; die $@ if $@; |
562 | Y(); |
563 | } |
564 | EOT |
565 | EXPECT |
566 | ok |
567 | ######## |
e5e32a3a |
568 | # This test is here instead of lib/locale.t because |
dd8482fc |
569 | # the bug depends on in the internal state of the locale |
570 | # settings and pragma/locale messes up that state pretty badly. |
571 | # We need a "fresh run". |
c9f931b8 |
572 | BEGIN { |
573 | eval { require POSIX }; |
574 | if ($@) { |
575 | exit(0); # running minitest? |
576 | } |
577 | } |
dd8482fc |
578 | use Config; |
579 | my $have_setlocale = $Config{d_setlocale} eq 'define'; |
dd8482fc |
580 | $have_setlocale = 0 if $@; |
581 | # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" |
582 | # and mingw32 uses said silly CRT |
2986a63f |
583 | $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); |
dd8482fc |
584 | exit(0) unless $have_setlocale; |
585 | my @locales; |
e5e32a3a |
586 | if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { |
dd8482fc |
587 | while(<LOCALES>) { |
588 | chomp; |
589 | push(@locales, $_); |
590 | } |
591 | close(LOCALES); |
592 | } |
593 | exit(0) unless @locales; |
594 | for (@locales) { |
595 | use POSIX qw(locale_h); |
596 | use locale; |
88e7acd2 |
597 | setlocale(LC_NUMERIC, $_) or next; |
dd8482fc |
598 | my $s = sprintf "%g %g", 3.1, 3.1; |
599 | next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; |
600 | print "$_ $s\n"; |
601 | } |
602 | EXPECT |
b927783e |
603 | ######## |
bf12611a |
604 | # [ID 20001202.002] and change #8066 added 'at -e line 1'; |
605 | # reversed again as a result of [perl #17763] |
b927783e |
606 | die qr(x) |
607 | EXPECT |
bf12611a |
608 | (?-xism:x) |
b927783e |
609 | ######## |
7ef822cd |
610 | # 20001210.003 mjd@plover.com |
611 | format REMITOUT_TOP = |
612 | FOO |
613 | . |
614 | |
615 | format REMITOUT = |
616 | BAR |
617 | . |
618 | |
619 | # This loop causes a segv in 5.6.0 |
620 | for $lineno (1..61) { |
621 | write REMITOUT; |
622 | } |
623 | |
624 | print "It's OK!"; |
625 | EXPECT |
626 | It's OK! |
cb55de95 |
627 | ######## |
628 | # Inaba Hiroto |
629 | reset; |
630 | if (0) { |
631 | if ("" =~ //) { |
632 | } |
633 | } |
634 | ######## |
635 | # Nicholas Clark |
636 | $ENV{TERM} = 0; |
637 | reset; |
638 | // if 0; |
639 | ######## |
640 | # Vadim Konovalov |
641 | use strict; |
642 | sub new_pmop($) { |
643 | my $pm = shift; |
644 | return eval "sub {shift=~/$pm/}"; |
645 | } |
646 | new_pmop "abcdef"; reset; |
647 | new_pmop "abcdef"; reset; |
648 | new_pmop "abcdef"; reset; |
649 | new_pmop "abcdef"; reset; |
880649cd |
650 | ######## |
651 | # David Dyck |
652 | # coredump in 5.7.1 |
653 | close STDERR; die; |
654 | EXPECT |
dba9804b |
655 | ######## |
ccecb81f |
656 | # core dump in 20000716.007 |
99799961 |
657 | -w |
ccecb81f |
658 | "x" =~ /(\G?x)?/; |
99799961 |
659 | ######## |
dba9804b |
660 | # Bug 20010515.004 |
661 | my @h = 1 .. 10; |
662 | bad(@h); |
663 | sub bad { |
664 | undef @h; |
665 | print "O"; |
666 | print for @_; |
667 | print "K"; |
668 | } |
669 | EXPECT |
670 | OK |
97b9a4cb |
671 | ######## |
672 | # Bug 20010506.041 |
673 | "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n"; |
674 | EXPECT |
675 | ok |
0b490c9c |
676 | ######## |
08b362fd |
677 | my $foo = Bar->new(); |
678 | my @dst; |
679 | END { |
680 | ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/; |
681 | print $_, "\n"; |
682 | } |
683 | package Bar; |
684 | sub new { |
685 | my Bar $self = bless [], Bar; |
686 | eval '$self'; |
687 | return $self; |
688 | } |
689 | sub DESTROY { |
690 | push @dst, "$_[0]"; |
691 | } |
692 | EXPECT |
693 | Bar=ARRAY(0x...) |
8bfdd7d9 |
694 | ######## (?{...}) compilation bounces on PL_rs |
695 | -0 |
696 | { |
697 | /(?{ $x })/; |
698 | # { |
699 | } |
700 | BEGIN { print "ok\n" } |
701 | EXPECT |
702 | ok |
80071be7 |
703 | ######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155] |
704 | # This only happens if the filename is 11 characters or less. |
705 | $foo = \-f "blah"; |
706 | print "ok" if ref $foo && !$$foo; |
707 | EXPECT |
708 | ok |
15a59b2d |
709 | ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1 |
710 | print "ok" if 'X' =~ /\X/; |
711 | EXPECT |
712 | ok |
f9dc862f |
713 | ######## segfault in 5.6.1 within peep() |
714 | @a = (1..9); |
715 | @b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a; |
716 | print join '', @a, "\n"; |
717 | EXPECT |
718 | 123456789 |
82686b01 |
719 | ######## example from Camel 5, ch. 15, pp.406 (with my) |
b97a373d |
720 | # SKIP: ord "A" == 193 # EBCDIC |
82686b01 |
721 | use strict; |
722 | use utf8; |
723 | my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph |
724 | $人++; # a child is born |
725 | print $人, "\n"; |
726 | EXPECT |
727 | 3 |
728 | ######## example from Camel 5, ch. 15, pp.406 (with our) |
b97a373d |
729 | # SKIP: ord "A" == 193 # EBCDIC |
82686b01 |
730 | use strict; |
731 | use utf8; |
732 | our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph |
733 | $人++; # a child is born |
734 | print $人, "\n"; |
735 | EXPECT |
736 | 3 |
737 | ######## example from Camel 5, ch. 15, pp.406 (with package vars) |
b97a373d |
738 | # SKIP: ord "A" == 193 # EBCDIC |
82686b01 |
739 | use utf8; |
740 | $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph |
741 | $人++; # a child is born |
742 | print $人, "\n"; |
743 | EXPECT |
744 | 3 |
08cd7fd6 |
745 | ######## example from Camel 5, ch. 15, pp.406 (with use vars) |
746 | # SKIP: ord "A" == 193 # EBCDIC |
747 | use strict; |
748 | use utf8; |
749 | use vars qw($人); |
750 | $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph |
751 | $人++; # a child is born |
752 | print $人, "\n"; |
753 | EXPECT |
754 | 3 |
650375fe |
755 | ######## |
756 | # test that closures generated by eval"" hold on to the CV of the eval"" |
757 | # for their entire lifetime |
758 | $code = eval q[ |
759 | sub { eval '$x = "ok 1\n"'; } |
760 | ]; |
761 | &{$code}(); |
762 | print $x; |
763 | EXPECT |
764 | ok 1 |
765 | ######## [ID 20020623.009] nested eval/sub segfaults |
766 | $eval = eval 'sub { eval "sub { %S }" }'; |
767 | $eval->({}); |
df68b396 |
768 | ######## [perl #17951] Strange UTF error |
769 | -W |
770 | # From: "John Kodis" <kodis@mail630.gsfc.nasa.gov> |
771 | # Newsgroups: comp.lang.perl.moderated |
772 | # Subject: Strange UTF error |
773 | # Date: Fri, 11 Oct 2002 16:19:58 -0400 |
774 | # Message-ID: <pan.2002.10.11.20.19.48.407190@mail630.gsfc.nasa.gov> |
775 | $_ = "foobar\n"; |
776 | utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN) |
777 | # matching is actually irrelevant: avoiding several dozen of these |
778 | # Illegal hexadecimal digit ' ' ignored at /usr/lib/perl5/5.8.0/utf8_heavy.pl line 152 |
779 | # is what matters. |
780 | /^([[:digit:]]+)/; |
781 | EXPECT |
d12e50cf |
782 | ######## [perl #20667] unicode regex vs non-unicode regex |
783 | $toto = 'Hello'; |
784 | $toto =~ /\w/; # this line provokes the problem! |
785 | $name = 'A B'; |
786 | # utf8::upgrade($name) if @ARGV; |
787 | if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){ |
788 | print "It's good! >$1< >$2<\n"; |
789 | } else { |
790 | print "It's not good...\n"; |
791 | } |
792 | EXPECT |
793 | It's good! >A< >B< |
4f49a093 |
794 | ######## [perl #8760] strangness with utf8 and warn |
795 | $_="foo";utf8::upgrade($_);/bar/i,warn$_; |
796 | EXPECT |
797 | foo at - line 1. |
f444d496 |
798 | ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com> |
799 | -lw |
8cf0503e |
800 | BEGIN { |
250d67eb |
801 | if ($^O eq 'os390') { |
802 | require File::Glob; |
803 | import File::Glob ':glob'; |
804 | } |
805 | } |
806 | BEGIN { |
8cf0503e |
807 | eval 'require Fcntl'; |
808 | if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest? |
809 | } |
e344bad3 |
810 | if ($^O eq 'VMS') { # VMS is not *that* kind of a glob. |
8cf0503e |
811 | print qq[./"TEST"\n./"TEST"\n]; |
e344bad3 |
812 | } else { |
f444d496 |
813 | print glob(q(./"TEST")); |
814 | use File::Glob; |
815 | print glob(q(./"TEST")); |
e344bad3 |
816 | } |
f444d496 |
817 | EXPECT |
818 | ./"TEST" |
819 | ./"TEST" |
820 | ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com> |
821 | -lw |
8cf0503e |
822 | BEGIN { |
250d67eb |
823 | if ($^O eq 'os390') { |
824 | require File::Glob; |
825 | import File::Glob ':glob'; |
826 | } |
827 | } |
828 | BEGIN { |
8cf0503e |
829 | eval 'require Fcntl'; |
830 | if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest? |
831 | } |
e344bad3 |
832 | if ($^O eq 'VMS') { # VMS is not *that* kind of a glob. |
8cf0503e |
833 | print qq[./"TEST"\n./"TEST"\n]; |
e344bad3 |
834 | } else { |
f444d496 |
835 | use File::Glob; |
836 | print glob(q(./"TEST")); |
837 | use File::Glob; |
838 | print glob(q(./"TEST")); |
e344bad3 |
839 | } |
f444d496 |
840 | EXPECT |
841 | ./"TEST" |
842 | ./"TEST" |
078c425b |
843 | ######## "Segfault using HTML::Entities", Richard Jolly <richardjolly@mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6@mac.com> in perl-unicode@perl.org |
844 | -lw |
46cea157 |
845 | # SKIP: use Config; $ENV{PERL_CORE_MINITEST} or " $Config::Config{'extensions'} " !~ m[ Encode ] # Perl configured without Encode module |
078c425b |
846 | BEGIN { |
847 | eval 'require Encode'; |
848 | if ($@) { exit 0 } # running minitest? |
849 | } |
850 | # Test case cut down by jhi |
851 | $SIG{__WARN__} = sub { $@ = shift }; |
852 | use Encode; |
250d67eb |
853 | my $t = ord('A') == 193 ? "\xEA" : "\xE9"; |
078c425b |
854 | Encode::_utf8_on($t); |
855 | $t =~ s/([^a])//ge; |
856 | $@ =~ s/ at .*/ at/; |
857 | print $@ |
858 | EXPECT |
a3b680e6 |
859 | Malformed UTF-8 character (unexpected end of string) in substitution (s///) at |