Integrate mainline

p4raw-id: //depot/perlio@19246

13 files changed, 342 insertions, 18 deletions

diff --git a/t/README b/t/README
index a20b481871..c129720ae2 100644
--- a/t/README
+++ b/t/README
@@ -26,6 +26,6 @@ That is, they should not require Config.pm nor should they require any
 extensions to have been built.  TEST will abort if any tests in the
 t/base/ directory fail.
 
-Tests in the t/comp/, t/cmd/, t/run/, t/io/, and t/op/ directories should
-also be runnable by miniperl and not require Config.pm, but failures
-to comply will not cause TEST to abort like for t/base/.
+Tests in the t/comp/, t/cmd/, t/run/, t/io/, t/op/ and t/uni/ directories
+should also be runnable by miniperl and not require Config.pm, but
+failures to comply will not cause TEST to abort like for t/base/.
diff --git a/t/comp/require.t b/t/comp/require.t
index 44b46cd72c..78ac436337 100755
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -11,8 +11,8 @@ $i = 1;
 
 my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
 my $Is_UTF8   = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 23;
-if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 20; }
+my $total_tests = 29;
+if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 26; }
 print "1..$total_tests\n";
 
 sub do_require {
@@ -130,6 +130,22 @@ dofile();
 sub dofile { do "bleah.do"; };
 print $x;
 
+# Test that scalar context is forced for require
+
+write_file('bleah.pm', <<'**BLEAH**'
+print "not " if !defined wantarray || wantarray ne '';
+print "ok $i - require() context\n";
+1;
+**BLEAH**
+);
+                              delete $INC{"bleah.pm"}; ++$::i;
+$foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+@foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+       eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+$foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+@foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
+       eval  {require bleah};
+
 # UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input
 
 if ($Is_EBCDIC || $Is_UTF8) { exit; }
diff --git a/t/io/layers.t b/t/io/layers.t
new file mode 100644
index 0000000000..0e733ad994
--- /dev/null
+++ b/t/io/layers.t
@@ -0,0 +1,191 @@
+#!./perl
+
+my $PERLIO;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    # Makes testing easier.
+    $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq '';
+    if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
+	# We are not prepared for anything else.
+	print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
+	exit 0;
+    }
+    $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)";
+}
+
+plan tests => 43;
+
+use Config;
+
+my $DOSISH    = $^O =~ /^(?:MSWin32|cygwin|os2|dos|NetWare|mint)$/ ? 1 : 0;
+my $NONSTDIO  = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0;
+my $FASTSTDIO =
+    $Config{d_stdstdio} &&
+    $Config{d_stdio_ptr_lval} &&
+    ($Config{d_stdio_cnt_lval} ||
+     $Config{d_stdio_ptr_lval_sets_cnt}) ? 1 : 0;
+
+print <<__EOH__;
+# PERLIO    = $PERLIO
+# DOSISH    = $DOSISH
+# NONSTDIO  = $NONSTDIO
+# FASTSTDIO = $FASTSTDIO
+__EOH__
+
+SKIP: {
+    skip("This perl does not have Encode", 43)
+	unless " $Config{extensions} " =~ / Encode /;
+
+    sub check {
+	my ($result, $expected, $id) = @_;
+	# An interesting dance follows where we try to make the following
+	# IO layer stack setups to compare equal:
+	#
+	# PERLIO     UNIX-like       DOS-like
+	#
+	# none or "" stdio [1]       unix crlf
+	# stdio      stdio [1]       stdio
+	# perlio     unix perlio     unix perlio
+	# mmap       unix mmap       unix mmap
+	#
+	# [1] If Configure found how to do "fast stdio",
+	# otherwise it will be "unix perlio".
+	#
+	if ($NONSTDIO) {
+	    # Get rid of "unix".
+	    shift @$result if $result->[0] eq "unix";
+	    # Change expectations.
+	    if ($FASTSTDIO) {
+		$expected->[0] = $ENV{PERLIO};
+	    } else {
+		$expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
+	    }
+	} elsif (!$FASTSTDIO) {
+	    splice(@$result, 0, 2, "stdio")
+		if @$result >= 2 &&
+		   $result->[0] eq "unix" &&
+		   $result->[1] eq "perlio";
+	} elsif ($DOSISH) {
+	    splice(@$result, 0, 2, "stdio")
+		if @$result >= 2 &&
+		   $result->[0] eq "unix" &&
+		   $result->[1] eq "crlf";
+	}
+	my $n = scalar @$expected;
+	is($n, scalar @$expected, "$id - layers = $n");
+	for (my $i = 0; $i < $n; $i++) {
+	    my $j = $expected->[$i];
+	    if (ref $j eq 'CODE') {
+		ok($j->($result->[$i]), "$id - $i is ok");
+	    } else {
+		is($result->[$i], $j,
+		   sprintf("$id - $i is %s",
+			   defined $j ? $j : "undef"));
+	    }
+	}
+    }
+
+    check([ PerlIO::get_layers(STDIN) ],
+	  [ "stdio" ],
+	  "STDIN");
+
+    open(F, ">:crlf", "afile");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ qw(stdio crlf) ],
+	  "open :crlf");
+
+    binmode(F, ":encoding(sjis)"); # "sjis" will be canonized to "shiftjis"
+
+    check([ PerlIO::get_layers(F) ],
+	  [ qw[stdio crlf encoding(shiftjis) utf8] ],
+	  ":encoding(sjis)");
+    
+    binmode(F, ":pop");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ qw(stdio crlf) ],
+	  ":pop");
+
+    binmode(F, ":raw");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ "stdio" ],
+	  ":raw");
+
+    binmode(F, ":pop") if $DOSISH; # Drop one extra :crlf.
+    binmode(F, ":utf8");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ qw(stdio utf8) ],
+	  ":utf8");
+
+    binmode(F, ":bytes");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ "stdio" ],
+	  ":bytes");
+
+    binmode(F, ":encoding(utf8)");
+
+    check([ PerlIO::get_layers(F) ],
+	    [ qw[stdio encoding(utf8) utf8] ],
+	    ":encoding(utf8)");
+
+    binmode(F, ":raw :crlf");
+
+    check([ PerlIO::get_layers(F) ],
+	  [ qw(stdio crlf) ],
+	  ":raw:crlf");
+
+    binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
+
+    SKIP: {
+	skip("too complex layer coreography", 7) if $DOSISH || !$FASTSTDIO;
+
+	my @results = PerlIO::get_layers(F, details => 1);
+
+	# Get rid of the args and the flags.
+	splice(@results, 1, 2) if $NONSTDIO;
+
+	check([ @results ],
+	      [ "stdio",    undef,        sub { $_[0] > 0 },
+		"encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ],
+	      ":raw:encoding(latin1)");
+    }
+
+    binmode(F);
+
+    check([ PerlIO::get_layers(F) ],
+	  [ "stdio" ],
+	  "binmode");
+
+    close F;
+
+    {
+	use open(IN => ":crlf", OUT => ":encoding(cp1252)");
+
+	open F, "<afile";
+	open G, ">afile";
+
+	check([ PerlIO::get_layers(F, input  => 1) ],
+	      [ qw(stdio crlf) ],
+	      "use open IN");
+	
+	check([ PerlIO::get_layers(G, output => 1) ],
+	      [ qw[stdio encoding(cp1252) utf8] ],
+	      "use open OUT");
+
+	close F;
+	close G;
+    }
+
+    1 while unlink "afile";
+}
diff --git a/t/io/open.t b/t/io/open.t
index 9e067b74f6..87a9c5580b 100755
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -12,7 +12,7 @@ use Config;
 $Is_VMS = $^O eq 'VMS';
 $Is_MacOS = $^O eq 'MacOS';
 
-plan tests => 95;
+plan tests => 100;
 
 my $Perl = which_perl();
 
@@ -228,6 +228,11 @@ like( $@, qr/Bad filehandle:\s+afile/,          '       right error' );
     ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
     ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
 
+    {
+	use strict; # the below should not warn
+	ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
+    }
+
     # used to try to open a file [perl #17830]
     ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh');
 }
@@ -244,3 +249,33 @@ SKIP: {
     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
 }
+
+{
+    local $SIG{__WARN__} = sub { $@ = shift };
+
+    sub gimme {
+        my $tmphandle = shift;
+	my $line = scalar <$tmphandle>;
+	warn "gimme";
+	return $line;
+    }
+
+    open($fh0[0], "TEST");
+    gimme($fh0[0]);
+    like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
+
+    open($fh1{k}, "TEST");
+    gimme($fh1{k});
+    like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
+
+    my @fh2;
+    open($fh2[0], "TEST");
+    gimme($fh2[0]);
+    like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
+
+    my %fh3;
+    open($fh3{k}, "TEST");
+    gimme($fh3{k});
+    like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
+}
+    
diff --git a/t/lib/MakeMaker/Test/Utils.pm b/t/lib/MakeMaker/Test/Utils.pm
index 9260faf343..be3ec73d74 100644
--- a/t/lib/MakeMaker/Test/Utils.pm
+++ b/t/lib/MakeMaker/Test/Utils.pm
@@ -12,7 +12,7 @@ require Exporter;
 $VERSION = 0.02;
 
 @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
-             make make_run make_macro calibrate_mtime
+             make make_run run make_macro calibrate_mtime
             );
 
 my $Is_VMS   = $^O eq 'VMS';
@@ -39,6 +39,8 @@ MakeMaker::Test::Utils - Utility routines for testing MakeMaker
 
   my $mtime         = calibrate_mtime;
 
+  my $out           = run($cmd);
+
 =head1 DESCRIPTION
 
 A consolidation of little utility functions used through out the
@@ -230,6 +232,34 @@ sub calibrate_mtime {
     return $mtime;
 }
 
+=item B<run>
+
+  my $out = run($command);
+  my @out = run($command);
+
+Runs the given $command as an external program returning at least STDOUT
+as $out.  If possible it will return STDOUT and STDERR combined as you
+would expect to see on a screen.
+
+=cut
+
+sub run {
+    my $cmd = shift;
+
+    require ExtUtils::MM;
+
+    # Unix can handle 2>&1 and OS/2 from 5.005_54 up.
+    # This makes our failure diagnostics nicer to read.
+    if( MM->os_flavor_is('Unix') or
+        ($] > 5.00554 and MM->os_flavor_is('OS/2'))
+      ) {
+        return `$cmd 2>&1`;
+    }
+    else {
+        return `$cmd`;
+    }
+}    
+
 =back
 
 =head1 AUTHOR
diff --git a/t/lib/sample-tests/switches b/t/lib/sample-tests/switches
new file mode 100644
index 0000000000..8ce9c9a589
--- /dev/null
+++ b/t/lib/sample-tests/switches
@@ -0,0 +1,2 @@
+print "1..1\n";
+print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n";
diff --git a/t/lib/strict/subs b/t/lib/strict/subs
index 4516de7be3..9e329091fc 100644
--- a/t/lib/strict/subs
+++ b/t/lib/strict/subs
@@ -361,3 +361,8 @@ print 1..1, bad;
 EXPECT
 Bareword "bad" not allowed while "strict subs" in use at - line 3.
 Execution of - aborted due to compilation errors.
+########
+eval q{ use strict; no strict refs; };
+print $@;
+EXPECT
+Bareword "refs" not allowed while "strict subs" in use at (eval 1) line 1.
diff --git a/t/lib/strict/vars b/t/lib/strict/vars
index de517078be..ab24c9d580 100644
--- a/t/lib/strict/vars
+++ b/t/lib/strict/vars
@@ -421,3 +421,12 @@ no warnings;
 EXPECT
 Global symbol "@i_like_crackers" requires explicit package name at - line 7.
 Execution of - aborted due to compilation errors.
+########
+
+# [perl #21914] New bug > 5.8.0. Used to dump core.
+use strict 'vars';
+@k = <$k>;
+EXPECT
+Global symbol "@k" requires explicit package name at - line 4.
+Global symbol "$k" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
diff --git a/t/op/getpid.t b/t/op/getpid.t
index f1a40636b4..a2c5f5f0e2 100644
--- a/t/op/getpid.t
+++ b/t/op/getpid.t
@@ -11,8 +11,6 @@ BEGIN {
 use strict;
 use Config;
 
-plan tests => 2;
-
 BEGIN {
     if (!$Config{useithreads}) {
 	print "1..0 # Skip: no ithreads\n";
@@ -22,11 +20,20 @@ BEGIN {
 	print "1..0 # Skip: no getppid\n";
 	exit;
     }
+    eval 'use threads; use threads::shared';
+    if ($@ =~ /dynamic loading not available/) {
+	print "1..0 # Skip: no dynamic loading, no threads\n";
+	exit;
+    }
+    plan tests => 3;
+    if ($@) {
+	fail("unable to load thread modules");
+    }
+    else {
+	pass("thread modules loaded");
+    }
 }
 
-use threads;
-use threads::shared;
-
 my ($pid, $ppid) = ($$, getppid());
 my $pid2 : shared = 0;
 my $ppid2 : shared = 0;
diff --git a/t/op/pat.t b/t/op/pat.t
index 16a38202dd..26e859435f 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..996\n";
+print "1..997\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -3159,4 +3159,11 @@ ok("bbbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]");
     ok(join(":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr");
 }
 
-# last test 996
+{
+    $_ = "code:   'x' { '...' }\n"; study;
+    my @x; push @x, $& while m/'[^\']*'/gx;
+    ok(join(":", @x) eq "'x':'...'",
+       "[perl #17757] Parse::RecDescent triggers infinite loop");
+}
+
+# last test 997
diff --git a/t/op/readdir.t b/t/op/readdir.t
index 83451d3d68..ee641227b7 100755
--- a/t/op/readdir.t
+++ b/t/op/readdir.t
@@ -8,7 +8,7 @@ BEGIN {
 eval 'opendir(NOSUCH, "no/such/directory");';
 if ($@) { print "1..0\n"; exit; }
 
-print "1..3\n";
+print "1..11\n";
 
 for $i (1..2000) {
     local *OP;
@@ -44,3 +44,12 @@ while (@R && @G && $G[0] eq ($^O eq 'MacOS' ? ':op:' : 'op/').$R[0]) {
 	shift(@G);
 }
 if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; }
+
+if (opendir($fh, "op")) { print "ok 4\n"; } else { print "not ok 4\n"; }
+if (ref($fh) eq 'GLOB') { print "ok 5\n"; } else { print "not ok 5\n"; }
+if (opendir($fh[0], "op")) { print "ok 6\n"; } else { print "not ok 6\n"; }
+if (ref($fh[0]) eq 'GLOB') { print "ok 7\n"; } else { print "not ok 7\n"; }
+if (opendir($fh{abc}, "op")) { print "ok 8\n"; } else { print "not ok 8\n"; }
+if (ref($fh{abc}) eq 'GLOB') { print "ok 9\n"; } else { print "not ok 9\n"; }
+if ("$fh" ne "$fh[0]") { print "ok 10\n"; } else { print "not ok 10\n"; }
+if ("$fh" ne "$fh{abc}") { print "ok 11\n"; } else { print "not ok 11\n"; }
diff --git a/t/op/split.t b/t/op/split.t
index 55b2839b0c..17ab1e6a37 100755
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 52;
+plan tests => 54;
 
 $FS = ':';
 
@@ -279,6 +279,13 @@ ok(@ary == 3 &&
 {
     $p="a,b";
     utf8::upgrade $p;
-    @a=split(/[, ]+/,$p);
+    eval { @a=split(/[, ]+/,$p) };
     is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8');
 }
+
+{
+    is (\@a, \@{"a"}, '@a must be global for following test');
+    $p="";
+    $n = @a = split /,/,$p;
+    is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters');
+}
diff --git a/t/op/undef.t b/t/op/undef.t
index f6e36a5bed..1d169944be 100755
--- a/t/op/undef.t
+++ b/t/op/undef.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..27\n";
+print "1..28\n";
 
 print defined($a) ? "not ok 1\n" : "ok 1\n";
 
@@ -79,3 +79,9 @@ print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n";
     @foo = ( a => 1 );
     print defined @foo ? "ok 27\n" : "not ok 27\n";
 }
+
+{
+    # [perl #17753] segfault when undef'ing unquoted string constant
+    eval 'undef tcp';
+    print $@ =~ /^Can't modify constant item/ ? "ok 28\n" : "not ok 28\n";
+}