File Coverage

blib/lib/Test/Future/IO/Impl.pm
Criterion Covered Total %
statement 26 148 17.5
branch 0 46 0.0
condition 0 3 0.0
subroutine 9 20 45.0
pod 1 8 12.5
total 36 225 16.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
5              
6             package Test::Future::IO::Impl 0.14;
7              
8 1     1   640 use v5.14;
  1         3  
9 1     1   7 use warnings;
  1         2  
  1         29  
10              
11 1     1   5 use Test2::V0;
  1         2  
  1         15  
12 1     1   1594 use Test2::API ();
  1         3  
  1         21  
13              
14 1     1   5 use Errno qw( EINVAL EPIPE );
  1         2  
  1         169  
15 1     1   575 use IO::Handle;
  1         6162  
  1         49  
16 1     1   629 use Socket qw( pack_sockaddr_in INADDR_LOOPBACK );
  1         3724  
  1         194  
17 1     1   9 use Time::HiRes qw( time );
  1         2  
  1         10  
18              
19 1     1   161 use Exporter 'import';
  1         3  
  1         1659  
20             our @EXPORT = qw( run_tests );
21              
22             =head1 NAME
23              
24             C - acceptance tests for C implementations
25              
26             =head1 SYNOPSIS
27              
28             use Test::More;
29             use Test::Future::IO::Impl;
30              
31             use Future::IO;
32             use Future::IO::Impl::MyNewImpl;
33              
34             run_tests 'sleep';
35              
36             done_testing;
37              
38             =head1 DESCRIPTION
39              
40             This module contains a collection of acceptance tests for implementations of
41             L.
42              
43             =cut
44              
45             =head1 FUNCTIONS
46              
47             =cut
48              
49             my $errstr_EPIPE = do {
50             # On MSWin32 we don't get EPIPE, but EINVAL
51             local $! = $^O eq "MSWin32" ? EINVAL : EPIPE; "$!";
52             };
53              
54             my $errstr_ECONNREFUSED = do {
55             local $! = Errno::ECONNREFUSED; "$!";
56             };
57              
58             sub time_about(&@)
59             {
60 0     0 0   my ( $code, $want_time, $name ) = @_;
61 0           my $ctx = Test2::API::context;
62              
63 0           my $t0 = time();
64 0           $code->();
65 0           my $t1 = time();
66              
67 0           my $got_time = $t1 - $t0;
68 0 0 0       $ctx->ok(
69             $got_time >= $want_time * 0.9 && $got_time <= $want_time * 1.5, $name
70             ) or
71             $ctx->diag( sprintf "Test took %.3f seconds", $got_time );
72              
73 0           $ctx->release;
74             }
75              
76             =head2 run_tests
77              
78             run_tests @suitenames
79              
80             Runs a collection of tests against C. It is expected that the
81             caller has already loaded the specific implementation module to be tested
82             against before this function is called.
83              
84             =cut
85              
86             sub run_tests
87             {
88 0     0 1   foreach my $test ( @_ ) {
89 0 0         my $code = __PACKAGE__->can( "run_${test}_test" )
90             or die "Unrecognised test suite name $test";
91 0           __PACKAGE__->$code();
92             }
93             }
94              
95             =head1 TEST SUITES
96              
97             The following test suite names may be passed to the L function:
98              
99             =cut
100              
101             =head2 accept
102              
103             Tests the C<< Future::IO->accept >> method.
104              
105             =cut
106              
107             sub run_accept_test
108             {
109 0     0 0   require IO::Socket::INET;
110              
111 0 0         my $serversock = IO::Socket::INET->new(
112             Type => Socket::SOCK_STREAM(),
113             LocalAddr => "localhost",
114             LocalPort => 0,
115             Listen => 1,
116             ) or die "Cannot socket()/listen() - $@";
117              
118 0           $serversock->blocking( 0 );
119              
120 0           my $f = Future::IO->accept( $serversock );
121              
122             # Some platforms have assigned 127.0.0.1 here; others have left 0.0.0.0
123             # If it's still 0.0.0.0, then guess that maybe connecting to 127.0.0.1 will
124             # work
125 0 0         my $sockname = ( $serversock->sockhost ne "0.0.0.0" )
126             ? $serversock->sockname
127             : pack_sockaddr_in( $serversock->sockport, INADDR_LOOPBACK );
128              
129 0 0         my $clientsock = IO::Socket::INET->new(
130             Type => Socket::SOCK_STREAM(),
131             ) or die "Cannot socket() - $@";
132 0 0         $clientsock->connect( $sockname ) or die "Cannot connect() - $@";
133              
134 0           my $acceptedsock = $f->get;
135              
136 0           ok( $clientsock->peername eq $acceptedsock->sockname, 'Accepted socket address matches' );
137             }
138              
139             =head2 connect
140              
141             Tests the C<< Future::IO->connect >> method.
142              
143             =cut
144              
145             sub run_connect_test
146             {
147 0     0 0   require IO::Socket::INET;
148              
149 0 0         my $serversock = IO::Socket::INET->new(
150             Type => Socket::SOCK_STREAM(),
151             LocalAddr => "localhost",
152             LocalPort => 0,
153             Listen => 1,
154             ) or die "Cannot socket()/listen() - $@";
155              
156             # Some platforms have assigned 127.0.0.1 here; others have left 0.0.0.0
157             # If it's still 0.0.0.0, then guess that maybe connecting to 127.0.0.1 will
158             # work
159 0 0         my $sockname = ( $serversock->sockhost ne "0.0.0.0" )
160             ? $serversock->sockname
161             : pack_sockaddr_in( $serversock->sockport, INADDR_LOOPBACK );
162              
163             # ->connect success
164             {
165 0 0         my $clientsock = IO::Socket::INET->new(
  0            
166             Type => Socket::SOCK_STREAM(),
167             ) or die "Cannot socket() - $@";
168 0           $clientsock->blocking( 0 );
169              
170 0           my $f = Future::IO->connect( $clientsock, $sockname );
171              
172 0           $f->get;
173              
174 0           my $acceptedsock = $serversock->accept;
175 0           ok( $clientsock->peername eq $acceptedsock->sockname, 'Accepted socket address matches' );
176             }
177              
178 0           $serversock->close;
179 0           undef $serversock;
180              
181             # I really hate this, but apparently Win32 testers will fail if we don't
182             # do this.
183 0 0         sleep 1 if $^O eq "MSWin32";
184              
185             # ->connect fails
186             {
187 0 0         my $clientsock = IO::Socket::INET->new(
  0            
188             Type => Socket::SOCK_STREAM(),
189             ) or die "Cannot socket() - $@";
190 0           $clientsock->blocking( 0 );
191              
192 0           my $f = Future::IO->connect( $clientsock, $sockname );
193              
194 0           ok( !eval { $f->get; 1 }, 'Future::IO->connect fails on closed server' );
  0            
  0            
195              
196 0           is( [ $f->failure ],
197             [ "connect: $errstr_ECONNREFUSED\n", connect => $clientsock, $errstr_ECONNREFUSED ],
198             'Future::IO->connect failure' );
199             }
200             }
201              
202             =head2 sleep
203              
204             Tests the C<< Future::IO->sleep >> method.
205              
206             =cut
207              
208             sub run_sleep_test
209             {
210             time_about sub {
211 0     0     Future::IO->sleep( 0.2 )->get;
212 0     0 0   }, 0.2, 'Future::IO->sleep( 0.2 ) sleeps 0.2 seconds';
213              
214             time_about sub {
215 0     0     my $f1 = Future::IO->sleep( 0.1 );
216 0           my $f2 = Future::IO->sleep( 0.3 );
217 0           $f1->cancel;
218 0           $f2->get;
219 0           }, 0.3, 'Future::IO->sleep can be cancelled';
220              
221             {
222 0           my $f1 = Future::IO->sleep( 0.1 );
  0            
223 0           my $f2 = Future::IO->sleep( 0.3 );
224              
225 0           is( $f2->await, $f2, '->await returns Future' );
226 0           ok( $f2->is_ready, '$f2 is ready after ->await' );
227 0           ok( $f1->is_ready, '$f1 is also ready after ->await' );
228             }
229              
230             time_about sub {
231 0     0     Future::IO->alarm( time() + 0.2 )->get;
232 0           }, 0.2, 'Future::IO->alarm( now + 0.2 ) sleeps 0.2 seconds';
233             }
234              
235             =head2 sysread
236              
237             Tests the C<< Future::IO->sysread >> method.
238              
239             =cut
240              
241             sub run_sysread_test
242             {
243             # ->sysread yielding bytes
244             {
245 0 0         pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
246              
247 0           $wr->autoflush();
248 0           $wr->print( "BYTES" );
249              
250 0           my $f = Future::IO->sysread( $rd, 5 );
251              
252 0           is( scalar $f->get, "BYTES", 'Future::IO->sysread yields bytes from pipe' );
253             }
254              
255             # ->sysread yielding EOF
256             {
257 0 0   0 0   pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
  0            
258 0           $wr->close; undef $wr;
  0            
259              
260 0           my $f = Future::IO->sysread( $rd, 1 );
261              
262 0           is( [ $f->get ], [], 'Future::IO->sysread yields nothing on EOF' );
263             }
264              
265             # TODO: is there a nice portable way we can test for an IO error?
266              
267             # ->sysread can be cancelled
268             {
269 0 0         pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
  0            
  0            
270              
271 0           $wr->autoflush();
272 0           $wr->print( "BYTES" );
273              
274 0           my $f1 = Future::IO->sysread( $rd, 3 );
275 0           my $f2 = Future::IO->sysread( $rd, 3 );
276              
277 0           $f1->cancel;
278              
279 0           is( scalar $f2->get, "BYT", 'Future::IO->sysread can be cancelled' );
280             }
281             }
282              
283             =head2 syswrite
284              
285             Tests the C<< Future::IO->syswrite >> method.
286              
287             =cut
288              
289             sub run_syswrite_test
290             {
291             # ->syswrite success
292             {
293 0 0   0 0   pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
  0            
294              
295 0           my $f = Future::IO->syswrite( $wr, "BYTES" );
296              
297 0           is( scalar $f->get, 5, 'Future::IO->syswrite yields written count' );
298              
299 0           $rd->read( my $buf, 5 );
300 0           is( $buf, "BYTES", 'Future::IO->syswrite wrote bytes' );
301             }
302              
303             # ->syswrite yielding EAGAIN
304             SKIP: {
305 0 0         $^O eq "MSWin32" and skip "MSWin32 doesn't do EAGAIN properly", 2;
306              
307 0 0         pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
308 0           $wr->blocking( 0 );
309              
310             # Attempt to fill the pipe
311 0           $wr->syswrite( "X" x 4096 ) for 1..256;
312              
313 0           my $f = Future::IO->syswrite( $wr, "more" );
314              
315 0           ok( !$f->is_ready, '$f is still pending' );
316              
317             # Now make some space
318 0           $rd->read( my $buf, 4096 );
319              
320 0           is( scalar $f->get, 4, 'Future::IO->syswrite yields written count' );
321             }
322              
323             # ->syswrite yielding EPIPE
324             {
325 0 0         pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
  0            
326 0           $rd->close; undef $rd;
  0            
327              
328 0           local $SIG{PIPE} = 'IGNORE';
329              
330 0           my $f = Future::IO->syswrite( $wr, "BYTES" );
331              
332 0           ok( !eval { $f->get }, 'Future::IO->syswrite fails on EPIPE' );
  0            
333              
334 0           is( [ $f->failure ],
335             [ "syswrite: $errstr_EPIPE\n", syswrite => $wr, $errstr_EPIPE ],
336             'Future::IO->syswrite failure for EPIPE' );
337             }
338              
339             # ->syswrite can be cancelled
340             {
341 0 0         pipe my ( $rd, $wr ) or die "Cannot pipe() - $!";
  0            
  0            
342              
343 0           my $f1 = Future::IO->syswrite( $wr, "BY" );
344 0           my $f2 = Future::IO->syswrite( $wr, "TES" );
345              
346 0           $f1->cancel;
347              
348 0           is( scalar $f2->get, 3, 'Future::IO->syswrite after cancelled one still works' );
349              
350 0           $rd->read( my $buf, 3 );
351 0           is( $buf, "TES", 'Cancelled Future::IO->syswrite did not write bytes' );
352             }
353             }
354              
355             =head2 waitpid
356              
357             Tests the C<< Future::IO->waitpid >> method.
358              
359             =cut
360              
361             sub run_waitpid_test
362             {
363             # pre-exit
364             {
365 0 0         defined( my $pid = fork() ) or die "Unable to fork() - $!";
366 0 0         if( $pid == 0 ) {
367             # child
368 0           exit 3;
369             }
370              
371 0           Time::HiRes::sleep 0.1;
372              
373 0           my $f = Future::IO->waitpid( $pid );
374 0           is( scalar $f->get, ( 3 << 8 ), 'Future::IO->waitpid yields child wait status for pre-exit' );
375             }
376              
377             # post-exit
378             {
379 0 0   0 0   defined( my $pid = fork() ) or die "Unable to fork() - $!";
  0            
  0            
380 0 0         if( $pid == 0 ) {
381             # child
382 0           Time::HiRes::sleep 0.1;
383 0           exit 4;
384             }
385              
386 0           my $f = Future::IO->waitpid( $pid );
387 0           is( scalar $f->get, ( 4 << 8 ), 'Future::IO->waitpid yields child wait status for post-exit' );
388             }
389             }
390              
391             =head1 AUTHOR
392              
393             Paul Evans
394              
395             =cut
396              
397             0x55AA;