Import perl-5.18.2

OK espie@ sthen@ deraadt@

6 files changed, 234 insertions, 22 deletions

diff --git a/gnu/usr.bin/perl/t/comp/bproto.t b/gnu/usr.bin/perl/t/comp/bproto.t
index bc0f1a291bd..8d11b915c1a 100644
--- a/gnu/usr.bin/perl/t/comp/bproto.t
+++ b/gnu/usr.bin/perl/t/comp/bproto.t
@@ -8,7 +8,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..14\n";
+print "1..16\n";
 
 my $i = 1;
 
@@ -35,12 +35,14 @@ sub test_no_error {
 
 test_too_many($_) for split /\n/,
 q[	defined(&foo, $bar);
+	pos(1,$b);
 	undef(&foo, $bar);
 	uc($bar,$bar);
 ];
 
 test_too_few($_) for split /\n/,
 q[	unpack;
+	pack;
 ];
 
 test_no_error($_) for split /\n/,
diff --git a/gnu/usr.bin/perl/t/comp/fold.t b/gnu/usr.bin/perl/t/comp/fold.t
index ec95f1aed80..5d6d9bf0892 100644
--- a/gnu/usr.bin/perl/t/comp/fold.t
+++ b/gnu/usr.bin/perl/t/comp/fold.t
@@ -4,7 +4,7 @@
 # we've not yet verified that use works.
 # use strict;
 
-print "1..19\n";
+print "1..26\n";
 my $test = 0;
 
 # Historically constant folding was performed by evaluating the ops, and if
@@ -118,3 +118,34 @@ is ($@, '', 'no error');
  ok scalar $jing =~ (0 || y/fo//),
    'lone y/// is not bound via =~ after || folding';
 }
+
+# [perl #78064] or print
+package other { # hide the "ok" sub
+ BEGIN { $^W = 0 }
+ print 0 ? not_ok : ok;
+ print " ", ++$test, " - print followed by const ? BEAR : BEAR\n";
+ print 1 ? ok : not_ok;
+ print " ", ++$test, " - print followed by const ? BEAR : BEAR (again)\n";
+ print 1 && ok;
+ print " ", ++$test, " - print followed by const && BEAR\n";
+ print 0 || ok;
+ print " ", ++$test, " - print followed by const || URSINE\n";
+ BEGIN { $^W = 1 }
+}
+
+# or stat
+print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL");
+print "ok ", ++$test, " - stat(const ? word : ....)\n";
+# in case we are in t/
+print "not " unless stat(1 ? TEST : 0) eq stat("TEST");
+print "ok ", ++$test, " - stat(const ? word : ....)\n";
+
+# or truncate
+my $n = "for_fold_dot_t$$";
+open F, ">$n" or die "open: $!";
+print F "bralh blah blah \n";
+close F or die "close $!";
+eval "truncate 1 ? $n : 0, 0;";
+print "not " unless -z $n;
+print "ok ", ++$test, " - truncate(const ? word : ...)\n";
+unlink $n;
diff --git a/gnu/usr.bin/perl/t/comp/form_scope.t b/gnu/usr.bin/perl/t/comp/form_scope.t
index d4b5eddeb6c..2370a4bb307 100755
--- a/gnu/usr.bin/perl/t/comp/form_scope.t
+++ b/gnu/usr.bin/perl/t/comp/form_scope.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..7\n";
+print "1..14\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -75,13 +75,36 @@ defined $x ? "not ok 4 - $x" : "ok 4"
   print "ok 5 - closure var not available when outer sub is inactive\n";
 }
 
+# Formats inside closures should close over the topmost clone of the outer
+# sub on the call stack.
+# Tests will be out of sequence if the wrong sub is used.
+sub make_closure {
+  my $arg = shift;
+  sub {
+    shift == 0 and &$next(1), return;
+    my $x = "ok $arg";
+    format STDOUT4 =
+@<<<<<<<
+$x
+.
+    sub { write }->(); # separate sub, so as not to rely on it being the
+  }                    # currently-running sub
+}
+*STDOUT = *STDOUT4{FORMAT};
+$clo1 = make_closure 6;
+$clo2 = make_closure 7;
+$next = $clo1;
+&$clo2(0);
+$next = $clo2;
+&$clo1(0);
+
 # Cloning a format whose outside has been undefined
 sub x {
     {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
     my $z;
     format STDOUT6 =
 @<<<<<<<<<<<<<<<<<<<<<<<<<
-defined $z ? "not ok 6 - $z" : "ok 6"
+defined $z ? "not ok 8 - $z" : "ok 8"
 .
 }
 undef &x;
@@ -92,5 +115,46 @@ undef &x;
   local $SIG{__WARN__} = sub { $w = shift };
   write;
   print "not " unless $w =~ /^Variable "\$z" is not available at/;
-  print "ok 7 - closure var not available when outer sub is undefined\n";
+  print "ok 9 - closure var not available when outer sub is undefined\n";
+}
+
+format STDOUT7 =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<
+do { my $x = "ok 10 - closure inside format"; sub { $x }->() }
+.
+*STDOUT = *STDOUT7{FORMAT};
+write;
+
+$testn = 12;
+format STDOUT8 =
+@<<<< - recursive formats
+do { my $t = "ok " . $testn--; write if $t =~ 12; $t}
+.
+*STDOUT = *STDOUT8{FORMAT};
+write;
+
+sub _13 {
+    my $x;
+format STDOUT13 =
+@* - formats closing over redefined subs
+ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13";
+.
+}
+undef &_13;
+eval 'sub _13 { my @x; write }';
+*STDOUT = *STDOUT13{FORMAT};
+_13();
+
+# This is a variation of bug #22977, which crashes or fails an assertion
+# up to 5.16.
+# Keep this test last if you want test numbers to be sane.
+BEGIN { \&END }
+END {
+  my $test = "ok 14";
+  *STDOUT = *STDOUT5{FORMAT};
+  write;
+  format STDOUT5 =
+@<<<<<<<
+$test
+.
 }
diff --git a/gnu/usr.bin/perl/t/comp/hints.t b/gnu/usr.bin/perl/t/comp/hints.t
index a857755a4a4..9a08854d86c 100644
--- a/gnu/usr.bin/perl/t/comp/hints.t
+++ b/gnu/usr.bin/perl/t/comp/hints.t
@@ -4,6 +4,7 @@
 
 BEGIN {
     @INC = qw(. ../lib);
+    chdir 't';
 }
 
 BEGIN { print "1..31\n"; }
diff --git a/gnu/usr.bin/perl/t/comp/parser.t b/gnu/usr.bin/perl/t/comp/parser.t
index 16b4a826d1a..4f2da90f50e 100644
--- a/gnu/usr.bin/perl/t/comp/parser.t
+++ b/gnu/usr.bin/perl/t/comp/parser.t
@@ -3,7 +3,7 @@
 # Checks if the parser behaves correctly in edge cases
 # (including weird syntax errors)
 
-print "1..123\n";
+print "1..155\n";
 
 sub failed {
     my ($got, $expected, $name) = @_;
@@ -69,6 +69,13 @@ eval q/"\Nfoo"/;
 like( $@, qr/^Missing braces on \\N/,
     'syntax error in string with incomplete \N' );
 
+eval q/"\o{"/;
+like( $@, qr/^Missing right brace on \\o/,
+    'syntax error in string with incomplete \o' );
+eval q/"\ofoo"/;
+like( $@, qr/^Missing braces on \\o/,
+    'syntax error in string with incomplete \o' );
+
 eval "a.b.c.d.e.f;sub";
 like( $@, qr/^Illegal declaration of anonymous subroutine/,
     'found by Markov chain stress testing' );
@@ -125,11 +132,11 @@ is( $@, '', 'PL_lex_brackstack' );
     is("${a}[", "A[", "interpolation, qq//");
     my @b=("B");
     is("@{b}{", "B{", "interpolation, qq//");
-    is(qr/${a}{/, '(?^:A{)', "interpolation, qr//");
+    is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//");
     my $c = "A{";
-    $c =~ /${a}{/;
+    $c =~ /${a}\{/;
     is($&, 'A{', "interpolation, m//");
-    $c =~ s/${a}{/foo/;
+    $c =~ s/${a}\{/foo/;
     is($c, 'foo', "interpolation, s/...//");
     $c =~ s/foo/${a}{/;
     is($c, 'A{', "interpolation, s//.../");
@@ -311,9 +318,9 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' );
   eval qq[ %$xFC ];
   like($@, qr/Identifier too long/, "too long id in % sigil ctx");
 
-  eval qq[ \\&$xFC ]; # take a ref since I don't want to call it
-  is($@, "", "252 character & sigil ident ok");
-  eval qq[ \\&$xFD ];
+  eval qq[ \\&$xFB ]; # take a ref since I don't want to call it
+  is($@, "", "251 character & sigil ident ok");
+  eval qq[ \\&$xFC ];
   like($@, qr/Identifier too long/, "too long id in & sigil ctx");
 
   eval qq[ *$xFC ];
@@ -341,6 +348,12 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' );
   is(defined &zlonk, '', 'but no body defined');
 }
 
+# [perl #113016] CORE::print::foo
+sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate
+sub CORE'foo'bar { 43 }
+is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo';
+is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error";
+
 # bug #71748
 eval q{
 	$_ = "";
@@ -353,7 +366,99 @@ eval q{
 };
 is($@, "", "multiline whitespace inside substitute expression");
 
-# Add new tests HERE:
+eval '@A =~ s/a/b/; # compilation error
+      sub tahi {}
+      sub rua;
+      sub toru ($);
+      sub wha :lvalue;
+      sub rima ($%&*$&*\$%\*&$%*&) :method;
+      sub ono :lvalue { die }
+      sub whitu (_) { die }
+      sub waru ($;) :method { die }
+      sub iwa { die }
+      BEGIN { }';
+is $::{tahi}, undef, 'empty sub decl ignored after compilation error';
+is $::{rua}, undef, 'stub decl ignored after compilation error';
+is $::{toru}, undef, 'stub+proto decl ignored after compilation error';
+is $::{wha}, undef, 'stub+attr decl ignored after compilation error';
+is $::{rima}, undef, 'stub+proto+attr ignored after compilation error';
+is $::{ono}, undef, 'sub decl with attr ignored after compilation error';
+is $::{whitu}, undef, 'sub decl w proto ignored after compilation error';
+is $::{waru}, undef, 'sub w attr+proto ignored after compilation error';
+is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error';
+is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error';
+
+$test = $test + 1;
+"ok $test - format inside re-eval" =~ /(?{
+    format =
+@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$_
+.
+write
+}).*/;
+
+eval '
+"${;
+
+=pod
+
+=cut
+
+}";
+';
+is $@, "", 'pod inside string in string eval';
+"${;
+
+=pod
+
+=cut
+
+}";
+print "ok ", ++$test, " - pod inside string outside of string eval\n";
+
+like "blah blah blah\n", qr/${\ <<END
+blah blah blah
+END
+ }/, 'here docs in multiline quoted construct';
+like "blah blah blah\n", eval q|qr/${\ <<END
+blah blah blah
+END
+ }/|, 'here docs in multiline quoted construct in string eval';
+
+# Unterminated here-docs in subst in eval; used to crash
+eval 's/${<<END}//';
+eval 's//${<<END}/';
+print "ok ", ++$test, " - unterminated here-docs in s/// in string eval\n";
+
+sub 'Hello'_he_said (_);
+is prototype "Hello::_he_said", '_', 'initial tick in sub declaration';
+
+{
+    my @x = 'string';
+    is(eval q{ "$x[0]->strung" }, 'string->strung',
+	'literal -> after an array subscript within ""');
+    @x = ['string'];
+    # this used to give "string"
+    like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/,
+	'literal -> [0] after an array subscript within ""');
+}
+
+eval 'no if $] >= 5.17.4 warnings => "deprecated"';
+is 1,1, ' no crash for "no ... syntax error"';
+
+for my $pkg(()){}
+$pkg = 3;
+is $pkg, 3, '[perl #114942] for my $foo()){} $foo';
+
+eval 'Fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
+    .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
+    .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
+    .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
+    .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
+    .'ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo';
+like $@, "^Identifier too long at ", 'ident buffer overflow';
+
+# Add new tests HERE (above this line)
 
 # bug #74022: Loop on characters in \p{OtherIDContinue}
 # This test hangs if it fails.
@@ -437,15 +542,16 @@ eval <<'EOSTANZA'; die $@ if $@;
 check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks");
 EOSTANZA
 
-{
-    my @x = 'string';
-    is(eval q{ "$x[0]->strung" }, 'string->strung',
-	'literal -> after an array subscript within ""');
-    @x = ['string'];
-    # this used to give "string"
-    like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/,
-	'literal -> [0] after an array subscript within ""');
-}
+#line 531 parser.t
+<<EOU; check('parser\.t', 531, 'on same line as heredoc');
+EOU
+s//<<EOV/e if 0;
+EOV
+check('parser\.t', 535, 'after here-doc in quotes');
+<<EOW;
+${check('parser\.t', 537, 'first line of interp in here-doc');;
+  check('parser\.t', 538, 'second line of interp in here-doc');}
+EOW
 
 __END__
 # Don't add new tests HERE. See note above
diff --git a/gnu/usr.bin/perl/t/comp/uproto.t b/gnu/usr.bin/perl/t/comp/uproto.t
index d3ad19f849e..f81e31411c6 100644
--- a/gnu/usr.bin/perl/t/comp/uproto.t
+++ b/gnu/usr.bin/perl/t/comp/uproto.t
@@ -72,7 +72,11 @@ eval q{ f(1,2,3,4) };
 like( $@, qr/Too many arguments for main::f at/ );
 
 {
+    # We have not tested require/use/no yet, so we must avoid this:
+    #    no warnings 'deprecated';
+    BEGIN { $SIG{__WARN__} = sub {} }
     my $_ = "quarante-deux";
+    BEGIN { $SIG{__WARN__} = undef }
     $foo = "FOO";
     $bar = "BAR";
     f("FOO quarante-deux", $foo);
@@ -97,7 +101,9 @@ $_ = $expected;
 g();
 g;
 undef $expected; &g; # $_ not passed
+BEGIN { $SIG{__WARN__} = sub {} }
 { $expected = my $_ = "bar"; g() }
+BEGIN { $SIG{__WARN__} = undef }
 
 eval q{ sub wrong1 (_$); wrong1(1,2) };
 like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
@@ -142,7 +148,9 @@ $_ = 21;
 double();
 is( $_, 42, '$_ is modifiable' );
 {
+    BEGIN { $SIG{__WARN__} = sub {} }
     my $_ = 22;
+    BEGIN { $SIG{__WARN__} = undef }
     double();
     is( $_, 44, 'my $_ is modifiable' );
 }