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 used to abnormally 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 BEGIN {
  12     chdir 't' if -d 't';
  13     @INC = '../lib';
  14     require './test.pl';        # for which_perl() etc
  15 }
  16
  17 use strict;
  18
  19 my $Perl = which_perl();
  20
  21 $|=1;
  22
  23 my @prgs = ();
  24 while(<DATA>) {
  25     if(m/^#{8,}\s*(.*)/) {
  26         push @prgs, ['', $1];
  27     }
  28     else {
  29         $prgs[-1][0] .= $_;
  30     }
  31 }
  32 plan tests => scalar @prgs;
  33
  34 foreach my $prog (@prgs) {
  35     my($raw_prog, $name) = @$prog;
  36
  37     my $switch;
  38     if ($raw_prog =~ s/^\s*(-\w.*)\n//){
  39         $switch = $1;
  40     }
  41
  42     my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
  43     $prog .= "\n";
  44     $expected = '' unless defined $expected;
  45
  46     if ($prog =~ /^\# SKIP: (.+)/m) {
  47         if (eval $1) {
  48             ok(1, "Skip: $1");
  49             next;
  50         }
  51     }
  52
  53     $expected =~ s/\n+$//;
  54
  55     fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
  56 }
  57
  58 __END__
  59 ########
  60 $a = ":="; @_ = split /($a)/o, "a:=b:=c"; print "@_"
  61 EXPECT
  62 a := b := c
  63 ########
  64 $cusp = ~0 ^ (~0 >> 1);
  65 use integer;
  66 $, = " ";
  67 print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
  68 EXPECT
  69 7 0 0 8 !
  70 ########
  71 $foo=undef; $foo->go;
  72 EXPECT
  73 Can't call method "go" on an undefined value at - line 1.
  74 ########
  75 BEGIN
  76         {
  77             "foo";
  78         }
  79 ########
  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 ########
  86 chop ($str .= <DATA>);
  87 ########
  88 close ($banana);
  89 ########
  90 $x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
  91 EXPECT
  92 25
  93 ########
  94 eval 'sub bar {print "In bar"}';
  95 ########
  96 system './perl -ne "print if eof" /dev/null'
  97 ########
  98 chop($file = <DATA>);
  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 ########
 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  &sub;
 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.
 199 ########
 200 {
 201     package foo;
 202     sub PRINT {
 203         shift;
 204         print join(' ', reverse @_)."\n";
 205     }
 206     sub PRINTF {
 207         shift;
 208           my $fmt = shift;
 209         print sprintf($fmt, @_)."\n";
 210     }
 211     sub TIEHANDLE {
 212         bless {}, shift;
 213     }
 214     sub READLINE {
 215         "Out of inspiration";
 216     }
 217     sub DESTROY {
 218         print "and destroyed as well\n";
 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   }
 230 }
 231 {
 232     local(*FOO);
 233     tie(*FOO,'foo');
 234     print FOO "sentence.", "reversed", "a", "is", "This";
 235     print "-- ", <FOO>, " --\n";
 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";
 241     printf "%s is number %d\n", "Perl", 1;
 242 }
 243 EXPECT
 244 This is a reversed sentence.
 245 -- Out of inspiration --
 246 foo->can(READ)(string 10 1)
 247 Don't GETC, Get Perl
 248 Perl is number 1
 249 and destroyed as well
 250 ########
 251 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
 252 EXPECT
 253 2 2 2
 254 ########
 255 # used to attach defelem magic to all immortal values,
 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 ########
 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 ########
 274 print "ok\n" if ("\0" lt "\xFF");
 275 EXPECT
 276 ok
 277 ########
 278 open(H,'run/fresh_perl.t'); # must be in the 't' directory
 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 ########
 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 ########
 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
 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);
 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';
 351 ########
 352 /(?{"{"})/      # Check it outside of eval too
 353 EXPECT
 354 Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
 355 ########
 356 /(?{"{"}})/     # Check it outside of eval too
 357 EXPECT
 358 Unmatched right curly bracket at (re_eval 1) line 1, at end of line
 359 syntax error at (re_eval 1) line 1, near ""{"}"
 360 Compilation failed in regexp at - line 1.
 361 ########
 362 BEGIN { @ARGV = qw(a b c d e) }
 363 BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
 364 END { print "end <",shift,">\nargv <@ARGV>\n" }
 365 INIT { print "init <",shift,">\n" }
 366 CHECK { print "check <",shift,">\n" }
 367 EXPECT
 368 argv <a b c d e>
 369 begin <a>
 370 check <b>
 371 init <c>
 372 end <d>
 373 argv <e>
 374 ########
 375 -l
 376 # fdopen from a system descriptor to a system descriptor used to close
 377 # the former.
 378 open STDERR, '>&=STDOUT' or die $!;
 379 select STDOUT; $| = 1; print fileno STDOUT or die $!;
 380 select STDERR; $| = 1; print fileno STDERR or die $!;
 381 EXPECT
 382 1
 383 2
 384 ########
 385 -w
 386 sub testme { my $a = "test"; { local $a = "new test"; print $a }}
 387 EXPECT
 388 Can't localize lexical variable $a at - line 1.
 389 ########
 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
 425 sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
 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 ########
 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.
 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
 487 ########
 488 re();
 489 sub re {
 490     my $re = join '', eval 'qr/(??{ $obj->method })/';
 491     $re;
 492 }
 493 EXPECT
 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
 508 ########
 509 -w
 510 if (@ARGV) { print "" }
 511 else {
 512   if ($x == 0) { print "" } else { print $x }
 513 }
 514 EXPECT
 515 Use of uninitialized value $x in numeric eq (==) at - line 3.
 516 ########
 517 $x = sub {};
 518 foo();
 519 sub foo { eval { return }; }
 520 print "ok\n";
 521 EXPECT
 522 ok
 523 ########
 524 # moved to op/lc.t
 525 EXPECT
 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
 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.
 539 ########
 540 print qw(ab a\b a\\b);
 541 EXPECT
 542 aba\ba\b
 543 ########
 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 ########
 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 ########
 568 # This test is here instead of lib/locale.t because
 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".
 572 BEGIN {
 573     eval { require POSIX };
 574     if ($@) {
 575         exit(0); # running minitest?
 576     }
 577 }
 578 use Config;
 579 my $have_setlocale = $Config{d_setlocale} eq 'define';
 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
 583 $have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
 584 exit(0) unless $have_setlocale;
 585 my @locales;
 586 if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
 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;
 597     setlocale(LC_NUMERIC, $_) or next;
 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
 603 ########
 604 # [ID 20001202.002] and change #8066 added 'at -e line 1';
 605 # reversed again as a result of [perl #17763]
 606 die qr(x)
 607 EXPECT
 608 (?-xism:x)
 609 ########
 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!
 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;
 650 ########
 651 # David Dyck
 652 # coredump in 5.7.1
 653 close STDERR; die;
 654 EXPECT
 655 ########
 656 # core dump in 20000716.007
 657 -w
 658 "x" =~ /(\G?x)?/;
 659 ########
 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
 671 ########
 672 # Bug 20010506.041
 673 "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
 674 EXPECT
 675 ok
 676 ########
 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...)
 694 ######## (?{...}) compilation bounces on PL_rs
 695 -0
 696 {
 697   /(?{ $x })/;
 698   # {
 699 }
 700 BEGIN { print "ok\n" }
 701 EXPECT
 702 ok
 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
 709 ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
 710 print "ok" if 'X' =~ /\X/;
 711 EXPECT
 712 ok
 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
 719 ######## example from Camel 5, ch. 15, pp.406 (with my)
 720 # SKIP: ord "A" == 193 # EBCDIC
 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)
 729 # SKIP: ord "A" == 193 # EBCDIC
 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)
 738 # SKIP: ord "A" == 193 # EBCDIC
 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
 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
 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->({});
 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
 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<
 794 ######## [perl #8760] strangness with utf8 and warn
 795 $_="foo";utf8::upgrade($_);/bar/i,warn$_;
 796 EXPECT
 797 foo at - line 1.
 798 ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
 799 -lw
 800 BEGIN {
 801   if ($^O eq 'os390') {
 802     require File::Glob;
 803     import File::Glob ':glob';
 804   }
 805 }
 806 BEGIN {
 807   eval 'require Fcntl';
 808   if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
 809 }
 810 if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
 811 print qq[./"TEST"\n./"TEST"\n];
 812 } else {
 813 print glob(q(./"TEST"));
 814 use File::Glob;
 815 print glob(q(./"TEST"));
 816 }
 817 EXPECT
 818 ./"TEST"
 819 ./"TEST"
 820 ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
 821 -lw
 822 BEGIN {
 823   if ($^O eq 'os390') {
 824     require File::Glob;
 825     import File::Glob ':glob';
 826   }
 827 }
 828 BEGIN {
 829   eval 'require Fcntl';
 830   if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
 831 }
 832 if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
 833 print qq[./"TEST"\n./"TEST"\n];
 834 } else {
 835 use File::Glob;
 836 print glob(q(./"TEST"));
 837 use File::Glob;
 838 print glob(q(./"TEST"));
 839 }
 840 EXPECT
 841 ./"TEST"
 842 ./"TEST"
 843 ######## "Segfault using HTML::Entities", Richard Jolly <richardjolly@mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6@mac.com> in perl-unicode@perl.org
 844 -lw
 845 # SKIP: use Config; $ENV{PERL_CORE_MINITEST} or " $Config::Config{'extensions'} " !~ m[ Encode ] # Perl configured without Encode module
 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;
 853 my $t = ord('A') == 193 ? "\xEA" : "\xE9";
 854 Encode::_utf8_on($t);
 855 $t =~ s/([^a])//ge;
 856 $@ =~ s/ at .*/ at/;
 857 print $@
 858 EXPECT
 859 Malformed UTF-8 character (unexpected end of string) in substitution (s///) at
 860 ######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression"
 861 use strict;
 862
 863 unshift @INC, sub {
 864     my ($self, $fn) = @_;
 865
 866     (my $pkg = $fn) =~ s{/}{::}g;
 867     $pkg =~ s{.pm$}{};
 868
 869     if ($pkg eq 'Credit') {
 870         my $code = <<'EOC';
 871 package Credit;
 872
 873 use NonsenseAndBalderdash;
 874
 875 1;
 876 EOC
 877         eval $code;
 878         die "\$@ is $@";
 879     }
 880
 881     #print STDERR "Generator: not one of mine, ignoring\n";
 882     return undef;
 883 };
 884
 885 # create load-on-demand new() constructors
 886 {
 887     package Credit;
 888     sub new {
 889         eval "use Credit";
 890     }
 891 };
 892
 893 eval {
 894     my $credit = new Credit;
 895 };
 896
 897 print "If you get here, you didn't crash\n";
 898 EXPECT
 899 If you get here, you didn't crash