Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | #!./perl |
2 | ||
fb73857a | 3 | # NOTE: Please don't add tests to this file unless they *need* to be run in |
4 | # separate executable and can't simply use eval. | |
5 | ||
a0d0e21e | 6 | chdir 't' if -d 't'; |
20822f61 | 7 | @INC = '../lib'; |
a0d0e21e LW |
8 | $ENV{PERL5LIB} = "../lib"; |
9 | ||
10 | $|=1; | |
11 | ||
12 | undef $/; | |
13 | @prgs = split "\n########\n", <DATA>; | |
14 | print "1..", scalar @prgs, "\n"; | |
15 | ||
16 | $tmpfile = "misctmp000"; | |
17 | 1 while -f ++$tmpfile; | |
ed6b3797 | 18 | END { while($tmpfile && unlink $tmpfile){} } |
a0d0e21e | 19 | |
68dc0745 | 20 | $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); |
21 | ||
a0d0e21e LW |
22 | for (@prgs){ |
23 | my $switch; | |
fb73857a | 24 | if (s/^\s*(-\w.*)//){ |
25 | $switch = $1; | |
a0d0e21e LW |
26 | } |
27 | my($prog,$expected) = split(/\nEXPECT\n/, $_); | |
648cac19 | 28 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
ed6b3797 CL |
29 | $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; |
30 | $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking | |
31 | ||
648cac19 IZ |
32 | print TEST $prog, "\n"; |
33 | close TEST or die "Cannot close $tmpfile: $!"; | |
34 | ||
68dc0745 | 35 | if ($^O eq 'MSWin32') { |
648cac19 | 36 | $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; |
68dc0745 | 37 | } |
38 | else { | |
648cac19 | 39 | $results = `./perl $switch $tmpfile 2>&1`; |
68dc0745 | 40 | } |
a0d0e21e | 41 | $status = $?; |
a0d0e21e | 42 | $results =~ s/\n+$//; |
648cac19 IZ |
43 | $results =~ s/at\s+misctmp\d+\s+line/at - line/g; |
44 | $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; | |
f0ec1f9a | 45 | # bison says 'parse error' instead of 'syntax error', |
d91e2bdb | 46 | # various yaccs may or may not capitalize 'syntax'. |
2a8ee232 | 47 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
a0d0e21e | 48 | $expected =~ s/\n+$//; |
8feb4e9f | 49 | if ( $results ne $expected ) { |
a0d0e21e LW |
50 | print STDERR "PROG: $switch\n$prog\n"; |
51 | print STDERR "EXPECTED:\n$expected\n"; | |
52 | print STDERR "GOT:\n$results\n"; | |
53 | print "not "; | |
54 | } | |
55 | print "ok ", ++$i, "\n"; | |
56 | } | |
57 | ||
58 | __END__ | |
2ace3117 CS |
59 | ()=() |
60 | ######## | |
44a8e56a | 61 | $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" |
62 | EXPECT | |
63 | a := b := c | |
64 | ######## | |
36477c24 | 65 | $cusp = ~0 ^ (~0 >> 1); |
85e0ebd8 | 66 | use integer; |
36477c24 | 67 | $, = " "; |
85e0ebd8 | 68 | print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; |
36477c24 | 69 | EXPECT |
85e0ebd8 | 70 | 7 0 0 8 ! |
36477c24 | 71 | ######## |
a0d0e21e LW |
72 | $foo=undef; $foo->go; |
73 | EXPECT | |
72b5445b | 74 | Can't call method "go" on an undefined value at - line 1. |
a0d0e21e LW |
75 | ######## |
76 | BEGIN | |
77 | { | |
78 | "foo"; | |
79 | } | |
80 | ######## | |
a0d0e21e LW |
81 | $array[128]=1 |
82 | ######## | |
83 | $x=0x0eabcd; print $x->ref; | |
84 | EXPECT | |
85 | Can't call method "ref" without a package or object reference at - line 1. | |
86 | ######## | |
648cac19 | 87 | chop ($str .= <DATA>); |
a0d0e21e LW |
88 | ######## |
89 | close ($banana); | |
90 | ######## | |
91 | $x=2;$y=3;$x<$y ? $x : $y += 23;print $x; | |
92 | EXPECT | |
93 | 25 | |
94 | ######## | |
95 | eval {sub bar {print "In bar";}} | |
96 | ######## | |
68dc0745 | 97 | system './perl -ne "print if eof" /dev/null' |
a0d0e21e | 98 | ######## |
648cac19 | 99 | chop($file = <DATA>); |
a0d0e21e LW |
100 | ######## |
101 | package N; | |
102 | sub new {my ($obj,$n)=@_; bless \$n} | |
103 | $aa=new N 1; | |
104 | $aa=12345; | |
105 | print $aa; | |
106 | EXPECT | |
107 | 12345 | |
108 | ######## | |
109 | %@x=0; | |
110 | EXPECT | |
f1612b5c | 111 | Can't modify hash dereference in repeat (x) at - line 1, near "0;" |
3fe9a6f1 | 112 | Execution of - aborted due to compilation errors. |
a0d0e21e LW |
113 | ######## |
114 | $_="foo"; | |
115 | printf(STDOUT "%s\n", $_); | |
116 | EXPECT | |
117 | foo | |
118 | ######## | |
119 | push(@a, 1, 2, 3,) | |
120 | ######## | |
121 | quotemeta "" | |
122 | ######## | |
123 | for ("ABCDE") { | |
124 | ⊂ | |
125 | s/./&sub($&)/eg; | |
126 | print;} | |
127 | sub sub {local($_) = @_; | |
128 | $_ x 4;} | |
129 | EXPECT | |
130 | Modification of a read-only value attempted at - line 3. | |
131 | ######## | |
132 | package FOO;sub new {bless {FOO => BAR}}; | |
133 | package main; | |
134 | use strict vars; | |
135 | my $self = new FOO; | |
136 | print $$self{FOO}; | |
137 | EXPECT | |
138 | BAR | |
139 | ######## | |
140 | $_="foo"; | |
141 | s/.{1}//s; | |
142 | print; | |
143 | EXPECT | |
144 | oo | |
145 | ######## | |
146 | print scalar ("foo","bar") | |
147 | EXPECT | |
148 | bar | |
149 | ######## | |
150 | sub by_number { $a <=> $b; };# inline function for sort below | |
151 | $as_ary{0}="a0"; | |
152 | @ordered_array=sort by_number keys(%as_ary); | |
153 | ######## | |
154 | sub NewShell | |
155 | { | |
156 | local($Host) = @_; | |
157 | my($m2) = $#Shells++; | |
158 | $Shells[$m2]{HOST} = $Host; | |
159 | return $m2; | |
160 | } | |
161 | ||
162 | sub ShowShell | |
163 | { | |
164 | local($i) = @_; | |
165 | } | |
166 | ||
167 | &ShowShell(&NewShell(beach,Work,"+0+0")); | |
168 | &ShowShell(&NewShell(beach,Work,"+0+0")); | |
169 | &ShowShell(&NewShell(beach,Work,"+0+0")); | |
170 | ######## | |
171 | { | |
172 | package FAKEARRAY; | |
173 | ||
174 | sub TIEARRAY | |
175 | { print "TIEARRAY @_\n"; | |
176 | die "bomb out\n" unless $count ++ ; | |
177 | bless ['foo'] | |
178 | } | |
179 | sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } | |
180 | sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } | |
181 | sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } | |
182 | } | |
183 | ||
184 | eval 'tie @h, FAKEARRAY, fred' ; | |
185 | tie @h, FAKEARRAY, fred ; | |
186 | EXPECT | |
187 | TIEARRAY FAKEARRAY fred | |
188 | TIEARRAY FAKEARRAY fred | |
189 | DESTROY | |
190 | ######## | |
191 | BEGIN { die "phooey\n" } | |
192 | EXPECT | |
193 | phooey | |
194 | BEGIN failed--compilation aborted at - line 1. | |
195 | ######## | |
196 | BEGIN { 1/$zero } | |
197 | EXPECT | |
198 | Illegal division by zero at - line 1. | |
199 | BEGIN failed--compilation aborted at - line 1. | |
200 | ######## | |
201 | BEGIN { undef = 0 } | |
202 | EXPECT | |
203 | Modification of a read-only value attempted at - line 1. | |
204 | BEGIN failed--compilation aborted at - line 1. | |
a7adf1f0 | 205 | ######## |
206 | { | |
207 | package foo; | |
208 | sub PRINT { | |
209 | shift; | |
210 | print join(' ', reverse @_)."\n"; | |
211 | } | |
46fc3d4c | 212 | sub PRINTF { |
213 | shift; | |
214 | my $fmt = shift; | |
215 | print sprintf($fmt, @_)."\n"; | |
216 | } | |
a7adf1f0 | 217 | sub TIEHANDLE { |
218 | bless {}, shift; | |
219 | } | |
58f51617 SV |
220 | sub READLINE { |
221 | "Out of inspiration"; | |
222 | } | |
a7adf1f0 | 223 | sub DESTROY { |
224 | print "and destroyed as well\n"; | |
2ae324a7 | 225 | } |
226 | sub READ { | |
227 | shift; | |
228 | print STDOUT "foo->can(READ)(@_)\n"; | |
229 | return 100; | |
230 | } | |
231 | sub GETC { | |
232 | shift; | |
233 | print STDOUT "Don't GETC, Get Perl\n"; | |
234 | return "a"; | |
235 | } | |
a7adf1f0 | 236 | } |
237 | { | |
238 | local(*FOO); | |
239 | tie(*FOO,'foo'); | |
240 | print FOO "sentence.", "reversed", "a", "is", "This"; | |
58f51617 | 241 | print "-- ", <FOO>, " --\n"; |
2ae324a7 | 242 | my($buf,$len,$offset); |
243 | $buf = "string"; | |
244 | $len = 10; $offset = 1; | |
245 | read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; | |
246 | getc(FOO) eq "a" or die "foo->GETC failed"; | |
46fc3d4c | 247 | printf "%s is number %d\n", "Perl", 1; |
a7adf1f0 | 248 | } |
249 | EXPECT | |
250 | This is a reversed sentence. | |
58f51617 | 251 | -- Out of inspiration -- |
2ae324a7 | 252 | foo->can(READ)(string 10 1) |
253 | Don't GETC, Get Perl | |
46fc3d4c | 254 | Perl is number 1 |
a7adf1f0 | 255 | and destroyed as well |
a6006777 | 256 | ######## |
257 | my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" | |
258 | EXPECT | |
259 | 2 2 2 | |
260 | ######## | |
8b530633 GA |
261 | # used to attach defelem magic too all immortal values, |
262 | # which made restore of local $_ fail. | |
263 | foo(2>1); | |
264 | sub foo { bar() for @_; } | |
265 | sub bar { local $_; } | |
266 | print "ok\n"; | |
267 | EXPECT | |
268 | ok | |
269 | ######## | |
a6006777 | 270 | @a = ($a, $b, $c, $d) = (5, 6); |
271 | print "ok\n" | |
272 | if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); | |
273 | EXPECT | |
274 | ok | |
275 | ######## | |
276 | print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); | |
277 | EXPECT | |
278 | ok | |
279 | ######## | |
8ebc5c01 | 280 | print "ok\n" if ("\0" lt "\xFF"); |
a6006777 | 281 | EXPECT |
282 | ok | |
283 | ######## | |
284 | open(H,'op/misc.t'); # must be in the 't' directory | |
285 | stat(H); | |
286 | print "ok\n" if (-e _ and -f _ and -r _); | |
287 | EXPECT | |
288 | ok | |
289 | ######## | |
290 | sub thing { 0 || return qw(now is the time) } | |
291 | print thing(), "\n"; | |
292 | EXPECT | |
293 | nowisthetime | |
294 | ######## | |
295 | $ren = 'joy'; | |
296 | $stimpy = 'happy'; | |
297 | { local $main::{ren} = *stimpy; print $ren, ' ' } | |
298 | print $ren, "\n"; | |
299 | EXPECT | |
300 | happy joy | |
301 | ######## | |
302 | $stimpy = 'happy'; | |
303 | { local $main::{ren} = *stimpy; print ${'ren'}, ' ' } | |
304 | print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; | |
305 | EXPECT | |
306 | happy joy | |
307 | ######## | |
308 | package p; | |
309 | sub func { print 'really ' unless wantarray; 'p' } | |
310 | sub groovy { 'groovy' } | |
311 | package main; | |
312 | print p::func()->groovy(), "\n" | |
313 | EXPECT | |
314 | really groovy | |
315 | ######## | |
d53f8f1c HS |
316 | @list = ([ 'one', 1 ], [ 'two', 2 ]); |
317 | sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } | |
318 | print scalar(map &func($_), 1 .. 3), " ", | |
319 | scalar(map scalar &func($_), 1 .. 3), "\n"; | |
320 | EXPECT | |
321 | 2 3 | |
322 | ######## | |
44a8e56a | 323 | ($k, $s) = qw(x 0); |
324 | @{$h{$k}} = qw(1 2 4); | |
325 | for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } | |
326 | print "bogus\n" unless $s == 7; | |
327 | ######## | |
328 | my $a = 'outer'; | |
329 | eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; | |
330 | eval { my $x = 'peace'; eval q[ print "$x\n" ] } | |
331 | EXPECT | |
332 | inner peace | |
774d564b | 333 | ######## |
334 | -w | |
335 | $| = 1; | |
336 | sub foo { | |
337 | print "In foo1\n"; | |
338 | eval 'sub foo { print "In foo2\n" }'; | |
339 | print "Exiting foo1\n"; | |
340 | } | |
341 | foo; | |
342 | foo; | |
343 | EXPECT | |
344 | In foo1 | |
345 | Subroutine foo redefined at (eval 1) line 1. | |
346 | Exiting foo1 | |
347 | In foo2 | |
348 | ######## | |
349 | $s = 0; | |
350 | map {#this newline here tickles the bug | |
351 | $s += $_} (1,2,4); | |
352 | print "eat flaming death\n" unless ($s == 7); | |
1ca7b98a CS |
353 | ######## |
354 | sub foo { local $_ = shift; split; @_ } | |
355 | @x = foo(' x y z '); | |
356 | print "you die joe!\n" unless "@x" eq 'x y z'; | |
c277df42 IZ |
357 | ######## |
358 | /(?{"{"})/ # Check it outside of eval too | |
359 | EXPECT | |
2cd61cdb | 360 | Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern |
79eeca27 | 361 | Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. |
c277df42 IZ |
362 | ######## |
363 | /(?{"{"}})/ # Check it outside of eval too | |
364 | EXPECT | |
d98d5fff | 365 | Unmatched right curly bracket at (re_eval 1) line 1, at end of line |
c277df42 | 366 | syntax error at (re_eval 1) line 1, near ""{"}" |
2cd61cdb | 367 | Compilation failed in regexp at - line 1. |
0da4822f | 368 | ######## |
ff689196 | 369 | BEGIN { @ARGV = qw(a b c d e) } |
0da4822f GS |
370 | BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } |
371 | END { print "end <",shift,">\nargv <@ARGV>\n" } | |
372 | INIT { print "init <",shift,">\n" } | |
7d30b5c4 | 373 | CHECK { print "check <",shift,">\n" } |
0da4822f | 374 | EXPECT |
ff689196 | 375 | argv <a b c d e> |
0da4822f | 376 | begin <a> |
7d30b5c4 | 377 | check <b> |
ff689196 GS |
378 | init <c> |
379 | end <d> | |
380 | argv <e> | |
4599a1de | 381 | ######## |
3500f679 RS |
382 | -l |
383 | # fdopen from a system descriptor to a system descriptor used to close | |
384 | # the former. | |
385 | open STDERR, '>&=STDOUT' or die $!; | |
75642110 NC |
386 | select STDOUT; $| = 1; print fileno STDOUT or die $!; |
387 | select STDERR; $| = 1; print fileno STDERR or die $!; | |
3500f679 RS |
388 | EXPECT |
389 | 1 | |
390 | 2 | |
391 | ######## | |
20408e3c GS |
392 | -w |
393 | sub testme { my $a = "test"; { local $a = "new test"; print $a }} | |
394 | EXPECT | |
395 | Can't localize lexical variable $a at - line 2. | |
396 | ######## | |
51ae5c03 JPC |
397 | package X; |
398 | sub ascalar { my $r; bless \$r } | |
399 | sub DESTROY { print "destroyed\n" }; | |
400 | package main; | |
401 | *s = ascalar X; | |
402 | EXPECT | |
403 | destroyed | |
404 | ######## | |
405 | package X; | |
406 | sub anarray { bless [] } | |
407 | sub DESTROY { print "destroyed\n" }; | |
408 | package main; | |
409 | *a = anarray X; | |
410 | EXPECT | |
411 | destroyed | |
412 | ######## | |
413 | package X; | |
414 | sub ahash { bless {} } | |
415 | sub DESTROY { print "destroyed\n" }; | |
416 | package main; | |
417 | *h = ahash X; | |
418 | EXPECT | |
419 | destroyed | |
420 | ######## | |
421 | package X; | |
422 | sub aclosure { my $x; bless sub { ++$x } } | |
423 | sub DESTROY { print "destroyed\n" }; | |
424 | package main; | |
425 | *c = aclosure X; | |
426 | EXPECT | |
427 | destroyed | |
428 | ######## | |
429 | package X; | |
430 | sub any { bless {} } | |
431 | my $f = "FH000"; # just to thwart any future optimisations | |
ded8aa31 | 432 | sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } |
51ae5c03 JPC |
433 | sub DESTROY { print "destroyed\n" } |
434 | package main; | |
435 | $x = any X; # to bump sv_objcount. IO objs aren't counted?? | |
436 | *f = afh X; | |
437 | EXPECT | |
438 | destroyed | |
439 | destroyed | |
440 | ######## | |
ebf99b04 GS |
441 | BEGIN { |
442 | $| = 1; | |
443 | $SIG{__WARN__} = sub { | |
444 | eval { print $_[0] }; | |
445 | die "bar\n"; | |
446 | }; | |
447 | warn "foo\n"; | |
448 | } | |
449 | EXPECT | |
450 | foo | |
451 | bar | |
452 | BEGIN failed--compilation aborted at - line 8. | |
8feb4e9f JH |
453 | ######## |
454 | package X; | |
455 | @ISA='Y'; | |
456 | sub new { | |
457 | my $class = shift; | |
458 | my $self = { }; | |
459 | bless $self, $class; | |
460 | my $init = shift; | |
461 | $self->foo($init); | |
462 | print "new", $init; | |
463 | return $self; | |
464 | } | |
465 | sub DESTROY { | |
466 | my $self = shift; | |
467 | print "DESTROY", $self->foo; | |
468 | } | |
469 | package Y; | |
470 | sub attribute { | |
471 | my $self = shift; | |
472 | my $var = shift; | |
473 | if (@_ == 0) { | |
474 | return $self->{$var}; | |
475 | } elsif (@_ == 1) { | |
476 | $self->{$var} = shift; | |
477 | } | |
478 | } | |
479 | sub AUTOLOAD { | |
480 | $AUTOLOAD =~ /::([^:]+)$/; | |
481 | my $method = $1; | |
482 | splice @_, 1, 0, $method; | |
483 | goto &attribute; | |
484 | } | |
485 | package main; | |
486 | my $x = X->new(1); | |
487 | for (2..3) { | |
488 | my $y = X->new($_); | |
489 | print $y->foo; | |
490 | } | |
491 | print $x->foo; | |
492 | EXPECT | |
493 | new1new22DESTROY2new33DESTROY31DESTROY1 | |
dfad63ad HS |
494 | ######## |
495 | re(); | |
496 | sub re { | |
14455d6c | 497 | my $re = join '', eval 'qr/(??{ $obj->method })/'; |
dfad63ad HS |
498 | $re; |
499 | } | |
500 | EXPECT | |
1aff0e91 GS |
501 | ######## |
502 | use strict; | |
503 | my $foo = "ZZZ\n"; | |
504 | END { print $foo } | |
505 | EXPECT | |
506 | ZZZ | |
507 | ######## | |
508 | eval ' | |
509 | use strict; | |
510 | my $foo = "ZZZ\n"; | |
511 | END { print $foo } | |
512 | '; | |
513 | EXPECT | |
514 | ZZZ | |
7399586d HS |
515 | ######## |
516 | -w | |
517 | if (@ARGV) { print "" } | |
518 | else { | |
519 | if ($x == 0) { print "" } else { print $x } | |
520 | } | |
521 | EXPECT | |
b89fed5f | 522 | Use of uninitialized value in numeric eq (==) at - line 4. |
1d76a5c3 GS |
523 | ######## |
524 | $x = sub {}; | |
525 | foo(); | |
526 | sub foo { eval { return }; } | |
527 | print "ok\n"; | |
528 | EXPECT | |
529 | ok | |
07447971 GS |
530 | ######## |
531 | my @l = qw(hello.* world); | |
532 | my $x; | |
533 | ||
534 | foreach $x (@l) { | |
535 | print "before - $x\n"; | |
536 | $x = "\Q$x\E"; | |
537 | print "quotemeta - $x\n"; | |
538 | $x = "\u$x"; | |
539 | print "ucfirst - $x\n"; | |
540 | $x = "\l$x"; | |
541 | print "lcfirst - $x\n"; | |
542 | $x = "\U$x\E"; | |
543 | print "uc - $x\n"; | |
544 | $x = "\L$x\E"; | |
545 | print "lc - $x\n"; | |
546 | } | |
547 | EXPECT | |
548 | before - hello.* | |
549 | quotemeta - hello\.\* | |
550 | ucfirst - Hello\.\* | |
551 | lcfirst - hello\.\* | |
552 | uc - HELLO\.\* | |
553 | lc - hello\.\* | |
554 | before - world | |
555 | quotemeta - world | |
556 | ucfirst - World | |
557 | lcfirst - world | |
558 | uc - WORLD | |
559 | lc - world | |
92d29cee JH |
560 | ######## |
561 | sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } | |
562 | my $x = "foo"; | |
563 | { f } continue { print $x, "\n" } | |
564 | EXPECT | |
565 | foo | |
6a7129a1 GS |
566 | ######## |
567 | sub C () { 1 } | |
568 | sub M { $_[0] = 2; } | |
569 | eval "C"; | |
570 | M(C); | |
571 | EXPECT | |
572 | Modification of a read-only value attempted at - line 2. | |
00c29ff8 TH |
573 | ######## |
574 | print qw(ab a\b a\\b); | |
575 | EXPECT | |
576 | aba\ba\b | |
dd8482fc JH |
577 | ######## |
578 | # This test is here instead of pragma/locale.t because | |
579 | # the bug depends on in the internal state of the locale | |
580 | # settings and pragma/locale messes up that state pretty badly. | |
581 | # We need a "fresh run". | |
c9f931b8 JH |
582 | BEGIN { |
583 | eval { require POSIX }; | |
584 | if ($@) { | |
585 | exit(0); # running minitest? | |
586 | } | |
587 | } | |
dd8482fc JH |
588 | use Config; |
589 | my $have_setlocale = $Config{d_setlocale} eq 'define'; | |
dd8482fc JH |
590 | $have_setlocale = 0 if $@; |
591 | # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" | |
592 | # and mingw32 uses said silly CRT | |
593 | $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; | |
594 | exit(0) unless $have_setlocale; | |
595 | my @locales; | |
596 | if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { | |
597 | while(<LOCALES>) { | |
598 | chomp; | |
599 | push(@locales, $_); | |
600 | } | |
601 | close(LOCALES); | |
602 | } | |
603 | exit(0) unless @locales; | |
604 | for (@locales) { | |
605 | use POSIX qw(locale_h); | |
606 | use locale; | |
88e7acd2 | 607 | setlocale(LC_NUMERIC, $_) or next; |
dd8482fc JH |
608 | my $s = sprintf "%g %g", 3.1, 3.1; |
609 | next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; | |
610 | print "$_ $s\n"; | |
611 | } | |
612 | EXPECT | |
b927783e JH |
613 | ######## |
614 | die qr(x) | |
615 | EXPECT | |
616 | (?-xism:x) at - line 1. | |
617 | ######## | |
7ef822cd JH |
618 | # 20001210.003 mjd@plover.com |
619 | format REMITOUT_TOP = | |
620 | FOO | |
621 | . | |
622 | ||
623 | format REMITOUT = | |
624 | BAR | |
625 | . | |
626 | ||
627 | # This loop causes a segv in 5.6.0 | |
628 | for $lineno (1..61) { | |
629 | write REMITOUT; | |
630 | } | |
631 | ||
632 | print "It's OK!"; | |
633 | EXPECT | |
634 | It's OK! | |
cb55de95 JH |
635 | ######## |
636 | # Inaba Hiroto | |
637 | reset; | |
638 | if (0) { | |
639 | if ("" =~ //) { | |
640 | } | |
641 | } | |
642 | ######## | |
643 | # Nicholas Clark | |
644 | $ENV{TERM} = 0; | |
645 | reset; | |
646 | // if 0; | |
647 | ######## | |
648 | # Vadim Konovalov | |
649 | use strict; | |
650 | sub new_pmop($) { | |
651 | my $pm = shift; | |
652 | return eval "sub {shift=~/$pm/}"; | |
653 | } | |
654 | new_pmop "abcdef"; reset; | |
655 | new_pmop "abcdef"; reset; | |
656 | new_pmop "abcdef"; reset; | |
657 | new_pmop "abcdef"; reset; | |
658 |