In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/2fb0e7e4fee5700b0271b577a2e729301b7f483e?hp=3e09f0e17830742b74b979b35847f68f775468cd>
- Log -----------------------------------------------------------------
commit 2fb0e7e4fee5700b0271b577a2e729301b7f483e
Author: Tony Cook <t...@develop-help.com>
Date: Wed Sep 20 13:44:59 2017 +1000
prevent pod/builttoc spewing bad UTF-8 errors under PERL_UNICODE
M pod/buildtoc
commit e91a8fe59e04acc5aa33b600b132452b2e7e6165
Author: Tony Cook <t...@develop-help.com>
Date: Wed Sep 20 13:27:11 2017 +1000
avoid sysread()/syswrite() warnings from the default :utf8 from PERL_UNICODE
In a UTF-8 locale, if the PERL_UNICODE environment variable is set,
perl may add a :utf8 layer.
v5.23.1-197-gfb10a8a deprecated using sysread(), syswrite() etc on such
handles, which meant that a test run under PERL_UNICODE could produce
a significant number of deprecation warnings.
Prevent those warnings, typically by binmode(), but in one case by
disabling the warning.
M ext/Fcntl/t/fcntl.t
M ext/Fcntl/t/syslfs.t
M lib/File/Copy.t
M t/io/socket.t
M t/io/through.t
M t/op/gmagic.t
M t/op/readline.t
M t/op/sysio.t
M t/op/taint.t
-----------------------------------------------------------------------
Summary of changes:
ext/Fcntl/t/fcntl.t | 2 ++
ext/Fcntl/t/syslfs.t | 5 ++++-
lib/File/Copy.t | 7 ++++++-
pod/buildtoc | 2 +-
t/io/socket.t | 4 ++--
t/io/through.t | 9 +++++++--
t/op/gmagic.t | 2 ++
t/op/readline.t | 5 ++++-
t/op/sysio.t | 42 ++++++++++++++++++++++++++++--------------
t/op/taint.t | 2 +-
10 files changed, 57 insertions(+), 23 deletions(-)
diff --git a/ext/Fcntl/t/fcntl.t b/ext/Fcntl/t/fcntl.t
index b689f781cc..af649b52ce 100644
--- a/ext/Fcntl/t/fcntl.t
+++ b/ext/Fcntl/t/fcntl.t
@@ -12,11 +12,13 @@ print "1..7\n";
print "ok 1\n";
if (sysopen(my $wo, "fcntl$$", O_WRONLY|O_CREAT)) {
+ binmode $wo;
print "ok 2\n";
if (syswrite($wo, "foo") == 3) {
print "ok 3\n";
close($wo);
if (sysopen(my $ro, "fcntl$$", O_RDONLY)) {
+ binmode $ro;
print "ok 4\n";
if (sysread($ro, my $read, 3)) {
print "ok 5\n";
diff --git a/ext/Fcntl/t/syslfs.t b/ext/Fcntl/t/syslfs.t
index 00e072ba60..7537d54876 100644
--- a/ext/Fcntl/t/syslfs.t
+++ b/ext/Fcntl/t/syslfs.t
@@ -72,6 +72,7 @@ if ($^O eq 'unicos') {
sysopen(BIG, $big1, O_WRONLY|O_CREAT|O_TRUNC) or
die "sysopen $big1 failed: $!";
+binmode BIG;
sysseek(BIG, 1_000_000, SEEK_SET) or
die "sysseek $big1 failed: $!";
syswrite(BIG, "big") or
@@ -85,6 +86,7 @@ print "# s1 = @s1\n";
sysopen(BIG, $big2, O_WRONLY|O_CREAT|O_TRUNC) or
die "sysopen $big2 failed: $!";
+binmode BIG;
sysseek(BIG, 2_000_000, SEEK_SET) or
die "sysseek $big2 failed: $!";
syswrite(BIG, "big") or
@@ -127,6 +129,7 @@ EOF
sysopen(BIG, $big0, O_WRONLY|O_CREAT|O_TRUNC) or
die "sysopen $big0 failed: $!";
+binmode BIG;
my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
$sysseek = 'undef' unless defined $sysseek;
@@ -192,7 +195,7 @@ is(-e $big0, 1);
is(-f $big0, 1);
sysopen(BIG, $big0, O_RDONLY) or die "sysopen failed: $!";
-
+binmode BIG;
offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index 05590b262f..25f340d1c0 100644
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -66,12 +66,14 @@ for my $cross_partition_test (0..1) {
unlink "copy-$$" or die "unlink: $!";
open(F, "<", "file-$$");
+ binmode F;
copy(*F, "copy-$$");
- open(R, "<", "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
+ open(R, "<:raw", "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
is $foo, "ok\n", 'copy(*F, fn): same contents';
unlink "copy-$$" or die "unlink: $!";
open(F, "<", "file-$$");
+ binmode F;
copy(\*F, "copy-$$");
close(F) or die "close: $!";
open(R, "<", "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
@@ -345,6 +347,7 @@ SKIP: {
chmod $c_perm3 => $copy6 or die $!;
open my $fh => "<", $src or die $!;
+ binmode $fh;
copy ($src, $copy1);
copy ($fh, $copy2);
@@ -465,6 +468,8 @@ SKIP: {
open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"';
open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)';
+ binmode $IN;
+ binmode $OUT;
ok(copy($IN, $OUT), "copy pipe to another");
close($OUT);
diff --git a/pod/buildtoc b/pod/buildtoc
index 8837f8e388..9c66e93792 100644
--- a/pod/buildtoc
+++ b/pod/buildtoc
@@ -186,7 +186,7 @@ my ($inhead1, $inhead2, $initem);
sub podset {
my ($pod, $file) = @_;
- open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";
+ open my $fh, '<:raw', $file or my_die "Can't open file '$file' for $pod:
$!";
local *_;
my $found_pod;
diff --git a/t/io/socket.t b/t/io/socket.t
index 0629c64952..d1251d3a9e 100644
--- a/t/io/socket.t
+++ b/t/io/socket.t
@@ -70,7 +70,7 @@ SKIP: {
"make accept tcp socket");
ok(my $addr = accept($accept, $serv), "accept() works")
or diag "accept error: $!";
-
+ binmode $accept;
my $sent_total = 0;
while ($sent_total < length $send_data) {
my $sent = send($accept, substr($send_data, $sent_total), 0);
@@ -98,7 +98,7 @@ SKIP: {
ok_child(connect($child, $bind_name), "connect() works")
or diag "connect error: $!";
-
+ binmode $child;
my $buf;
my $recv_peer = recv($child, $buf, 1000, 0);
{
diff --git a/t/io/through.t b/t/io/through.t
index 65a64bbcaf..3d42a2594e 100644
--- a/t/io/through.t
+++ b/t/io/through.t
@@ -10,6 +10,8 @@ BEGIN {
use strict;
+++$|;
+
my $Perl = which_perl();
my $data = <<'EOD';
@@ -35,8 +37,8 @@ $c += 6; # Tests with sleep()...
print "1..$c\n";
-my $set_out = '';
-$set_out = "binmode STDOUT, ':crlf'"
+my $set_out = "binmode STDOUT, ':raw'";
+$set_out = "binmode STDOUT, ':raw:crlf'"
if defined $main::use_crlf && $main::use_crlf == 1;
sub testread ($$$$$$$) {
@@ -89,6 +91,7 @@ sub testpipe ($$$$$$) {
} else {
die "Unrecognized write: '$how_w'";
}
+ binmode $fh; # remove any :utf8 set by PERL_UNICODE
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why");
@@ -101,6 +104,7 @@ sub testfile ($$$$$$) {
my $filename = tempfile();
open my $fh, '>', $filename or die "open: > $filename: $!";
select $fh;
+ binmode $fh; # remove any :utf8 set by PERL_UNICODE
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
if ($how_w eq 'print') { # AUTOFLUSH???
@@ -116,6 +120,7 @@ sub testfile ($$$$$$) {
}
close $fh or die "close: $!";
open $fh, '<', $filename or die "open: < $filename: $!";
+ binmode $fh;
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why");
diff --git a/t/op/gmagic.t b/t/op/gmagic.t
index 1226e3a785..5b2845bab4 100644
--- a/t/op/gmagic.t
+++ b/t/op/gmagic.t
@@ -64,11 +64,13 @@ expected_tie_calls(tied $c, 1, 2, 'chomping a ref');
{
my $outfile = tempfile();
open my $h, ">$outfile" or die "$0 cannot close $outfile: $!";
+ binmode $h;
print $h "bar\n";
close $h or die "$0 cannot close $outfile: $!";
$c = *foo; # 1 write
open $h, $outfile;
+ binmode $h;
sysread $h, $c, 3, 7; # 1 read; 1 write
is $c, "*main::bar", 'what sysread wrote'; # 1 read
expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf');
diff --git a/t/op/readline.t b/t/op/readline.t
index 2ee153442c..c2727fe829 100644
--- a/t/op/readline.t
+++ b/t/op/readline.t
@@ -63,7 +63,7 @@ foreach my $l (1, 21) {
use strict;
-open F, '.' and sysread F, $_, 1;
+open F, '.' and binmode F and sysread F, $_, 1;
my $err = $! + 0;
close F;
@@ -148,6 +148,9 @@ SKIP: {
skip( 2, 'The pipe function is unimplemented' );
}
+ binmode $out;
+ binmode $in;
+
# Make the pipe autoflushing
{
my $old_fh = select $out;
diff --git a/t/op/sysio.t b/t/op/sysio.t
index b95def0ecb..ebcf821d37 100644
--- a/t/op/sysio.t
+++ b/t/op/sysio.t
@@ -9,6 +9,7 @@ BEGIN {
plan tests => 48;
open(I, 'op/sysio.t') || die "sysio.t: cannot find myself: $!";
+binmode I;
$reopen = ($^O eq 'VMS' ||
$^O eq 'os2' ||
@@ -55,6 +56,7 @@ is($a, "#!.\0\0erl");
$outfile = tempfile();
open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
+binmode O;
select(O); $|=1; select(STDOUT);
@@ -82,6 +84,7 @@ syswrite(O, $x, 1, 3);
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
ok(!-s $outfile);
@@ -96,6 +99,7 @@ is($x, 'abc');
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
ok(!-s $outfile);
@@ -109,6 +113,7 @@ is($x, 'abc');
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
ok(!-s $outfile);
@@ -121,6 +126,7 @@ is($x, 'abc');
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
ok(!-s $outfile);
@@ -141,6 +147,7 @@ is($a, "#!.\0\0erl");
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
is(-s $outfile, 2);
@@ -153,6 +160,7 @@ is($a, "#!.\0\0erl");
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
is(-s $outfile, 4);
@@ -165,6 +173,7 @@ is($a, "#!.\0\0erl");
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
is(-s $outfile, 7);
@@ -177,12 +186,14 @@ is($x, "abc");
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+ binmode O;
}
is(-s $outfile, 10);
close(O);
open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
+binmode I;
$b = 'xyz';
@@ -211,26 +222,29 @@ close(I);
unlink_all $outfile;
# Check that utf8 IO doesn't upgrade the scalar
-open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
-# Will skip harmlessly on stdioperl
-eval {binmode STDOUT, ":utf8"};
-die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
+{
+ no warnings 'deprecated';
+ open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
+ # Will skip harmlessly on stdioperl
+ eval {binmode STDOUT, ":utf8"};
+ die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
-# y diaresis is \w when UTF8
-$a = chr 255;
+ # y diaresis is \w when UTF8
+ $a = chr 255;
-unlike($a, qr/\w/);
+ unlike($a, qr/\w/);
-syswrite I, $a;
+ syswrite I, $a;
-# Should not be upgraded as a side effect of syswrite.
-unlike($a, qr/\w/);
+ # Should not be upgraded as a side effect of syswrite.
+ unlike($a, qr/\w/);
-# This should work
-eval {syswrite I, 2;};
-is($@, '');
+ # This should work
+ eval {syswrite I, 2;};
+ is($@, '');
-close(I);
+ close(I);
+}
unlink_all $outfile;
chdir('..');
diff --git a/t/op/taint.t b/t/op/taint.t
index 0988c7e0e0..1c6eceaf8a 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -1065,7 +1065,7 @@ SKIP: {
# Reading from a file should be tainted
{
ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!");
-
+ binmode $fh;
my $block;
sysread($fh, $block, 100);
my $line = <$fh>;
--
Perl5 Master Repository
