diff options
Diffstat (limited to 'gnu/usr.bin/perl/dist/IO')
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/ChangeLog | 23 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/Makefile.PL | 59 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/README | 1 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/t/cachepropagate-tcp.t | 16 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/t/gh17447.t | 29 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/IO/t/io_getline.t | 117 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/dist/IO/t/io_udp.t | 36 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/dist/IO/t/io_unix.t | 24 |
8 files changed, 267 insertions, 38 deletions
diff --git a/gnu/usr.bin/perl/dist/IO/ChangeLog b/gnu/usr.bin/perl/dist/IO/ChangeLog index 4101627c23e..5ed2b464579 100644 --- a/gnu/usr.bin/perl/dist/IO/ChangeLog +++ b/gnu/usr.bin/perl/dist/IO/ChangeLog @@ -1,3 +1,26 @@ +IO 1.42 - Jan 20 2020 - Todd Rinaldo + * Point IO support to perl/perl5 not dual-life/IO + +IO 1.41 - Jan 20 2020 - Todd Rinaldo + * Switch pre-release testing to github actions. + * Update MANIFEST with new test. + +IO 1.41_50 -- Dec 16 2019 - Ricardo Signes + * [ TRIAL RELEASE ] + * Loading IO is now threadsafe, avoiding the core bug reported as GH #14816. + Implemented by converting getline() and getlines() to XS code. + +IO 1.41 -- Dec 12 2019 - Ricardo Signes + * [ TRIAL RELEASE ] + * import the latest from blead, so some changes may be in intermediate + versions found only in releases of perl5 + * (perl #133936) make send() a bit saner + * (perl #133936) document differences between IO::Socket::* and builtin + * (perl #133936) ensure TO is honoured for UDP $sock->send() + * Remove vestiges of mpeix support (removed in 5.17.x) + * Documentation formatting fixes + * Improve isolation of tests as they run + IO 1.38 -- Apr 19 2018 - Todd Rinaldo * Remove pre 5.8 logic from code base. * Bump all IO modules to 1.38 and set required Perl to 5.8.1 diff --git a/gnu/usr.bin/perl/dist/IO/Makefile.PL b/gnu/usr.bin/perl/dist/IO/Makefile.PL index 0fd03318711..327bb275c57 100644 --- a/gnu/usr.bin/perl/dist/IO/Makefile.PL +++ b/gnu/usr.bin/perl/dist/IO/Makefile.PL @@ -9,35 +9,44 @@ my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV; my $define = ""; -unless ($PERL_CORE or exists $Config{'i_poll'}) { - my @inc = split(/\s+/, join(" ", $Config{'usrinc'}, $Config{'incpth'}, $Config{'locincpth'})); - foreach $path (@inc) { - if (-f $path . "/poll.h") { - $define .= "-DI_POLL "; - last; +unless ( $PERL_CORE or exists $Config{'i_poll'} ) { + my @inc = split( /\s+/, join( " ", $Config{'usrinc'}, $Config{'incpth'}, $Config{'locincpth'} ) ); + foreach $path (@inc) { + if ( -f $path . "/poll.h" ) { + $define .= "-DI_POLL "; + last; + } } - } } #--- Write the Makefile WriteMakefile( - VERSION_FROM => "IO.pm", - NAME => "IO", - OBJECT => '$(O_FILES)', - ABSTRACT => 'Perl core IO modules', - AUTHOR => 'Graham Barr <gbarr@cpan.org>', - PREREQ_PM => { - 'Test::More' => 0, - 'File::Temp' => '0.15', - }, - ( $PERL_CORE - ? () - : ( - INSTALLDIRS => ($] < 5.011 ? 'perl' : 'site'), - clean => {FILES => 'typemap'}, - ) - ), - ($define ? (DEFINE => $define) : ()), - ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()), + VERSION_FROM => "IO.pm", + NAME => "IO", + OBJECT => '$(O_FILES)', + ABSTRACT => 'Perl core IO modules', + AUTHOR => 'Perl5 Porters <perl5-porters@perl.org>', + PREREQ_PM => { + 'Test::More' => 0, + 'File::Temp' => '0.15', + }, + ( + $PERL_CORE + ? () + : ( + INSTALLDIRS => ( $] < 5.011 ? 'perl' : 'site' ), + clean => { FILES => 'typemap' }, + ) + ), + ( $define ? ( DEFINE => $define ) : () ), + ( ( ExtUtils::MakeMaker->VERSION() gt '6.30' ) ? ( 'LICENSE' => 'perl' ) : () ), + META_MERGE => { + resources => { + license => 'http://dev.perl.org/licenses/', + bugtracker => 'https://github.com/perl/perl5/issues', + repository => 'https://github.com/Perl/perl5/tree/blead/dist/IO', + MailingList => 'http://lists.perl.org/list/perl5-porters.html', + }, + }, ); diff --git a/gnu/usr.bin/perl/dist/IO/README b/gnu/usr.bin/perl/dist/IO/README index 3783750c896..5457a632c2a 100644 --- a/gnu/usr.bin/perl/dist/IO/README +++ b/gnu/usr.bin/perl/dist/IO/README @@ -24,4 +24,3 @@ To build, test and install this distribution type: Share and Enjoy! Graham Barr <gbarr@pobox.com> - diff --git a/gnu/usr.bin/perl/dist/IO/t/cachepropagate-tcp.t b/gnu/usr.bin/perl/dist/IO/t/cachepropagate-tcp.t index b9104bba090..f59c1339348 100644 --- a/gnu/usr.bin/perl/dist/IO/t/cachepropagate-tcp.t +++ b/gnu/usr.bin/perl/dist/IO/t/cachepropagate-tcp.t @@ -9,7 +9,7 @@ use Socket; use Test::More; use Config; -plan tests => 8; +plan tests => 9; my $listener = IO::Socket::INET->new(Listen => 1, LocalAddr => '127.0.0.1', @@ -26,7 +26,7 @@ my $s = $listener->socktype(); ok(defined($s), 'type defined'); SKIP: { - skip "fork not available", 4 + skip "fork not available", 5 unless $Config{d_fork} || $Config{d_pseudofork}; my $cpid = fork(); @@ -36,6 +36,14 @@ SKIP: { my $connector = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp'); + if ($connector) { + my $buf; + # wait for parent to close its end + $connector->read($buf, 1); + } + else { + diag "child failed to connect to parent: $@"; + } exit(0); } else {; ok(defined($cpid), 'spawned a child'); @@ -43,6 +51,9 @@ SKIP: { my $new = $listener->accept(); + ok($new, "got a socket from accept") + or diag "accept failed: $@"; + is($new->sockdomain(), $d, 'domain match'); SKIP: { skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL }); @@ -52,6 +63,7 @@ SKIP: { skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE }); is($new->socktype(), $s, 'type match'); } + $new->close; wait(); } diff --git a/gnu/usr.bin/perl/dist/IO/t/gh17447.t b/gnu/usr.bin/perl/dist/IO/t/gh17447.t new file mode 100644 index 00000000000..bcdec4b0f92 --- /dev/null +++ b/gnu/usr.bin/perl/dist/IO/t/gh17447.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# Regression test for https://github.com/Perl/perl5/issues/17447 + +use strict; +use warnings; + +use Test::More tests => 2; + +use IO::Select; +use IO::Handle; + +pipe( my $rd, my $wr ) or die "Cannot pipe() - $!"; +binmode $rd; +binmode $wr; +$wr->syswrite("data\n"); + +my $select = IO::Select->new(); +$select->add($rd); + +is( scalar $select->handles, 1, '$select has 1 handle' ); + +# close first, then remove afterwards +$rd->close; +$select->remove($rd); + +is( scalar $select->handles, 0, '$select has 0 handles' ); + +exit; diff --git a/gnu/usr.bin/perl/dist/IO/t/io_getline.t b/gnu/usr.bin/perl/dist/IO/t/io_getline.t new file mode 100644 index 00000000000..22361e6b7e8 --- /dev/null +++ b/gnu/usr.bin/perl/dist/IO/t/io_getline.t @@ -0,0 +1,117 @@ +#!./perl -w +use strict; + +use Test::More tests => 37; + +my $File = 'README'; + +use IO::File; + +my $io = IO::File->new($File); +isa_ok($io, 'IO::File', "Opening $File"); + +my $line = $io->getline(); +like($line, qr/^This is the/, "Read first line"); + +my ($list, $context) = $io->getline(); +is($list, "\n", "Read second line"); +is($context, undef, "Did not read third line with getline() in list context"); + +$line = $io->getline(); +like($line, qr/^This distribution/, "Read third line"); + +my @lines = $io->getlines(); +cmp_ok(@lines, '>', 3, "getlines reads lots of lines"); +like($lines[-2], qr/^Share and Enjoy!/, "Share and Enjoy!"); + +$line = $io->getline(); +is($line, undef, "geline reads no more at EOF"); + +@lines = $io->getlines(); +is(@lines, 0, "gelines reads no more at EOF"); + +# And again +$io = IO::File->new($File); +isa_ok($io, 'IO::File', "Opening $File"); + +$line = $io->getline(); +like($line, qr/^This is the/, "Read first line again"); + +is(eval { + $line = $io->getline("Boom"); + 1; + }, undef, "eval caught an exception"); +like($@, qr/^usage.*getline\(\) at .*\bio_getline\.t line /, 'getline usage'); +like($line, qr/^This is the/, '$line unchanged'); + +is(eval { + ($list, $context) = $io->getlines("Boom"); + 1; + }, undef, "eval caught an exception"); +like($@, qr/^usage.*getlines\(\) at .*\bio_getline\.t line /, 'getlines usage'); +is($list, "\n", '$list unchanged'); + +is(eval { + $line = $io->getlines(); + 1; + }, undef, "eval caught an exception"); +like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /, + 'getlines in scalar context croaks'); +like($line, qr/^This is the/, '$line unchanged'); + +is(eval { + $io->getlines(); + 1; + }, undef, "eval caught an exception"); +like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /, + 'getlines in void context croaks'); +like($line, qr/^This is the/, '$line unchanged'); + +($list, $context) = $io->getlines(); +is($list, "\n", "Read second line"); +like($context, qr/^This distribution/, "Read third line"); + +{ + package TiedHandle; + + sub TIEHANDLE { + return bless ["Tick", "tick", "tick"]; + } + + sub READLINE { + my $fh = shift; + die "Boom!" + unless @$fh; + return shift @$fh + unless wantarray; + return splice @$fh; + } +} + +tie *FH, 'TiedHandle'; + +is(*FH->getline(), "Tick", "tied handle read works"); +($list, $context) = *FH->getline(); +is($list, "tick", "tied handle read works in list context 0"); +is($context, undef, "tied handle read works in list context 1"); +is(*FH->getline(), "tick", "tied handle read works again"); +is(eval { + $line = *FH->getline(); + 1; + }, undef, "eval on tied handle caught an exception"); +like($@, qr/^Boom!/, + 'getline on tied handle propagates exception'); +like($line, qr/^This is the/, '$line unchanged'); + +tie *FH, 'TiedHandle'; + +($list, $context) = *FH->getlines(); +is($list, "Tick", "tied handle read works in list context 2"); +is($context, "tick", "tied handle read works in list context 3"); +is(eval { + ($list, $context) = *FH->getlines(); + 1; + }, undef, "eval on tied handle caught an exception again"); +like($@, qr/^Boom!/, + 'getlines on tied handle propagates exception'); +is($list, "Tick", '$line unchanged'); diff --git a/gnu/usr.bin/perl/dist/IO/t/io_udp.t b/gnu/usr.bin/perl/dist/IO/t/io_udp.t index d7e95a88298..2adc6a4a692 100755 --- a/gnu/usr.bin/perl/dist/IO/t/io_udp.t +++ b/gnu/usr.bin/perl/dist/IO/t/io_udp.t @@ -15,6 +15,8 @@ BEGIN { skip_all($reason) if $reason; } +use strict; + sub compare_addr { no utf8; my $a = shift; @@ -36,18 +38,18 @@ sub compare_addr { "$a[0]$a[1]" eq "$b[0]$b[1]"; } -plan(7); +plan(15); watchdog(15); use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') +my $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; ok(1); -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') +my $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; ok(1); @@ -56,6 +58,7 @@ $udpa->send('BORK', 0, $udpb->sockname); ok(compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname')); +my $buf; my $where = $udpb->recv($buf="", 4); is($buf, 'BORK'); @@ -69,7 +72,32 @@ $udpb->send('FOObar', @xtra); $udpa->recv($buf="", 6); is($buf, 'FOObar'); -ok(! $udpa->connected); +{ + # check the TO parameter passed to $sock->send() is honoured for UDP sockets + # [perl #133936] + my $udpc = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; + pass("created C socket"); + + ok($udpc->connect($udpa->sockname), "connect C to A"); + + ok($udpc->connected, "connected a UDP socket"); + + ok($udpc->send("fromctoa"), "send to a"); + + ok($udpa->recv($buf = "", 8), "recv it"); + is($buf, "fromctoa", "check value received"); + + SKIP: + { + $^O eq "linux" + or skip "This is non-portable, known to 'work' on Linux", 3; + ok($udpc->send("fromctob", 0, $udpb->sockname), "send to non-connected socket"); + ok($udpb->recv($buf = "", 8), "recv it"); + is($buf, "fromctob", "check value received"); + } +} exit(0); diff --git a/gnu/usr.bin/perl/dist/IO/t/io_unix.t b/gnu/usr.bin/perl/dist/IO/t/io_unix.t index a6cd05c898f..93cddfb7c69 100755 --- a/gnu/usr.bin/perl/dist/IO/t/io_unix.t +++ b/gnu/usr.bin/perl/dist/IO/t/io_unix.t @@ -1,9 +1,16 @@ #!./perl use Config; +use IO::Socket; BEGIN { my $reason; + my $can_fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) { $reason = 'Socket extension unavailable'; } @@ -11,18 +18,25 @@ BEGIN { $reason = 'IO extension unavailable'; } elsif ($^O eq 'os2') { - require IO::Socket; - eval {IO::Socket::pack_sockaddr_un('/foo/bar') || 1} or $@ !~ /not implemented/ or $reason = 'compiled without TCP/IP stack v4'; } - elsif ($^O =~ m/^(?:qnx|nto|vos|MSWin32)$/ ) { + elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) { $reason = "UNIX domain sockets not implemented on $^O"; } - elsif (! $Config{'d_fork'}) { + elsif (! $can_fork) { $reason = 'no fork'; } + elsif ($^O eq 'MSWin32') { + if ($ENV{CONTINUOUS_INTEGRATION}) { + $reason = 'Skipping on Windows CI, see gh17575 and gh17429'; + } else { + $reason = "AF_UNIX unavailable or disabled on this platform" + unless eval { socket(my $sock, PF_UNIX, SOCK_STREAM, 0) }; + } + } + if ($reason) { print "1..0 # Skip: $reason\n"; exit 0; @@ -50,8 +64,6 @@ unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; $| = 1; print "1..5\n"; -use IO::Socket; - $listen = IO::Socket::UNIX->new(Local => $PATH, Listen => 0); # Sometimes UNIX filesystems are mounted for security reasons |