| 1 | #!./perl |
| 2 | |
| 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 | |
| 6 | chdir 't' if -d 't'; |
| 7 | @INC = '../lib'; |
| 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; |
| 18 | END { while($tmpfile && unlink $tmpfile){} } |
| 19 | |
| 20 | $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); |
| 21 | |
| 22 | for (@prgs){ |
| 23 | my $switch; |
| 24 | if (s/^\s*(-\w.*)//){ |
| 25 | $switch = $1; |
| 26 | } |
| 27 | my($prog,$expected) = split(/\nEXPECT\n/, $_); |
| 28 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
| 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 | |
| 32 | print TEST $prog, "\n"; |
| 33 | close TEST or die "Cannot close $tmpfile: $!"; |
| 34 | |
| 35 | if ($^O eq 'MSWin32') { |
| 36 | $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; |
| 37 | } |
| 38 | else { |
| 39 | $results = `./perl $switch $tmpfile 2>&1`; |
| 40 | } |
| 41 | $status = $?; |
| 42 | $results =~ s/\n+$//; |
| 43 | $results =~ s/at\s+misctmp\d+\s+line/at - line/g; |
| 44 | $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; |
| 45 | # bison says 'parse error' instead of 'syntax error', |
| 46 | # various yaccs may or may not capitalize 'syntax'. |
| 47 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
| 48 | $expected =~ s/\n+$//; |
| 49 | if ( $results ne $expected ) { |
| 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__ |
| 59 | ()=() |
| 60 | ######## |
| 61 | $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" |
| 62 | EXPECT |
| 63 | a := b := c |
| 64 | ######## |
| 65 | $cusp = ~0 ^ (~0 >> 1); |
| 66 | use integer; |
| 67 | $, = " "; |
| 68 | print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; |
| 69 | EXPECT |
| 70 | 7 0 0 8 ! |
| 71 | ######## |
| 72 | $foo=undef; $foo->go; |
| 73 | EXPECT |
| 74 | Can't call method "go" on an undefined value at - line 1. |
| 75 | ######## |
| 76 | BEGIN |
| 77 | { |
| 78 | "foo"; |
| 79 | } |
| 80 | ######## |
| 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 | ######## |
| 87 | chop ($str .= <DATA>); |
| 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 | ######## |
| 97 | system './perl -ne "print if eof" /dev/null' |
| 98 | ######## |
| 99 | chop($file = <DATA>); |
| 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 |
| 111 | Can't modify hash dereference in repeat (x) at - line 1, near "0;" |
| 112 | Execution of - aborted due to compilation errors. |
| 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. |
| 205 | ######## |
| 206 | { |
| 207 | package foo; |
| 208 | sub PRINT { |
| 209 | shift; |
| 210 | print join(' ', reverse @_)."\n"; |
| 211 | } |
| 212 | sub PRINTF { |
| 213 | shift; |
| 214 | my $fmt = shift; |
| 215 | print sprintf($fmt, @_)."\n"; |
| 216 | } |
| 217 | sub TIEHANDLE { |
| 218 | bless {}, shift; |
| 219 | } |
| 220 | sub READLINE { |
| 221 | "Out of inspiration"; |
| 222 | } |
| 223 | sub DESTROY { |
| 224 | print "and destroyed as well\n"; |
| 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 | } |
| 236 | } |
| 237 | { |
| 238 | local(*FOO); |
| 239 | tie(*FOO,'foo'); |
| 240 | print FOO "sentence.", "reversed", "a", "is", "This"; |
| 241 | print "-- ", <FOO>, " --\n"; |
| 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"; |
| 247 | printf "%s is number %d\n", "Perl", 1; |
| 248 | } |
| 249 | EXPECT |
| 250 | This is a reversed sentence. |
| 251 | -- Out of inspiration -- |
| 252 | foo->can(READ)(string 10 1) |
| 253 | Don't GETC, Get Perl |
| 254 | Perl is number 1 |
| 255 | and destroyed as well |
| 256 | ######## |
| 257 | my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" |
| 258 | EXPECT |
| 259 | 2 2 2 |
| 260 | ######## |
| 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 | ######## |
| 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 | ######## |
| 280 | print "ok\n" if ("\0" lt "\xFF"); |
| 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 | ######## |
| 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 | ######## |
| 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 |
| 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); |
| 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'; |
| 357 | ######## |
| 358 | /(?{"{"})/ # Check it outside of eval too |
| 359 | EXPECT |
| 360 | Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern |
| 361 | Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. |
| 362 | ######## |
| 363 | /(?{"{"}})/ # Check it outside of eval too |
| 364 | EXPECT |
| 365 | Unmatched right curly bracket at (re_eval 1) line 1, at end of line |
| 366 | syntax error at (re_eval 1) line 1, near ""{"}" |
| 367 | Compilation failed in regexp at - line 1. |
| 368 | ######## |
| 369 | BEGIN { @ARGV = qw(a b c d e) } |
| 370 | BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } |
| 371 | END { print "end <",shift,">\nargv <@ARGV>\n" } |
| 372 | INIT { print "init <",shift,">\n" } |
| 373 | CHECK { print "check <",shift,">\n" } |
| 374 | EXPECT |
| 375 | argv <a b c d e> |
| 376 | begin <a> |
| 377 | check <b> |
| 378 | init <c> |
| 379 | end <d> |
| 380 | argv <e> |
| 381 | ######## |
| 382 | -l |
| 383 | # fdopen from a system descriptor to a system descriptor used to close |
| 384 | # the former. |
| 385 | open STDERR, '>&=STDOUT' or die $!; |
| 386 | select STDOUT; $| = 1; print fileno STDOUT or die $!; |
| 387 | select STDERR; $| = 1; print fileno STDERR or die $!; |
| 388 | EXPECT |
| 389 | 1 |
| 390 | 2 |
| 391 | ######## |
| 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 | ######## |
| 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 |
| 432 | sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } |
| 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 | ######## |
| 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. |
| 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 |
| 494 | ######## |
| 495 | re(); |
| 496 | sub re { |
| 497 | my $re = join '', eval 'qr/(??{ $obj->method })/'; |
| 498 | $re; |
| 499 | } |
| 500 | EXPECT |
| 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 |
| 515 | ######## |
| 516 | -w |
| 517 | if (@ARGV) { print "" } |
| 518 | else { |
| 519 | if ($x == 0) { print "" } else { print $x } |
| 520 | } |
| 521 | EXPECT |
| 522 | Use of uninitialized value in numeric eq (==) at - line 4. |
| 523 | ######## |
| 524 | $x = sub {}; |
| 525 | foo(); |
| 526 | sub foo { eval { return }; } |
| 527 | print "ok\n"; |
| 528 | EXPECT |
| 529 | ok |
| 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 |
| 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 |
| 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. |
| 573 | ######## |
| 574 | print qw(ab a\b a\\b); |
| 575 | EXPECT |
| 576 | aba\ba\b |
| 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". |
| 582 | BEGIN { |
| 583 | eval { require POSIX }; |
| 584 | if ($@) { |
| 585 | exit(0); # running minitest? |
| 586 | } |
| 587 | } |
| 588 | use Config; |
| 589 | my $have_setlocale = $Config{d_setlocale} eq 'define'; |
| 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; |
| 607 | setlocale(LC_NUMERIC, $_) or next; |
| 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 |
| 613 | ######## |
| 614 | die qr(x) |
| 615 | EXPECT |
| 616 | (?-xism:x) at - line 1. |
| 617 | ######## |
| 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! |
| 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 | |