Integrate mainline

p4raw-id: //depot/perlio@14517

7 files changed, 229 insertions, 41 deletions

diff --git a/t/io/utf8.t b/t/io/utf8.t
index e8caf722f2..337bd52144 100755
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -12,7 +12,7 @@ BEGIN {
 no utf8; # needed for use utf8 not griping about the raw octets
 
 $| = 1;
-print "1..26\n";
+print "1..31\n";
 
 open(F,"+>:utf8",'a');
 print F chr(0x100).'£';
@@ -186,7 +186,7 @@ if (ord('A') == 193) {
 close F;
 unlink('a');
 
-open F, ">a";
+open F, ">:utf8", "a";
 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
 unshift @a, chr(0); # ... and a null byte in front just for fun
 print F @a;
@@ -216,6 +216,52 @@ for (@a) {
 close F;
 print "ok 26\n";
 
+{
+    # Check that warnings are on on I/O, and that they can be muffled.
+
+    local $SIG{__WARN__} = sub { $@ = shift };
+
+    undef $@;
+    open F, ">a";
+    print F chr(0x100);
+    close(F);
+
+    print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n";
+
+    undef $@;
+    open F, ">:utf8", "a";
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 28\n" : "ok 28\n";
+
+    undef $@;
+    open F, ">a";
+    binmode(F, ":utf8");
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 29\n" : "ok 29\n";
+
+    no warnings 'utf8';
+
+    undef $@;
+    open F, ">a";
+    print F chr(0x100);
+    close(F);
+
+    print defined $@ ? "not ok 30\n" : "ok 30\n";
+
+    use warnings 'utf8';
+
+    undef $@;
+    open F, ">a";
+    print F chr(0x100);
+    close(F);
+
+    print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n";
+}
+
 # sysread() and syswrite() tested in lib/open.t since Fnctl is used
 
 END {
@@ -223,4 +269,3 @@ END {
     1 while unlink "b";
 }
 
-
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index e30637b0d4..4b9c8b1a96 100644
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -83,9 +83,6 @@
     flock STDIN, 8;
     flock $a, 8;
 
-  The stat preceding lstat() wasn't an lstat %s	[pp_stat]
-    lstat(STDIN);
-
   warn(warn_nl, "stat");			[pp_stat]
 
   -T on closed filehandle %s
@@ -347,24 +344,6 @@ stat "abc\ndef";
 EXPECT
 Unsuccessful stat on filename containing newline at - line 3.
 ########
-# pp_sys.c [pp_stat]
-use Config; 
-BEGIN { 
-  if ($^O eq 'd_lstat') {
-    print <<EOM ;
-SKIPPED
-# lstat not present
-EOM
-    exit ;
-  } 
-}
-use warnings 'io' ;
-lstat(STDIN) ;
-no warnings 'io' ;
-lstat(STDIN) ;
-EXPECT
-The stat preceding lstat() wasn't an lstat at - line 13.
-########
 # pp_sys.c [pp_fttext]
 use warnings qw(unopened closed) ;
 close STDIN ; 
diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8
index d2ac06f0fa..747436ab27 100644
--- a/t/lib/warnings/utf8
+++ b/t/lib/warnings/utf8
@@ -34,15 +34,88 @@ Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately af
 Malformed UTF-8 character (unexpected non-continuation byte 0x73, immediately after start byte 0xf8) at - line 14.
 ########
 use warnings 'utf8';
-my $surr = chr(0xD800);
-my $fff3 = chr(0xFFFE);
-my $ffff = chr(0xFFFF);
+my $d7ff  = chr(0xD7FF);
+my $d800  = chr(0xD800);
+my $dfff  = chr(0xDFFF);
+my $e000  = chr(0xE000);
+my $fffd  = chr(0xFFFD);
+my $fffe  = chr(0xFFFE);
+my $ffff  = chr(0xFFFF);
+my $hex4  = chr(0x10000);
+my $hex5  = chr(0x100000);
+my $max   = chr(0x10FFFF);
 no warnings 'utf8';
-$surr = chr(0xD800);
-$fffe = chr(0xFFFE);
-$ffff = chr(0xFFFF);
+my $d7ff  = chr(0xD7FF);
+my $d800  = chr(0xD800);
+my $dfff  = chr(0xDFFF);
+my $e000  = chr(0xE000);
+my $fffd  = chr(0xFFFD);
+my $fffe  = chr(0xFFFE);
+my $ffff  = chr(0xFFFF);
+my $hex4  = chr(0x10000);
+my $hex5  = chr(0x100000);
+my $max   = chr(0x10FFFF);
 EXPECT
-UTF-16 surrogate 0xd800 at - line 2.
-Unicode character 0xfffe is illegal at - line 3.
-Unicode character 0xffff is illegal at - line 4.
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 7.
+Unicode character 0xffff is illegal at - line 8.
+Unicode character 0x10ffff is illegal at - line 11.
 ########
+use warnings 'utf8';
+my $d7ff  = pack("U", 0xD7FF);
+my $d800  = pack("U", 0xD800);
+my $dfff  = pack("U", 0xDFFF);
+my $e000  = pack("U", 0xE000);
+my $fffd  = pack("U", 0xFFFD);
+my $fffe  = pack("U", 0xFFFE);
+my $ffff  = pack("U", 0xFFFF);
+my $hex4  = pack("U", 0x10000);
+my $hex5  = pack("U", 0x100000);
+my $max   = pack("U", 0x10FFFF);
+no warnings 'utf8';
+my $d7ff  = pack("U", 0xD7FF);
+my $d800  = pack("U", 0xD800);
+my $dfff  = pack("U", 0xDFFF);
+my $e000  = pack("U", 0xE000);
+my $fffd  = pack("U", 0xFFFD);
+my $fffe  = pack("U", 0xFFFE);
+my $ffff  = pack("U", 0xFFFF);
+my $hex4  = pack("U", 0x10000);
+my $hex5  = pack("U", 0x100000);
+my $max   = pack("U", 0x10FFFF);
+EXPECT
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 7.
+Unicode character 0xffff is illegal at - line 8.
+Unicode character 0x10ffff is illegal at - line 11.
+########
+use warnings 'utf8';
+my $d7ff  = "\x{D7FF}";
+my $d800  = "\x{D800}";
+my $dfff  = "\x{DFFF}";
+my $e000  = "\x{E000}";
+my $fffd  = "\x{FFFD}";
+my $fffe  = "\x{FFFE}";
+my $ffff  = "\x{FFFF}";
+my $hex4  = "\x{10000}";
+my $hex5  = "\x{100000}";
+my $max   = "\x{10FFFF}";
+no warnings 'utf8';
+my $d7ff  = "\x{D7FF}";
+my $d800  = "\x{D800}";
+my $dfff  = "\x{DFFF}";
+my $e000  = "\x{E000}";
+my $fffd  = "\x{FFFD}";
+my $fffe  = "\x{FFFE}";
+my $ffff  = "\x{FFFF}";
+my $hex4  = "\x{10000}";
+my $hex5  = "\x{100000}";
+my $max   = "\x{10FFFF}";
+EXPECT
+UTF-16 surrogate 0xd800 at - line 3.
+UTF-16 surrogate 0xdfff at - line 4.
+Unicode character 0xfffe is illegal at - line 7.
+Unicode character 0xffff is illegal at - line 8.
+Unicode character 0x10ffff is illegal at - line 11.
diff --git a/t/op/inccode.t b/t/op/inccode.t
index 49ab85fbc0..1a3d3cf3e1 100644
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -10,7 +10,7 @@ BEGIN {
 use File::Spec;
 
 require "test.pl";
-plan(tests => 43);
+plan(tests => 44);
 
 my @tempfiles = ();
 
@@ -172,3 +172,11 @@ ok( ! ref $INC{'Toto.pm'},         q/  val Toto.pm isn't a ref in %INC/ );
 is( $INC{'Toto.pm'}, 'xyz',	   '  val Toto.pm is correct in %INC' );
 
 pop @INC;
+
+my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
+{
+    local @INC;
+    @INC = sub { $filename = 'seen'; return undef; };
+    eval { require $filename; };
+    is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
+}
diff --git a/t/op/lc.t b/t/op/lc.t
index 091df87dee..1fbb3e1afb 100644
--- a/t/op/lc.t
+++ b/t/op/lc.t
@@ -82,14 +82,31 @@ ok(lc($b)         eq "\x{101}\x{101}aa",  'lc');
 # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is
 # \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N.
 
-ok("\U\x{DF}ab\x{149}cd" eq "SSAB\x{2BC}NCD",
-   "multicharacter uppercase");
+# In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS,
+# and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS.
+
+if (ord("A") == 193) { # EBCDIC
+    ok("\U\x{DF}aB\x{149}cD" eq "\x{178}AB\x{2BC}NCD",
+       "multicharacter uppercase");
+} elsif (ord("A") == 65) {
+    ok("\U\x{DF}aB\x{149}cD" eq "SSAB\x{2BC}NCD",
+       "multicharacter uppercase");
+} else {
+    ok(0, "what is your encoding?");
+}
 
 # The \x{DF} is its own lowercase, ditto for \x{149}.
 # There are no single character -> multiple characters lowercase mappings.
 
-ok("\L\x{DF}AB\x{149}CD" eq "\x{DF}ab\x{149}cd",
-   "multicharacter lowercase");
+if (ord("A") == 193) { # EBCDIC
+    ok("\LaB\x{149}cD" eq "ab\x{149}cd",
+       "multicharacter lowercase");
+} elsif (ord("A") == 65) {
+    ok("\L\x{DF}aB\x{149}cD" eq "\x{DF}ab\x{149}cd",
+       "multicharacter lowercase");
+} else {
+    ok(0, "what is your encoding?");
+}
 
 # titlecase is used for \u / ucfirst.
 
diff --git a/t/op/stat.t b/t/op/stat.t
index c3bbe8362d..ad87c25b0b 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -9,7 +9,7 @@ BEGIN {
 use Config;
 use File::Spec;
 
-plan tests => 69;
+plan tests => 75;
 
 my $Perl = which_perl();
 
@@ -106,6 +106,8 @@ SKIP: {
 # Check if you are on a tmpfs of some sort.  Building in /tmp sometimes
 # has this problem.  Also building on the ClearCase VOBS filesystem may
 # cause this failure.
+# Darwins UFS doesn't have a ctime concept, and thus is
+# expected to fail this test.
 DIAG
         }
     }
@@ -376,3 +378,36 @@ unlink $tmpfile or print "# unlink failed: $!\n";
 # bug id 20011101.069
 my @r = \stat(".");
 is(scalar @r, 13,   'stat returns full 13 elements');
+
+SKIP: {
+    skip "No lstat", 2 unless $Config{d_lstat};
+
+    stat $0;
+    eval { lstat _ };
+    like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
+	'lstat _ croaks after stat' );
+    eval { -l _ };
+    like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
+	'-l _ croaks after stat' );
+
+    eval { lstat STDIN };
+    like( $@, qr/^You can't use lstat\(\) on a filehandle/,
+	'lstat FILEHANDLE croaks' );
+    eval { -l STDIN };
+    like( $@, qr/^You can't use -l on a filehandle/,
+	'-l FILEHANDLE croaks' );
+
+    # bug id 20020124.004
+    # If we have d_lstat, we should have symlink()
+    my $linkname = 'dolzero';
+    symlink $0, $linkname or die "# Can't symlink $0: $!";
+    lstat $linkname;
+    -T _;
+    eval { lstat _ };
+    like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
+	'lstat croaks after -T _' );
+    eval { -l _ };
+    like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
+	'-l _ croaks after -T _' );
+    unlink $linkname or print "# unlink $linkname failed: $!\n";
+}
diff --git a/t/run/switches.t b/t/run/switches.t
index f920f37ca7..996ad5d4c6 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -9,10 +9,11 @@ BEGIN {
 
 require "./test.pl";
 
-plan(tests => 14);
+plan(tests => 19);
 
 # due to a bug in VMS's piping which makes it impossible for runperl()
-# to emulate echo -n, these tests almost totally fail.
+# to emulate echo -n (ie. stdin always winds up with a newline), these 
+# tests almost totally fail.
 $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
 
 my $r;
@@ -169,3 +170,33 @@ SWTESTPM
     is( $r, '<swtest><foo><bar>', '-m with import parameters' );
     push @tmpfiles, $filename;
 }
+
+# Tests for -V
+
+{
+    local $TODO = '';   # these ones should work on VMS
+
+    # basic perl -V should generate significant output.
+    # we don't test actual format since it could change
+    like( runperl( switches => ['-V'] ), qr/(\n.*){20}/,
+          '-V generates 20+ lines' );
+
+    # lookup a known config var
+    chomp( $r=runperl( switches => ['-V:osname'] ) );
+    is( $r, "osname='$^O';", 'perl -V:osname');
+
+    # lookup a nonexistent var
+    chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) );
+    is( $r, "this_var_makes_switches_test_fail='UNKNOWN';",
+        'perl -V:unknown var');
+
+    # regexp lookup
+    # platforms that don't like this quoting can either skip this test
+    # or fix test.pl _quote_args
+    $r = runperl( switches => ['"-V:i\D+size"'] );
+    # should be unlike( $r, qr/^$|not found|UNKNOWN/ );
+    like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' );
+
+    # make sure each line we got matches the re
+    ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' );
+}