t/op/misc.t

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