File Coverage

blib/lib/Future/IO/ImplBase.pm
Criterion Covered Total %
statement 51 62 82.2
branch 11 20 55.0
condition 2 11 18.1
subroutine 15 17 88.2
pod 6 6 100.0
total 85 116 73.2


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, 2019-2021 -- leonerd@leonerd.org.uk
5              
6             package Future::IO::ImplBase 0.13;
7              
8 13     13   173 use v5.14;
  13         46  
9 13     13   83 use warnings;
  13         21  
  13         540  
10              
11 13     13   3006 use Errno qw( EAGAIN EWOULDBLOCK EINPROGRESS );
  13         8487  
  13         1261  
12 13     13   4681 use Socket qw( SOL_SOCKET SO_ERROR );
  13         29886  
  13         1647  
13              
14             # connect() yields EWOULDBLOCK on MSWin32
15 13     13   94 use constant CONNECT_EWOULDBLOCK => ( $^O eq "MSWin32" );
  13         36  
  13         1090  
16              
17 13     13   78 use constant HAVE_MULTIPLE_FILEHANDLES => 1;
  13         97  
  13         907  
18              
19             =head1 NAME
20              
21             C - base class for C implementations
22              
23             =head1 DESCRIPTION
24              
25             This package provides a few utility methods that may help writing actual
26             L implementation classes. It is entirely optional; implementations
27             are not required to use it.
28              
29             =cut
30              
31             =head1 CLASS METHODS
32              
33             =cut
34              
35             =head2 APPLY
36              
37             __PACKAGE__->APPLY
38              
39             Attempts to set the value of the C<$Future::IO::IMPL> variable to the name of
40             the calling package.
41              
42             =cut
43              
44             sub APPLY
45             {
46 0     0 1 0 my $pkg = shift;
47              
48 13     13   174 no warnings 'once';
  13         35  
  13         8660  
49 0 0 0     0 ( $Future::IO::IMPL //= $pkg ) eq $pkg or
50             warn "Unable to set Future::IO implementation to $pkg".
51             " as it is already $Future::IO::IMPL\n";
52             }
53              
54             =head1 DEFAULT METHODS
55              
56             These methods are provided based on lower-level functionallity that the
57             implementing class should provide.
58              
59             =cut
60              
61             =head2 accept
62              
63             Implemented by wrapping C, as L uses.
64              
65             =cut
66              
67             sub accept
68             {
69 1     1 1 3 my $self = shift;
70 1         5 my ( $fh ) = @_;
71              
72             return $self->ready_for_read( $fh )->then( sub {
73 1     1   128 my $accepted = $fh->accept;
74 1 50       148 if( $accepted ) {
75 1         12 return Future->done( $accepted );
76             }
77             else {
78 0         0 return Future->fail( "accept: $!\n", accept => $fh, $! );
79             }
80 1         5 } );
81             }
82              
83             =head2 alarm
84              
85             Implemented by wrapping C.
86              
87             =cut
88              
89             sub alarm
90             {
91 0     0 1 0 my $self = shift;
92 0         0 my ( $time ) = @_;
93              
94 0         0 return $self->sleep( $time - Time::HiRes::time() );
95             }
96              
97             =head2 connect
98              
99             Implemented by wrapping C, as L uses.
100              
101             =cut
102              
103             sub connect
104             {
105 2     2 1 4 my $self = shift;
106 2         6 my ( $fh, $name ) = @_;
107              
108             # We can't use IO::Socket->connect here because
109             # https://github.com/Perl/perl5/issues/19326
110              
111 2         139 my $ret = CORE::connect( $fh, $name );
112 2         19 my $errno = $!;
113              
114 2 50 50     15 if( $ret ) {
    50          
115 0         0 return Future->done;
116             }
117             elsif( $errno != EINPROGRESS and !CONNECT_EWOULDBLOCK || $errno != EWOULDBLOCK ) {
118 0         0 return Future->fail( "connect: $errno\n", connect => $fh, $errno );
119             }
120              
121             # not synchronous result
122              
123             return $self->ready_for_write( $fh )->then( sub {
124 2     2   198 $errno = $fh->getsockopt( SOL_SOCKET, SO_ERROR );
125              
126 2 100       54 if( $errno ) {
127 1         3 $! = $errno;
128 1         18 return Future->fail( "connect: $!\n", connect => $fh, $! );
129             }
130              
131 1         12 return Future->done;
132 2         12 } );
133             }
134              
135             =head2 sysread
136              
137             Requires a lower-level method
138              
139             $f = $class->ready_for_read( $fh )
140              
141             which should return a Future that completes when the given filehandle may be
142             ready for reading.
143              
144             =cut
145              
146             sub sysread
147             {
148 15     15 1 31 my $self = shift;
149 15         65 my ( $fh, $length ) = @_;
150              
151             $self->ready_for_read( $fh )->then( sub {
152 13     13   1075 my $ret = $fh->sysread( my $buf, $length );
153 13 100 0     246 if( $ret ) {
    50          
    0          
154 10         76 return Future->done( $buf );
155             }
156             elsif( defined $ret ) {
157             # EOF
158 3         14 return Future->done();
159             }
160             elsif( $! == EAGAIN or $! == EWOULDBLOCK ) {
161             # Try again
162 0         0 return $self->sysread( $fh, $length );
163             }
164             else {
165 0         0 return Future->fail( "sysread: $!\n", sysread => $fh, $! );
166             }
167 15         53 });
168             }
169              
170             =head2 syswrite
171              
172             Requires a lower-level method
173              
174             $f = $class->ready_for_write( $fh )
175              
176             which should return a Future that completes when the given filehandle may be
177             ready for writing.
178              
179             =cut
180              
181             sub syswrite
182             {
183 8     8 1 16 my $self = shift;
184 8         23 my ( $fh, $data ) = @_;
185              
186             return $self->ready_for_write( $fh )->then( sub {
187 7     7   673 my $len = $fh->syswrite( $data );
188 7 100 33     215 if( defined $len ) {
    50          
189 6         56 return Future->done( $len );
190             }
191             elsif( $! == EAGAIN or $! == EWOULDBLOCK ) {
192             # Try again
193 0         0 return $self->syswrite( $fh, $data );
194             }
195             else {
196 1         20 return Future->fail( "syswrite: $!\n", syswrite => $fh, $! );
197             }
198 8         30 });
199             }
200              
201             =head1 AUTHOR
202              
203             Paul Evans
204              
205             =cut
206              
207             0x55AA;