t/run/fresh_perl.t

   1 #!./perl
   2
   3 # ** DO NOT ADD ANY MORE TESTS HERE **
   4 # Instead, put the test in the appropriate test file and use the
   5 # fresh_perl_is()/fresh_perl_like() functions in t/test.pl.
   6
   7 # This is for tests that will normally cause segfaults, and other nasty
   8 # errors that might kill the interpreter and for some reason you can't
   9 # use an eval().
  10 #
  11 # New tests are added to the bottom.  For example.
  12 #
  13 #       ######## perlbug ID 20020831.001
  14 #       ($a, b) = (1,2)
  15 #       EXPECT
  16 #       Can't modify constant item in list assignment - at line 1
  17 #
  18 # to test that the code "($a, b) = (1,2)" causes the appropriate syntax
  19 # error, rather than just segfaulting as reported in perlbug ID
  20 # 20020831.001
  21
  22 BEGIN {
  23     chdir 't' if -d 't';
  24     @INC = '../lib';
  25     require './test.pl';        # for which_perl() etc
  26 }
  27
  28 use strict;
  29
  30 my $Perl = which_perl();
  31
  32 $|=1;
  33
  34 my @prgs = ();
  35 while(<DATA>) {
  36     if(m/^#{8,}\s*(.*)/) {
  37         push @prgs, ['', $1];
  38     }
  39     else {
  40         $prgs[-1][0] .= $_;
  41     }
  42 }
  43 plan tests => scalar @prgs;
  44
  45 foreach my $prog (@prgs) {
  46     my($raw_prog, $name) = @$prog;
  47
  48     my $switch;
  49     if ($raw_prog =~ s/^\s*(-\w.*)//){
  50         $switch = $1;
  51     }
  52
  53     my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
  54
  55     if ($prog =~ /^\# SKIP: (.+)/m) {
  56         if (eval $1) {
  57             ok(1, "Skip: $1");
  58             next;
  59         }
  60     }
  61
  62     $expected =~ s/\n+$//;
  63
  64     fresh_perl_is($prog, $expected, { switches => [$switch] }, $name);
  65 }
  66
  67 __END__
  68 ########
  69 $a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
  70 EXPECT
  71 a := b := c
  72 ########
  73 $cusp = ~0 ^ (~0 >> 1);
  74 use integer;
  75 $, = " ";
  76 print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
  77 EXPECT
  78 7 0 0 8 !
  79 ########
  80 $foo=undef; $foo->go;
  81 EXPECT
  82 Can't call method "go" on an undefined value at - line 1.
  83 ########
  84 BEGIN
  85         {
  86             "foo";
  87         }
  88 ########
  89 $array[128]=1
  90 ########
  91 $x=0x0eabcd; print $x->ref;
  92 EXPECT
  93 Can't call method "ref" without a package or object reference at - line 1.
  94 ########
  95 chop ($str .= <DATA>);
  96 ########
  97 close ($banana);
  98 ########
  99 $x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
 100 EXPECT
 101 25
 102 ########
 103 eval {sub bar {print "In bar";}}
 104 ########
 105 system './perl -ne "print if eof" /dev/null' unless $^O eq 'MacOS'
 106 ########
 107 chop($file = <DATA>);
 108 ########
 109 package N;
 110 sub new {my ($obj,$n)=@_; bless \$n}
 111 $aa=new N 1;
 112 $aa=12345;
 113 print $aa;
 114 EXPECT
 115 12345
 116 ########
 117 %@x=0;
 118 EXPECT
 119 Can't modify hash dereference in repeat (x) at - line 1, near "0;"
 120 Execution of - aborted due to compilation errors.
 121 ########
 122 $_="foo";
 123 printf(STDOUT "%s\n", $_);
 124 EXPECT
 125 foo
 126 ########
 127 push(@a, 1, 2, 3,)
 128 ########
 129 quotemeta ""
 130 ########
 131 for ("ABCDE") {
 132  &sub;
 133 s/./&sub($&)/eg;
 134 print;}
 135 sub sub {local($_) = @_;
 136 $_ x 4;}
 137 EXPECT
 138 Modification of a read-only value attempted at - line 3.
 139 ########
 140 package FOO;sub new {bless {FOO => BAR}};
 141 package main;
 142 use strict vars;
 143 my $self = new FOO;
 144 print $$self{FOO};
 145 EXPECT
 146 BAR
 147 ########
 148 $_="foo";
 149 s/.{1}//s;
 150 print;
 151 EXPECT
 152 oo
 153 ########
 154 print scalar ("foo","bar")
 155 EXPECT
 156 bar
 157 ########
 158 sub by_number { $a <=> $b; };# inline function for sort below
 159 $as_ary{0}="a0";
 160 @ordered_array=sort by_number keys(%as_ary);
 161 ########
 162 sub NewShell
 163 {
 164   local($Host) = @_;
 165   my($m2) = $#Shells++;
 166   $Shells[$m2]{HOST} = $Host;
 167   return $m2;
 168 }
 169
 170 sub ShowShell
 171 {
 172   local($i) = @_;
 173 }
 174
 175 &ShowShell(&NewShell(beach,Work,"+0+0"));
 176 &ShowShell(&NewShell(beach,Work,"+0+0"));
 177 &ShowShell(&NewShell(beach,Work,"+0+0"));
 178 ########
 179    {
 180        package FAKEARRAY;
 181
 182        sub TIEARRAY
 183        { print "TIEARRAY @_\n";
 184          die "bomb out\n" unless $count ++ ;
 185          bless ['foo']
 186        }
 187        sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
 188        sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
 189        sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
 190    }
 191
 192 eval 'tie @h, FAKEARRAY, fred' ;
 193 tie @h, FAKEARRAY, fred ;
 194 EXPECT
 195 TIEARRAY FAKEARRAY fred
 196 TIEARRAY FAKEARRAY fred
 197 DESTROY
 198 ########
 199 BEGIN { die "phooey\n" }
 200 EXPECT
 201 phooey
 202 BEGIN failed--compilation aborted at - line 1.
 203 ########
 204 BEGIN { 1/$zero }
 205 EXPECT
 206 Illegal division by zero at - line 1.
 207 BEGIN failed--compilation aborted at - line 1.
 208 ########
 209 BEGIN { undef = 0 }
 210 EXPECT
 211 Modification of a read-only value attempted at - line 1.
 212 BEGIN failed--compilation aborted at - line 1.
 213 ########
 214 {
 215     package foo;
 216     sub PRINT {
 217         shift;
 218         print join(' ', reverse @_)."\n";
 219     }
 220     sub PRINTF {
 221         shift;
 222           my $fmt = shift;
 223         print sprintf($fmt, @_)."\n";
 224     }
 225     sub TIEHANDLE {
 226         bless {}, shift;
 227     }
 228     sub READLINE {
 229         "Out of inspiration";
 230     }
 231     sub DESTROY {
 232         print "and destroyed as well\n";
 233   }
 234   sub READ {
 235       shift;
 236       print STDOUT "foo->can(READ)(@_)\n";
 237       return 100;
 238   }
 239   sub GETC {
 240       shift;
 241       print STDOUT "Don't GETC, Get Perl\n";
 242       return "a";
 243   }
 244 }
 245 {
 246     local(*FOO);
 247     tie(*FOO,'foo');
 248     print FOO "sentence.", "reversed", "a", "is", "This";
 249     print "-- ", <FOO>, " --\n";
 250     my($buf,$len,$offset);
 251     $buf = "string";
 252     $len = 10; $offset = 1;
 253     read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
 254     getc(FOO) eq "a" or die "foo->GETC failed";
 255     printf "%s is number %d\n", "Perl", 1;
 256 }
 257 EXPECT
 258 This is a reversed sentence.
 259 -- Out of inspiration --
 260 foo->can(READ)(string 10 1)
 261 Don't GETC, Get Perl
 262 Perl is number 1
 263 and destroyed as well
 264 ########
 265 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
 266 EXPECT
 267 2 2 2
 268 ########
 269 # used to attach defelem magic to all immortal values,
 270 # which made restore of local $_ fail.
 271 foo(2>1);
 272 sub foo { bar() for @_;  }
 273 sub bar { local $_; }
 274 print "ok\n";
 275 EXPECT
 276 ok
 277 ########
 278 @a = ($a, $b, $c, $d) = (5, 6);
 279 print "ok\n"
 280   if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
 281 EXPECT
 282 ok
 283 ########
 284 print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
 285 EXPECT
 286 ok
 287 ########
 288 print "ok\n" if ("\0" lt "\xFF");
 289 EXPECT
 290 ok
 291 ########
 292 open(H,$^O eq 'MacOS' ? ':run:fresh_perl.t' : 'run/fresh_perl.t'); # must be in the 't' directory
 293 stat(H);
 294 print "ok\n" if (-e _ and -f _ and -r _);
 295 EXPECT
 296 ok
 297 ########
 298 sub thing { 0 || return qw(now is the time) }
 299 print thing(), "\n";
 300 EXPECT
 301 nowisthetime
 302 ########
 303 $ren = 'joy';
 304 $stimpy = 'happy';
 305 { local $main::{ren} = *stimpy; print $ren, ' ' }
 306 print $ren, "\n";
 307 EXPECT
 308 happy joy
 309 ########
 310 $stimpy = 'happy';
 311 { local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
 312 print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
 313 EXPECT
 314 happy joy
 315 ########
 316 package p;
 317 sub func { print 'really ' unless wantarray; 'p' }
 318 sub groovy { 'groovy' }
 319 package main;
 320 print p::func()->groovy(), "\n"
 321 EXPECT
 322 really groovy
 323 ########
 324 @list = ([ 'one', 1 ], [ 'two', 2 ]);
 325 sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
 326 print scalar(map &func($_), 1 .. 3), " ",
 327       scalar(map scalar &func($_), 1 .. 3), "\n";
 328 EXPECT
 329 2 3
 330 ########
 331 ($k, $s)  = qw(x 0);
 332 @{$h{$k}} = qw(1 2 4);
 333 for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
 334 print "bogus\n" unless $s == 7;
 335 ########
 336 my $a = 'outer';
 337 eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
 338 eval { my $x = 'peace'; eval q[ print "$x\n" ] }
 339 EXPECT
 340 inner peace
 341 ########
 342 -w
 343 $| = 1;
 344 sub foo {
 345     print "In foo1\n";
 346     eval 'sub foo { print "In foo2\n" }';
 347     print "Exiting foo1\n";
 348 }
 349 foo;
 350 foo;
 351 EXPECT
 352 In foo1
 353 Subroutine foo redefined at (eval 1) line 1.
 354 Exiting foo1
 355 In foo2
 356 ########
 357 $s = 0;
 358 map {#this newline here tickles the bug
 359 $s += $_} (1,2,4);
 360 print "eat flaming death\n" unless ($s == 7);
 361 ########
 362 sub foo { local $_ = shift; split; @_ }
 363 @x = foo(' x  y  z ');
 364 print "you die joe!\n" unless "@x" eq 'x y z';
 365 ########
 366 /(?{"{"})/      # Check it outside of eval too
 367 EXPECT
 368 Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
 369 Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
 370 ########
 371 /(?{"{"}})/     # Check it outside of eval too
 372 EXPECT
 373 Unmatched right curly bracket at (re_eval 1) line 1, at end of line
 374 syntax error at (re_eval 1) line 1, near ""{"}"
 375 Compilation failed in regexp at - line 1.
 376 ########
 377 BEGIN { @ARGV = qw(a b c d e) }
 378 BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
 379 END { print "end <",shift,">\nargv <@ARGV>\n" }
 380 INIT { print "init <",shift,">\n" }
 381 CHECK { print "check <",shift,">\n" }
 382 EXPECT
 383 argv <a b c d e>
 384 begin <a>
 385 check <b>
 386 init <c>
 387 end <d>
 388 argv <e>
 389 ########
 390 -l
 391 # fdopen from a system descriptor to a system descriptor used to close
 392 # the former.
 393 open STDERR, '>&=STDOUT' or die $!;
 394 select STDOUT; $| = 1; print fileno STDOUT or die $!;
 395 select STDERR; $| = 1; print fileno STDERR or die $!;
 396 EXPECT
 397 1
 398 2
 399 ########
 400 -w
 401 sub testme { my $a = "test"; { local $a = "new test"; print $a }}
 402 EXPECT
 403 Can't localize lexical variable $a at - line 2.
 404 ########
 405 package X;
 406 sub ascalar { my $r; bless \$r }
 407 sub DESTROY { print "destroyed\n" };
 408 package main;
 409 *s = ascalar X;
 410 EXPECT
 411 destroyed
 412 ########
 413 package X;
 414 sub anarray { bless [] }
 415 sub DESTROY { print "destroyed\n" };
 416 package main;
 417 *a = anarray X;
 418 EXPECT
 419 destroyed
 420 ########
 421 package X;
 422 sub ahash { bless {} }
 423 sub DESTROY { print "destroyed\n" };
 424 package main;
 425 *h = ahash X;
 426 EXPECT
 427 destroyed
 428 ########
 429 package X;
 430 sub aclosure { my $x; bless sub { ++$x } }
 431 sub DESTROY { print "destroyed\n" };
 432 package main;
 433 *c = aclosure X;
 434 EXPECT
 435 destroyed
 436 ########
 437 package X;
 438 sub any { bless {} }
 439 my $f = "FH000"; # just to thwart any future optimisations
 440 sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
 441 sub DESTROY { print "destroyed\n" }
 442 package main;
 443 $x = any X; # to bump sv_objcount. IO objs aren't counted??
 444 *f = afh X;
 445 EXPECT
 446 destroyed
 447 destroyed
 448 ########
 449 BEGIN {
 450   $| = 1;
 451   $SIG{__WARN__} = sub {
 452     eval { print $_[0] };
 453     die "bar\n";
 454   };
 455   warn "foo\n";
 456 }
 457 EXPECT
 458 foo
 459 bar
 460 BEGIN failed--compilation aborted at - line 8.
 461 ########
 462 package X;
 463 @ISA='Y';
 464 sub new {
 465     my $class = shift;
 466     my $self = { };
 467     bless $self, $class;
 468     my $init = shift;
 469     $self->foo($init);
 470     print "new", $init;
 471     return $self;
 472 }
 473 sub DESTROY {
 474     my $self = shift;
 475     print "DESTROY", $self->foo;
 476 }
 477 package Y;
 478 sub attribute {
 479     my $self = shift;
 480     my $var = shift;
 481     if (@_ == 0) {
 482         return $self->{$var};
 483     } elsif (@_ == 1) {
 484         $self->{$var} = shift;
 485     }
 486 }
 487 sub AUTOLOAD {
 488     $AUTOLOAD =~ /::([^:]+)$/;
 489     my $method = $1;
 490     splice @_, 1, 0, $method;
 491     goto &attribute;
 492 }
 493 package main;
 494 my $x = X->new(1);
 495 for (2..3) {
 496     my $y = X->new($_);
 497     print $y->foo;
 498 }
 499 print $x->foo;
 500 EXPECT
 501 new1new22DESTROY2new33DESTROY31DESTROY1
 502 ########
 503 re();
 504 sub re {
 505     my $re = join '', eval 'qr/(??{ $obj->method })/';
 506     $re;
 507 }
 508 EXPECT
 509 ########
 510 use strict;
 511 my $foo = "ZZZ\n";
 512 END { print $foo }
 513 EXPECT
 514 ZZZ
 515 ########
 516 eval '
 517 use strict;
 518 my $foo = "ZZZ\n";
 519 END { print $foo }
 520 ';
 521 EXPECT
 522 ZZZ
 523 ########
 524 -w
 525 if (@ARGV) { print "" }
 526 else {
 527   if ($x == 0) { print "" } else { print $x }
 528 }
 529 EXPECT
 530 Use of uninitialized value in numeric eq (==) at - line 4.
 531 ########
 532 $x = sub {};
 533 foo();
 534 sub foo { eval { return }; }
 535 print "ok\n";
 536 EXPECT
 537 ok
 538 ########
 539 # moved to op/lc.t
 540 EXPECT
 541 ########
 542 sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
 543 my $x = "foo";
 544 { f } continue { print $x, "\n" }
 545 EXPECT
 546 foo
 547 ########
 548 sub C () { 1 }
 549 sub M { $_[0] = 2; }
 550 eval "C";
 551 M(C);
 552 EXPECT
 553 Modification of a read-only value attempted at - line 2.
 554 ########
 555 print qw(ab a\b a\\b);
 556 EXPECT
 557 aba\ba\b
 558 ########
 559 # lexicals declared after the myeval() definition should not be visible
 560 # within it
 561 sub myeval { eval $_[0] }
 562 my $foo = "ok 2\n";
 563 myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
 564 die $@ if $@;
 565 foo();
 566 print $foo;
 567 EXPECT
 568 ok 1
 569 ok 2
 570 ########
 571 # lexicals outside an eval"" should be visible inside subroutine definitions
 572 # within it
 573 eval <<'EOT'; die $@ if $@;
 574 {
 575     my $X = "ok\n";
 576     eval 'sub Y { print $X }'; die $@ if $@;
 577     Y();
 578 }
 579 EOT
 580 EXPECT
 581 ok
 582 ########
 583 # This test is here instead of lib/locale.t because
 584 # the bug depends on in the internal state of the locale
 585 # settings and pragma/locale messes up that state pretty badly.
 586 # We need a "fresh run".
 587 BEGIN {
 588     eval { require POSIX };
 589     if ($@) {
 590         exit(0); # running minitest?
 591     }
 592 }
 593 use Config;
 594 my $have_setlocale = $Config{d_setlocale} eq 'define';
 595 $have_setlocale = 0 if $@;
 596 # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
 597 # and mingw32 uses said silly CRT
 598 $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
 599 exit(0) unless $have_setlocale;
 600 my @locales;
 601 if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
 602     while(<LOCALES>) {
 603         chomp;
 604         push(@locales, $_);
 605     }
 606     close(LOCALES);
 607 }
 608 exit(0) unless @locales;
 609 for (@locales) {
 610     use POSIX qw(locale_h);
 611     use locale;
 612     setlocale(LC_NUMERIC, $_) or next;
 613     my $s = sprintf "%g %g", 3.1, 3.1;
 614     next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
 615     print "$_ $s\n";
 616 }
 617 EXPECT
 618 ########
 619 die qr(x)
 620 EXPECT
 621 (?-xism:x) at - line 1.
 622 ########
 623 # 20001210.003 mjd@plover.com
 624 format REMITOUT_TOP =
 625 FOO
 626 .
 627
 628 format REMITOUT =
 629 BAR
 630 .
 631
 632 # This loop causes a segv in 5.6.0
 633 for $lineno (1..61) {
 634    write REMITOUT;
 635 }
 636
 637 print "It's OK!";
 638 EXPECT
 639 It's OK!
 640 ########
 641 # Inaba Hiroto
 642 reset;
 643 if (0) {
 644   if ("" =~ //) {
 645   }
 646 }
 647 ########
 648 # Nicholas Clark
 649 $ENV{TERM} = 0;
 650 reset;
 651 // if 0;
 652 ########
 653 # Vadim Konovalov
 654 use strict;
 655 sub new_pmop($) {
 656     my $pm = shift;
 657     return eval "sub {shift=~/$pm/}";
 658 }
 659 new_pmop "abcdef"; reset;
 660 new_pmop "abcdef"; reset;
 661 new_pmop "abcdef"; reset;
 662 new_pmop "abcdef"; reset;
 663 ########
 664 # David Dyck
 665 # coredump in 5.7.1
 666 close STDERR; die;
 667 EXPECT
 668 ########
 669 -w
 670 "x" =~ /(\G?x)?/;       # core dump in 20000716.007
 671 ########
 672 # Bug 20010515.004
 673 my @h = 1 .. 10;
 674 bad(@h);
 675 sub bad {
 676    undef @h;
 677    print "O";
 678    print for @_;
 679    print "K";
 680 }
 681 EXPECT
 682 OK
 683 ########
 684 # Bug 20010506.041
 685 "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
 686 EXPECT
 687 ok
 688 ########
 689 # Bug 20010422.005
 690 {s//${}/; //}
 691 EXPECT
 692 syntax error at - line 2, near "${}"
 693 Execution of - aborted due to compilation errors.
 694 ########
 695 # Bug 20010528.007
 696 "\x{"
 697 EXPECT
 698 Missing right brace on \x{} at - line 2, within string
 699 Execution of - aborted due to compilation errors.
 700 ########
 701 my $foo = Bar->new();
 702 my @dst;
 703 END {
 704     ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
 705     print $_, "\n";
 706 }
 707 package Bar;
 708 sub new {
 709     my Bar $self = bless [], Bar;
 710     eval '$self';
 711     return $self;
 712 }
 713 sub DESTROY {
 714     push @dst, "$_[0]";
 715 }
 716 EXPECT
 717 Bar=ARRAY(0x...)
 718 ########
 719 ######## found by Markov chain stress testing
 720 eval "a.b.c.d.e.f;sub"
 721 EXPECT
 722
 723 ######## perlbug ID 20010831.001
 724 ($a, b) = (1, 2);
 725 EXPECT
 726 Can't modify constant item in list assignment at - line 1, near ");"
 727 Execution of - aborted due to compilation errors.
 728 ######## tying a bareword causes a segfault in 5.6.1
 729 tie FOO, "Foo";
 730 EXPECT
 731 Can't modify constant item in tie at - line 1, near ""Foo";"
 732 Execution of - aborted due to compilation errors.
 733 ######## undefing constant causes a segfault in 5.6.1 [ID 20010906.019]
 734 undef foo;
 735 EXPECT
 736 Can't modify constant item in undef operator at - line 1, near "foo;"
 737 Execution of - aborted due to compilation errors.
 738 ######## (?{...}) compilation bounces on PL_rs
 739 -0
 740 {
 741   /(?{ $x })/;
 742   # {
 743 }
 744 BEGIN { print "ok\n" }
 745 EXPECT
 746 ok
 747 ######## read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]
 748 read($bla, FILE, 1);
 749 EXPECT
 750 Can't modify constant item in read at - line 1, near "1)"
 751 Execution of - aborted due to compilation errors.
 752 ######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
 753 # This only happens if the filename is 11 characters or less.
 754 $foo = \-f "blah";
 755 print "ok" if ref $foo && !$$foo;
 756 EXPECT
 757 ok
 758 ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
 759 print "ok" if 'X' =~ /\X/;
 760 EXPECT
 761 ok
 762 ######## segfault in 5.6.1 within peep()
 763 @a = (1..9);
 764 @b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
 765 print join '', @a, "\n";
 766 EXPECT
 767 123456789
 768 ######## [ID 20020104.007] "coredump on dbmclose"
 769 package Foo;
 770 eval { require AnyDBM_File }; # not all places have dbm* functions
 771 if ($@) {
 772     print "ok\n";
 773     exit 0;
 774 }
 775 package Foo;
 776 sub new {
 777         my $proto = shift;
 778         my $class = ref($proto) || $proto;
 779         my $self  = {};
 780         bless($self,$class);
 781         my %LT;
 782         dbmopen(%LT, "dbmtest", 0666) ||
 783             die "Can't open dbmtest because of $!\n";
 784         $self->{'LT'} = \%LT;
 785         return $self;
 786 }
 787 sub DESTROY {
 788         my $self = shift;
 789         dbmclose(%{$self->{'LT'}});
 790         1 while unlink 'dbmtest';
 791         1 while unlink <dbmtest.*>;
 792         print "ok\n";
 793 }
 794 package main;
 795 $test = Foo->new(); # must be package var
 796 EXPECT
 797 ok
 798 ######## example from Camel 5, ch. 15, pp.406 (with my)
 799 # SKIP: ord "A" == 193 # EBCDIC
 800 use strict;
 801 use utf8;
 802 my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
 803 $人++; # a child is born
 804 print $人, "\n";
 805 EXPECT
 806 3
 807 ######## example from Camel 5, ch. 15, pp.406 (with our)
 808 # SKIP: ord "A" == 193 # EBCDIC
 809 use strict;
 810 use utf8;
 811 our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
 812 $人++; # a child is born
 813 print $人, "\n";
 814 EXPECT
 815 3
 816 ######## example from Camel 5, ch. 15, pp.406 (with package vars)
 817 # SKIP: ord "A" == 193 # EBCDIC
 818 use utf8;
 819 $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
 820 $人++; # a child is born
 821 print $人, "\n";
 822 EXPECT
 823 3
 824 ######## example from Camel 5, ch. 15, pp.406 (with use vars)
 825 # SKIP: ord "A" == 193 # EBCDIC
 826 use strict;
 827 use utf8;
 828 use vars qw($人);
 829 $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
 830 $人++; # a child is born
 831 print $人, "\n";
 832 EXPECT
 833 3