File Coverage

lib/HTTP/Promise/IO.pm
Criterion Covered Total %
statement 271 522 51.9
branch 115 408 28.1
condition 45 235 19.1
subroutine 34 48 70.8
pod 24 28 85.7
total 489 1241 39.4


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/IO.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/02
7             ## Modified 2022/05/02
8             ## All rights reserved.
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package HTTP::Promise::IO;
15             BEGIN
16             {
17 12     12   440189 use strict;
  12         46  
  12         429  
18 12     12   146 use warnings;
  12         24  
  12         369  
19 12     12   69 use warnings::register;
  12         32  
  12         2103  
20 12     12   111 use parent qw( Module::Generic );
  12         26  
  12         87  
21 12     12   917 use vars qw( $CRLF $IS_WIN32 $INIT_PARAMS $VERSION );
  12         41  
  12         1031  
22 12     12   3776 use Errno qw( EAGAIN ECONNRESET EINPROGRESS EINTR EWOULDBLOCK ECONNABORTED EISCONN );
  12         12507  
  12         1810  
23 12     12   98 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK O_RDONLY O_RDWR SEEK_SET SEEK_END );
  12         25  
  12         1031  
24 12         2373 use Socket qw(
25             PF_INET SOCK_STREAM
26             IPPROTO_TCP
27             TCP_NODELAY
28             pack_sockaddr_in
29             INADDR_ANY
30 12     12   6948 );
  12         47765  
31 12     12   110 use Time::HiRes qw( time );
  12         42  
  12         178  
32 12     12   2090 use constant ERROR_EINTR => ( abs( Errno::EINTR ) * -1 );
  12         26  
  12         1458  
33 12     12   62 our $CRLF = "\015\012";
34 12         49 our $IS_WIN32 = ( $^O eq 'MSWin32' );
35             # This is for connect() so it knows
36 12         37 our $INIT_PARAMS = [qw( buffer debug inactivity_timeout last_delimiter max_read_buffer ssl_opts stop_if timeout )];
37 12         226 our $VERSION = 'v0.1.0';
38             };
39              
40 12     12   74 use strict;
  12         24  
  12         254  
41 12     12   54 use warnings;
  12         27  
  12         19959  
42              
43             sub init
44             {
45 60     60 1 1424515 my $self = shift( @_ );
46 60 50       494 return( $self->error( "No filehandle was provided." ) ) if( !scalar( @_ ) );
47 60         235 my $fh = shift( @_ );
48 60 50       380 return( $self->error( "Filehandle provided (", overload::StrVal( $fh ), ") is not a proper filehandle." ) ) if( !$self->_is_glob( $fh ) );
49             # This needs to be set to empty string and not undef to make chaining work with Module::Generic::Scalar
50 60         1886 $self->{buffer} = '';
51 60         356 $self->{inactivity_timeout} = 600;
52 60         359 $self->{last_delimiter} = '';
53 60         373 $self->{max_read_buffer} = 0;
54 60         252 $self->{ssl_opts} = {};
55 60     0   635 $self->{stop_if} = sub{};
56 60         535 $self->{timeout} = 5;
57 60         434 $self->{_init_strict_use_sub} = 1;
58 60 50       377 $self->SUPER::init( @_ ) || return( $self->pass_error );
59             # Ensure O_NONBLOCK is set so that calls to select in can_read() would not report ok
60             # although no data is available. See select in perlfunc for more details.
61 60         35422 my $dummy = '';
62 60 50       460 if( $self->_can( $fh => 'fcntl' ) )
63             {
64 60         2185 my $flags = $fh->fcntl( F_GETFL, $dummy );
65 60 50       2277 return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
66 60         470 my $rv = $fh->fcntl( F_SETFL, ( $flags | O_NONBLOCK ) );
67 60 50       1877 return( $self->error({ code => 500, message => "Unable to set flags to filehandle '$fh': $!" }) ) if( !defined( $rv ) );
68             }
69             else
70             {
71 0         0 my $flags = fcntl( $fh, F_GETFL, $dummy );
72 0 0       0 return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
73 0         0 my $rv = fcntl( $fh, F_SETFL, ( $flags | O_NONBLOCK ) );
74 0 0       0 return( $self->error({ code => 500, message => "Unable to set flags to filehandle '$fh': $!" }) ) if( !defined( $rv ) );
75             }
76 60         207 $self->{_fh} = $fh;
77 60         183 return( $self );
78             }
79              
80 337     337 1 3591 sub buffer { return( shift->_set_get_scalar_as_object( 'buffer', @_ ) ); }
81              
82             sub can_read
83             {
84 158     158 1 382 my $self = shift( @_ );
85 158         522 my $fh = $self->filehandle;
86 158         116341 my $opts = $self->_get_args_as_hash( @_ );
87 158 50       1716 return(1) unless( defined( fileno( $fh ) ) );
88 158 50 33     1820 return(1) if( $fh->isa( 'IO::Socket::SSL' ) && $fh->pending );
89 158 0 33     1413 return(1) if( $fh->isa( 'Net::SSL' ) && $fh->can('pending') && $fh->pending );
      33        
90            
91             # If this is an in-memory scalar filehandle
92             # check that it is opened so we can read from it
93 158 100       557 if( fileno( $fh ) == -1 )
94             {
95 40 50       196 if( $self->_can( $fh => 'can_read' ) )
96             {
97 40         1394 return( $fh->can_read );
98             }
99             else
100             {
101 0         0 my( $dummy, $flags );
102 0 0       0 if( $self->_can( $fh => 'fcntl' ) )
103             {
104 0         0 $flags = $fh->fcntl( F_GETFL, $dummy );
105             }
106             else
107             {
108 0         0 $flags = fcntl( $fh, F_GETFL, $dummy );
109             }
110 0 0       0 return( $self->error({ code => 500, message => "Unable to get flags from filehandle '$fh': $!" }) ) if( !defined( $flags ) );
111 0   0     0 return( ( $flags == O_RDONLY ) || ( $flags & ( O_RDONLY | O_RDWR ) ) );
112             }
113             }
114              
115             # With no timeout, wait forever. An explicit timeout of 0 can be used to just check
116             # if the socket is readable without waiting.
117 118 50       525 my $timeout = $opts->{timeout} ? $opts->{timeout} : $self->timeout;
118              
119 118         257 my $fbits = '';
120 118         521 vec( $fbits, fileno( $fh ), 1 ) = 1;
121             SELECT:
122             {
123 118         280 my $before;
  118         194  
124 118 50       607 $before = time() if( $timeout );
125 118         1957 my $nfound = select( $fbits, undef, undef, $timeout );
126 118 50       507 if( $nfound < 0 )
127             {
128 0 0 0     0 if( $!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK} )
      0        
129             {
130             # don't really think EAGAIN/EWOULDBLOCK can happen here
131 0 0       0 if( $timeout )
132             {
133 0         0 $timeout -= time() - $before;
134 0 0       0 $timeout = 0 if( $timeout < 0 );
135             }
136 0         0 redo( SELECT );
137             }
138 0         0 return( $self->error({ code => 500, message => "select failed: $!" }) );
139             }
140 118         651 return( $nfound > 0 );
141             }
142             }
143              
144             sub close
145             {
146 0     0 1 0 my $self = shift( @_ );
147 0         0 my $fh = $self->filehandle;
148 0 0       0 $fh->close if( $self->_can( $fh, 'close' ) );
149 0         0 $self->filehandle( undef );
150 0         0 $self->DESTROY;
151             }
152              
153             sub connect
154             {
155 0     0 1 0 my $self = shift( @_ );
156 0         0 my $opts = $self->_get_args_as_hash( @_ );
157 0   0     0 my $host = $opts->{host} || return( $self->error( "No host to connect to was provided." ) );
158 0   0     0 my $port = $opts->{port} || return( $self->error( "No port to connect to was provided." ) );
159 0 0       0 return( $self->error( "Port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
160 0 0 0     0 return( $self->error( "No timeout was provided to connect." ) ) if( !exists( $opts->{timeout} ) || !length( $opts->{timeout} ) );
161 0         0 my $sock;
162              
163 0 0   0   0 my $stop_if = $self->_is_code( $opts->{stop_if} ) ? $opts->{stop_if} : sub{};
164 0         0 $opts->{stop_if} = $stop_if;
165 0         0 my $timeout = $opts->{timeout};
166 0         0 my( $sock_addr );
167             eval
168 0         0 {
169 0     0   0 local $SIG{ALRM} = sub{ die( "timeout\n" ); };
  0         0  
170 0 0 0     0 alarm( $timeout ) if( defined( $timeout ) && $timeout > 0 );
171 0   0     0 my $ipbin = Socket::inet_aton( $host ) ||
172             return( $self->error( "Cannot resolve host name: ${host} (port: ${port}): $!" ) );
173 0   0     0 $sock_addr = Socket::pack_sockaddr_in( $port, $ipbin ) ||
174             return( $self->error( "Cannot resolve host name: ${host} (port: ${port}): $!" ) );
175 0         0 alarm(0);
176             };
177 0 0       0 return( $self->error( "Failed to resolve host name '$host': timeout" ) ) if( $@ =~ /timeout/i );
178            
179 0         0 my( $lport, $laddr );
180 0 0 0     0 $lport = $opts->{local_port} if( exists( $opts->{local_port} ) && defined( $opts->{local_port} ) );
181             $laddr = defined( $opts->{local_host} )
182             ? Socket::inet_aton( $opts->{local_host} )
183 0 0       0 : INADDR_ANY;
184 0 0       0 return( $self->error( "Bad local host provided \"$opts->{local_host}\": $!" ) ) if( !defined( $laddr ) );
185            
186 0 0 0     0 if( defined( $lport ) ||
187             ( $laddr ne INADDR_ANY ) )
188             {
189 0   0     0 my $local_sock_addr = Socket::pack_sockaddr_in( ( $lport // 0 ), $laddr ) ||
190             return( $self->error( "Cannot resolve local host: $opts->{local_host} (port: $opts->{local_port}): $!" ) );
191             CORE::bind( $sock, $local_sock_addr ) || do
192 0 0       0 {
193 0 0       0 if( $laddr ne INADDR_ANY )
194             {
195 0         0 return( $self->error( "Unable to bind to local host \"$opts->{local_host}\": $!" ) );
196             }
197             else
198             {
199 0         0 return( $self->error( "Unable to bind to local port \"$opts->{local_port}\": $!" ) );
200             }
201             };
202             }
203              
204             RETRY:
205 0 0       0 CORE::socket( $sock, Socket::sockaddr_family( $sock_addr ), SOCK_STREAM, 0 ) ||
206             return( $self->error( "Unable to create socket: $!" ) );
207 0 0       0 $self->_set_sockopts( $sock ) || return( $self->pass_error );
208 0         0 my $params = {};
209 0 0       0 if( $self->_is_array( $INIT_PARAMS ) )
210             {
211 0         0 for( @$INIT_PARAMS )
212             {
213 0 0       0 $params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
214             }
215             }
216 0   0     0 my $new = $self->new( $sock, $params ) || return( $self->pass_error );
217 0 0 0     0 if( CORE::connect( $sock, $sock_addr ) )
    0 0        
218             {
219             # connected
220             }
221             elsif( $! == EINPROGRESS || ( $IS_WIN32 && $! == EWOULDBLOCK ) )
222             {
223 0         0 my $rv = $new->make_select_timeout( write => 1, timeout => $opts->{timeout} );
224 0 0       0 return( $self->error( "Cannot connect to ${host}:${port}: ", $new->error->message ) ) if( !defined( $rv ) );
225 0 0       0 return( $self->error( "Select timeout on socket." ) ) if( !$rv );
226             }
227             # connected
228             else
229             {
230 0 0 0     0 if( $! == EINTR && !$stop_if->() )
231             {
232 0         0 CORE::close( $sock );
233 0         0 goto( RETRY );
234             }
235 0         0 return( $self->error( "Cannot connect to ${host}:${port}: $!" ) );
236             }
237 0         0 return( $new );
238             }
239              
240             # connect SSL socket.
241             # You can override this method in your child class, if you want to use Crypt::SSLeay or some other library.
242             # Returns file handle like object
243             sub connect_ssl
244             {
245 0     0 1 0 my $self = shift( @_ );
246 0         0 my $opts = $self->_get_args_as_hash( @_ );
247 0   0     0 my $host = $opts->{host} || return( $self->error( "No host to connect to was provided." ) );
248 0   0     0 my $port = $opts->{port} || return( $self->error( "No port to connect to was provided." ) );
249 0 0       0 return( $self->error( "Port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
250 0 0 0     0 return( $self->error( "No timeout was provided to connect." ) ) if( !exists( $opts->{timeout} ) || !length( $opts->{timeout} ) );
251            
252 0 0       0 $self->_load_class( 'IO::Socket::SSL' ) || return( $self->pass_error );
253              
254 0         0 my $params = {};
255 0 0       0 if( $self->_is_array( $INIT_PARAMS ) )
256             {
257 0         0 for( @$INIT_PARAMS )
258             {
259 0 0       0 $params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
260             }
261             }
262 0         0 $params->{host} = $host;
263 0         0 $params->{port} = $port;
264 0   0     0 my $new = $self->connect( %$params ) ||
265             return( $self->pass_error );
266 0         0 my $sock = $new->filehandle;
267              
268 0   0     0 my $timeout = $opts->{timeout} // $self->timeout // 5;
      0        
269             # my $timeout = ( $opts->{timeout} - time() );
270             # return( $self->error( "Cannot create SSL connection: timeout" ) ) if( $timeout <= 0 );
271              
272 0         0 my $ssl_opts = $new->_ssl_opts;
273             IO::Socket::SSL->start_SSL(
274             $sock,
275             PeerHost => $host,
276             PeerPort => $port,
277             Timeout => $timeout,
278             ( defined( $opts->{local_host} ) ? ( LocalHost => $opts->{local_host} ) : () ),
279 0 0       0 ( defined( $opts->{local_port} ) ? ( LocalPort => $opts->{local_port} ) : () ),
    0          
    0          
280             %$ssl_opts,
281             ) or return( $self->error( "Cannot create SSL connection: " . IO::Socket::SSL::errstr() ) );
282 0         0 $new->_set_sockopts( $sock );
283 0         0 return( $new );
284             }
285              
286             sub connect_ssl_over_proxy
287             {
288 0     0 1 0 my $self = shift( @_ );
289 0         0 my $opts = $self->_get_args_as_hash( @_ );
290 0   0     0 my $proxy_host = $opts->{proxy_host} || return( $self->error( "No proxy host to connect to was provided." ) );
291 0   0     0 my $proxy_port = $opts->{proxy_port} || return( $self->error( "No proxy port to connect to was provided." ) );
292 0   0     0 my $host = $opts->{host} || return( $self->error( "No host to connect to was provided." ) );
293 0   0     0 my $port = $opts->{port} || return( $self->error( "No port to connect to was provided." ) );
294 0 0       0 return( $self->error( "Proxy port provided ($proxy_port) is not a number" ) ) if( $proxy_port !~ /^\d+$/ );
295 0 0       0 return( $self->error( "Host port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
296 0 0       0 return( $self->error( "Port provided ($port) is not a number" ) ) if( $port !~ /^\d+$/ );
297 0 0 0     0 return( $self->error( "No timeout was provided to connect." ) ) if( !exists( $opts->{timeout} ) || !length( $opts->{timeout} ) );
298 0         0 my $proxy_authorization = $opts->{proxy_authorization};
299 0 0       0 $self->_load_class( 'IO::Socket::SSL' ) || return( $self->pass_error );
300              
301 0         0 my $params = {};
302 0 0       0 if( $self->_is_array( $INIT_PARAMS ) )
303             {
304 0         0 for( @$INIT_PARAMS )
305             {
306 0 0       0 $params->{ $_ } = $opts->{ $_ } if( exists( $opts->{ $_ } ) );
307             }
308             }
309 0         0 $params->{host} = $proxy_host;
310 0         0 $params->{port} = $proxy_port;
311 0   0     0 my $new = $self->connect( %$params ) ||
312             return( $self->pass_error );
313 0         0 my $sock = $new->filehandle;
314              
315 0         0 my $p = "CONNECT ${host}:${port} HTTP/1.0${CRLF}Server: ${host}${CRLF}";
316 0 0       0 if( defined( $proxy_authorization ) )
317             {
318 0         0 $p .= "Proxy-Authorization: ${proxy_authorization}${CRLF}";
319             }
320 0         0 $p .= $CRLF;
321 0 0       0 $new->_write_all( $sock, $p, $opts->{timeout} ) ||
    0          
322             return( $self->error({
323             code => 500,
324             message => "Failed to send HTTP request to proxy: " . ( $! != 0 ? "$!" : 'timeout' )
325             }) );
326 0         0 my $buf = '';
327 0         0 my $read = $new->read( \$buf, $new->buffer_size, length( $buf ), $opts->{timeout} );
328 0 0       0 if( !defined( $read ) )
    0          
    0          
329             {
330 0 0       0 return( $self->error( "Cannot read proxy response: " . ( $! != 0 ? "$!" : 'timeout' ) ) );
331             }
332             # eof
333             elsif( $read == 0 )
334             {
335 0         0 return( $self->error( "Unexpected EOF while reading proxy response" ) );
336             }
337             elsif( $buf !~ /^HTTP\/1\.[0-9] 200 .+\015\012/ )
338             {
339 0         0 return( $self->error( "Invalid HTTP Response via proxy" ) );
340             }
341              
342 0         0 my $timeout = ( $opts->{timeout} - time() );
343 0 0       0 return( $self->error( "Cannot start SSL connection: timeout" ) ) if( $opts->{timeout} <= 0 );
344              
345 0         0 my $ssl_opts = $new->_ssl_opts;
346 0 0       0 unless( exists( $ssl_opts->{SSL_verifycn_name} ) )
347             {
348 0         0 $ssl_opts->{SSL_verifycn_name} = $host;
349             }
350             IO::Socket::SSL->start_SSL(
351             $sock,
352             PeerHost => "$host",
353             PeerPort => "$port",
354             Timeout => "$timeout",
355             ( defined( $opts->{local_host} ) ? ( LocalHost => $opts->{local_host} ) : () ),
356 0 0       0 ( defined( $opts->{local_port} ) ? ( LocalPort => $opts->{local_port} ) : () ),
    0          
    0          
357             %$ssl_opts
358             ) or return( $self->error( "Cannot start SSL connection: " . IO::Socket::SSL::errstr() ) );
359 0         0 $new->_set_sockopts( $sock );
360 0         0 return( $new );
361             }
362              
363 628     628 1 2738 sub filehandle { return( shift->_set_get_glob( '_fh', @_ ) ); }
364              
365             # Credits: Olaf Alders in Net::HTTP
366             sub getline
367             {
368 24     24 1 117 my $self = shift( @_ );
369 24         267 my $opts = $self->_get_args_as_hash( @_ );
370 24 50       4293 $opts->{chomp} = 0 if( !CORE::exists( $opts->{chomp} ) );
371 24         115 $opts->{max_read_buffer} = 0;
372 24   50     178 my $fh = $self->filehandle || return( $self->error( "No filehandle currently set." ) );
373 24         19288 my $buff = $self->buffer;
374 24   33     19577 my $max = $opts->{max_read_buffer} || $self->max_read_buffer;
375 24         18588 my $pos;
376 24 50       300 my $is_object = $self->_can( $fh => 'sysread' ) ? 1 : 0;
377 24         723 while(1)
378             {
379             # Get the position of line ending. \015 might not be there, but \012 will
380 46         506 $pos = $buff->index( "\012" );
381 46 100       1678485 last if( $pos >= 0 );
382             # 413 Entity too large
383 23 50 33     4354 return( $self->error({ code => 413, message => "Line too long (limit is $max)" }) ) if( $max && $buff->length > $max );
384             # need to read more data to find a line ending
385 23         846753 my $new_bytes = 0;
386             READ:
387             {
388 23         3031 my $rv = $self->can_read;
  23         225  
389 23 50       409 return( $self->pass_error ) if( !defined( $rv ) );
390 23 50       94 return( $self->error( "Cannot read from filehandle '$fh'" ) ) if( !$rv );
391             # consume all incoming bytes
392 23 50       183 my $bytes_read = $is_object
393             ? $fh->sysread( $$buff, 1024, $buff->length )
394             : sysread( $fh, $$buff, 1024, $buff->length );
395 23 50 0     843301 if( defined( $bytes_read ) )
    0 0        
396             {
397 23         2981 $new_bytes += $bytes_read;
398             }
399             elsif( $!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK} )
400             {
401 0         0 redo READ;
402             }
403             else
404             {
405 0         0 $self->mesage( 4, "$bytes_read bytes read from filehandle '$fh' with total read so far of ", $buff->length );
406             # if we have already accumulated some data let's at
407             # least return that as a line
408 0 0       0 $buff->length or return( $self->error( "read() failed: $!" ) );
409             }
410             # no line-ending, no new bytes
411             return(
412 23 50       179 $buff->length
    100          
413             ? $buff->substr( 0, $buff->length, '' )
414             # : undef
415             : ''
416             ) if( $new_bytes == 0 );
417             };
418             }
419 23 50 33     3798 return( $self->error( "Line too long ($pos; limit is $max)" ) ) if( $max && $pos > $max );
420 23         3351 my $line = $buff->substr( 0, $pos + 1, '' );
421             # $line =~ s/(\015?\012)\z// || return( $self->error( 'No end-of-line found' ) );
422             # return( wantarray() ? ($line, $1) : $line;
423 23 50       16744 $$line =~ s/(\015?\012)\z// if( $opts->{chomp} );
424 23         2740 return( $$line );
425             }
426              
427 0     0 1 0 sub inactivity_timeout { return( shift->_set_get_number_as_scalar( 'inactivity_timeout', @_ ) ); }
428              
429 78     78 1 423 sub last_delimiter { return( shift->_set_get_scalar_as_object( 'last_delimiter', @_ ) ); }
430              
431             sub make_select
432             {
433 0     0 1 0 my $self = shift( @_ );
434 0         0 my $opts = $self->_get_args_as_hash( @_ );
435 0   0     0 my $fh = $self->filehandle || return( $self->error( "No filehandle set to read from." ) );
436 0   0     0 my $timeout = $opts->{timeout} // $self->timeout;
437 0 0       0 return( $self->error( 'No timeout was provided.' ) ) if( !defined( $timeout ) );
438 0 0       0 my $is_write = $opts->{write} ? 1 : 0;
439 0         0 my( $rfd, $wfd );
440 0         0 my $efd = '';
441 0         0 vec( $efd, fileno( $fh ), 1 ) = 1;
442 0 0       0 if( $is_write )
443             {
444 0         0 $wfd = $efd;
445             }
446             else
447             {
448 0         0 $rfd = $efd;
449             }
450 0         0 my $nfound = select( $rfd, $wfd, $efd, $timeout );
451 0 0 0     0 return( $self->error( $! ) ) if( $nfound < 0 && $! );
452 0         0 return( $nfound );
453             }
454              
455             # returns true if the socket is ready to read, false if timeout has occurred ($! will be cleared upon timeout)
456             sub make_select_timeout
457             {
458 0     0 1 0 my $self = shift( @_ );
459 0         0 my $opts = $self->_get_args_as_hash( @_ );
460 0 0       0 my $is_write = $opts->{write} ? 1 : 0;
461 0   0     0 my $fh = $self->filehandle || return( $self->error( "No filehandle currently set." ) );
462 0         0 my $timeout;
463 0 0 0     0 $timeout = $opts->{timeout} if( exists( $opts->{timeout} ) && length( $opts->{timeout} ) );
464 0   0     0 $timeout //= $self->timeout;
465 0         0 my $timeout_at = time() + $timeout;
466 0 0       0 return( $self->error( "No timeout option was provided nor is it defined with timeout()." ) ) if( !defined( $timeout ) );
467             # Time::HiRes time()
468 0         0 my $now = time();
469 0   0     0 my $inactivity_timeout = $self->inactivity_timeout // $opts->{inactivity_timeout} // 600;
      0        
470 0         0 my $inactivity_timeout_at = ( $now + $inactivity_timeout );
471 0 0       0 $self->message( 4, "Setting timeout_at to $inactivity_timeout_at (${inactivity_timeout_at} [", scalar( localtime( $inactivity_timeout_at ) ), "]) ? ", ( $timeout_at > $inactivity_timeout_at ? 'yes' : 'no' ) );
472 0 0       0 $timeout_at = $inactivity_timeout_at if( $timeout_at > $inactivity_timeout_at );
473 0         0 my $stop_if = $self->stop_if;
474             # wait for data
475 0         0 while(1)
476             {
477 0         0 my $timeout2 = ( $timeout_at - $now );
478 0 0       0 if( $timeout2 <= 0 )
479             {
480 0         0 $! = 0;
481 0         0 return(0);
482             }
483 0         0 my $nfound = $self->make_select( write => $is_write, timeout => $timeout2 );
484 0 0       0 return( $self->pass_error ) if( !defined( $nfound ) );
485 0 0       0 return(1) if( $nfound > 0 );
486 0 0 0     0 return(0) if( $nfound == -1 && $! == EINTR && $stop_if->() );
      0        
487             # Time::HiRes time()
488 0         0 $now = time();
489             }
490 0         0 return( $self->error( 'Error checking for readiness of socket. Should not get here.' ) );
491             }
492              
493             # Maximum size of read buffer, beyond which, if still nothing is found, then we give up
494 88     88 1 4500 sub max_read_buffer { return( shift->_set_get_number_as_scalar( 'max_read_buffer', @_ ) ); }
495              
496 237 50   237 1 866 sub print { return( defined( shift->write( @_ ) ) ? 1 : 0 ); }
497              
498             sub read
499             {
500 80     80 1 307 my $self = $_[0];
501 80 50 33     823 return( $self->error({ code => 500, message => "Wrong number of arguments. Usage: \$reader->read( \$buffer, \$length, \$offset )" }) ) unless( @_ > 2 && @_ < 5 );
502 80         245 my $len = $_[2];
503 80 50 33     885 return( $self->error( "Length provided (${len}) is not a positive integer." ) ) if( !defined( $len ) || $len !~ /^\d+$/ );
504 80         752 my $off = $_[3];
505 80 50 66     545 return( $self->error( "Offset provided (${off}) is not an integer." ) ) if( defined( $off ) && $off !~ /^-?\d+$/ );
506 80 100       496 my $is_scalar = $self->_is_scalar( $_[1] ) ? 1 : 0;
507 80 50 66     1181 return( $self->error( "scalar provided as first argument to read() is a reference (", overload::StrVal( $_[1] ), "). You need to first dereference it." ) ) if( ref( $_[1] ) && !$is_scalar );
508 80   100     554 $off //= 0;
509 80   50     389 my $fh = $self->filehandle || return( $self->error( "No filehandle set to read from." ) );
510 80         61939 my $buff = $self->buffer;
511 80         63868 my $buff_len = $buff->length->scalar;
512 80 50       2879234 my $is_object = $self->_can( $fh => 'sysread' ) ? 1 : 0;
513 80         13178 my $stop_if = $self->stop_if;
514            
515             my $sysread = sub
516             {
517 40     40   93 while(1)
518             {
519 40 50       368 my $n = $is_object
    0          
    50          
520             ? $fh->sysread( $_[0], $_[1], ( @_ > 2 ? $_[2] : () ) )
521             : sysread( $fh, $_[0], $_[1], ( @_ > 2 ? $_[2] : () ) );
522 40 50       6836 if( defined( $n ) )
523             {
524 40         333 return( $n );
525             }
526            
527 0 0 0     0 if( $! == EAGAIN || $! == EWOULDBLOCK || ( $IS_WIN32 && $! == EISCONN ) )
    0 0        
      0        
528             {
529             # passthru
530             }
531             elsif( $! == EINTR )
532             {
533 0 0       0 return( $self->error({ code => $!+0, message => "Received interruption signal: $!" }) ) if( $stop_if->() );
534             # otherwise passthru
535             }
536             else
537             {
538 0         0 return( $self->error({ code => $!+0, message => "Unable to read from filehandle: $!" }) );
539             }
540             # on EINTER/EAGAIN/EWOULDBLOCK
541 0         0 my $rv = $self->make_select_timeout( write => 0 );
542 0 0       0 return( $self->pass_error ) if( !defined( $rv ) );
543 0 0       0 return( $self->error( "Unable to select the filehandle." ) ) if( !$rv );
544             }
545 80         64245 };
546            
547 80 100       366 if( $buff_len )
548             {
549             # if our buffer is less than that is required, attempt to read the difference from the filehandle
550 61 100       454 if( $buff_len < $len )
551             {
552 21 50       143 return( $self->pass_error ) unless( defined( $self->can_read ) );
553 21         472 my $n = $sysread->( $$buff, ( $len - $buff_len ), $buff_len );
554 21 50       108 return( $self->pass_error ) if( !defined( $n ) );
555             }
556            
557             # What we will return
558 61 100       7122 my $bytes = ( $buff->length > $len ? $len : $buff->length );
559             # "A positive OFFSET greater than the length of SCALAR results in the string being
560             # padded to the required size with "\0" bytes before the result of the read is
561             # appended."
562             # (perlfunc)
563 61 50       4357396 if( $is_scalar )
564             {
565 0 0       0 if( $off > length( $$_[1] ) )
566             {
567 0         0 $$_[1] .= \0 x ( $off - length( $$_[1] ) );
568             }
569 0         0 substr( $$_[1], $off, 0, $buff->substr( 0, $bytes, '' )->scalar );
570             # Truncate
571 0         0 substr( $$_[1], ( $off + $bytes ), length( $$_[1] ), '' );
572             }
573             else
574             {
575 61 50       8307 if( $off > length( $_[1] ) )
576             {
577 0         0 $_[1] .= \0 x ( $off - length( $_[1] ) );
578             }
579 61         466 substr( $_[1], $off, 0, $buff->substr( 0, $bytes, '' )->scalar );
580             # Truncate
581 61         4070 substr( $_[1], ( $off + $bytes ), length( $_[1] ), '' );
582             }
583 61         28654 return( $bytes );
584             }
585             else
586             {
587 19 50       148 return( $sysread->( $_[1], $len, ( defined( $off ) ? $off : () ) ) );
588             }
589             }
590              
591             sub read_until
592             {
593 129     129 1 2855 my $self = $_[0];
594 129 50       567 return( $self->error({ code => 500, message => "Wrong number of arguments. Usage: \$reader->read_until( \$buffer, \$length, \$offset, { string => 'something', exclude => 1, include => 1, chunk_size => 2048 } )" }) ) unless( @_ > 2 );
595 129         207 my $len = $_[2];
596 129 50       954 return( $self->error( "Length provided (${len}) is not an integer." ) ) if( $len !~ /^\d+$/ );
597 129 50       452 return( $self->error( "scalar provided as first argument to read_until() is a reference (", overload::StrVal( $_[1] ), "). You need to first dereference it." ) ) if( ref( $_[1] ) );
598 129 50       718 my $off = ( $_[3] =~ /^\-?\d+$/ ? $_[3] : 0 );
599 129         325 my $opts = {};
600 129 50       566 $opts = $_[-1] if( ref( $_[-1] ) eq 'HASH' );
601 129         301 my $what = $opts->{string};
602 129 50 33     873 return( $self->error({ code => 500, message => "Nothing was provided to look for." }) ) if( !defined( $what ) || !CORE::length( $what ) );
603 129 50       474 $what = qr/\Q${what}\E/ unless( ref( $what ) eq 'Regexp' );
604 129   50     431 my $fh = $self->filehandle || return( $self->error( "No filehandle set to read from." ) );
605 129   50     96667 $opts->{ignore} //= 0;
606 129 50       519 $opts->{exclude} = 0 if( !exists( $opts->{exclude} ) );
607 129 50       582 $opts->{inlude} = !$opts->{exclude} if( !exists( $opts->{include} ) );
608             # Should we capture the delimiter?
609             # This is useful for debugging, or in case of boundary for HTTP message multipart to know
610             # if we have reached the trailing delimiter for example.
611 129   100     620 $opts->{capture} //= 0;
612 129         211 my $re;
613 129 50       369 if( $opts->{ignore} )
    0          
614             {
615 129 100       1112 $re = $opts->{capture} ? qr/(.*?)(?<__reader_delimiter>${what})/s : qr/(.*?)${what}/s;
616             }
617             elsif( $opts->{include} )
618             {
619 0 0       0 $re = $opts->{capture} ? qr/((?:.*?)(?<__reader_delimiter>${what}))/s : qr/((?:.*?)${what})/s;
620             }
621             else
622             {
623 0         0 $re = qr/(.*?)(?=${what})/s;
624             }
625 129   50     685 my $chunk_size = $opts->{chunk_size} // 2048;
626 129 50       421 $chunk_size = $len if( $len > $chunk_size );
627 129         406 my $buff = $self->buffer;
628 129         102620 my $n = -1;
629 129         450 my $sliding_buffer_size = $chunk_size * 2;
630 129 50       620 my $is_object = $self->_can( $fh => 'sysread' ) ? 1 : 0;
631 129         3813 my $buff_len = $buff->length->scalar;
632 129         4559282 my $stop_if = $self->stop_if;
633 129 100 100     100727 if( !$buff_len || $$buff !~ /$re/ )
634             {
635 114 50       488 if( $buff_len < $sliding_buffer_size )
636             {
637 114 50       475 return( $self->pass_error ) unless( defined( $self->can_read ) );
638 114         192 while(1)
639             {
640 114 50       906 my $n = $is_object
641             ? $fh->sysread( $$buff, ( $sliding_buffer_size - $buff_len ), $buff_len )
642             : sysread( $fh, $$buff, ( $sliding_buffer_size - $buff_len ), $buff_len );
643 114 50 66     18406 if( !defined( $n ) )
    100          
644             {
645 0 0 0     0 if( $! == EAGAIN || $! == EWOULDBLOCK || ( $IS_WIN32 && $! == EISCONN ) )
    0 0        
      0        
646             {
647             # passthru
648             }
649             elsif( $! == EINTR )
650             {
651 0 0       0 return( $self->error({ code => $!+0, message => "Received interruption signal: $!" }) ) if( $stop_if->() );
652             # otherwise passthru
653             }
654             else
655             {
656 0         0 return( $self->error({ code => $!+0, message => "Unable to read from filehandle: $!" }) );
657             }
658             # on EINTER/EAGAIN/EWOULDBLOCK
659 0         0 my $rv = $self->make_select_timeout( write => 0 );
660 0 0       0 return( $self->pass_error ) if( !defined( $rv ) );
661 0 0       0 return( $self->error( "Unable to select the filehandle." ) ) if( !$rv );
662             }
663             # 0, meaning there is no more data to read
664             # If our buffer still has some data, we'll return whatever we have left
665             elsif( !$n && $buff->is_empty )
666             {
667 1         17 return( $n );
668             }
669             else
670             {
671 113         277 last;
672             }
673             }
674             }
675             }
676            
677 128   100     370 $_[1] //= '';
678             # "A positive OFFSET greater than the length of SCALAR results in the string being
679             # padded to the required size with "\0" bytes before the result of the read is
680             # appended."
681             # (perlfunc)
682 128 50       472 if( $off > length( $_[1] ) )
683             {
684 0         0 $_[1] .= \0 x ( $off - length( $_[1] ) );
685             }
686            
687 128 100       2030 if( $$buff =~ s/^$re// )
688             {
689 18         139 my $trail = $1;
690 18 100       210 if( exists( $+{__reader_delimiter} ) )
691             {
692 13         86 $self->last_delimiter( $+{__reader_delimiter} );
693             }
694             else
695             {
696 5         20 $self->last_delimiter->reset;
697             }
698 18         15088 my $bytes = length( $trail );
699 18         104 substr( $_[1], $off, 0, $trail );
700             # Truncate
701 18         54 substr( $_[1], ( $off + $bytes ), length( $_[1] ), '' );
702             # < 0 means in our API there is a match and this is what was returned.
703             # The caller can simply use abs() to get the bytes value.
704             # 0 means no more data, and
705             # undef means there is an error
706             # > 0 is returned when no match was found, but only data
707 18         120 return( $bytes * -1 );
708             }
709             else
710             {
711 110 50       464 my $bytes = $buff->length > $len ? $len : $buff->length;
712 110         3901555 substr( $_[1], $off, 0, $buff->substr( 0, $bytes, '' ) );
713             # Truncate
714 110         18977 substr( $_[1], ( $off + $bytes ), length( $_[1] ), '' );
715 110         2289 return( $bytes );
716             }
717             }
718              
719             sub read_until_in_memory
720             {
721 42     42 1 3045 my $self = shift( @_ );
722 42         106 my $what = shift( @_ );
723 42         222 my $opts = $self->_get_args_as_hash( @_ );
724 42 50 33     7012 return( $self->error({ code => 500, message => "Nothing was provided to look for." }) ) if( !defined( $what ) || !CORE::length( $what ) );
725 42 50       239 $what = qr/\Q${what}\E/ unless( ref( $what ) eq 'Regexp' );
726 42   50     435 $opts->{ignore} //= 0;
727 42 100       278 $opts->{exclude} = 0 if( !exists( $opts->{exclude} ) );
728 42 100       173 $opts->{inlude} = !$opts->{exclude} if( !exists( $opts->{include} ) );
729             # Should we capture the delimiter?
730             # This is useful for debugging, or in case of boundary for HTTP message multipart to know
731             # if we have reached the trailing delimiter for example.
732 42   100     437 $opts->{capture} //= 0;
733 42         104 my $re;
734 42 50       216 if( $opts->{ignore} )
    100          
735             {
736 0 0       0 $re = $opts->{capture} ? qr/(.*?)(?<__reader_delimiter>${what})/s : qr/(.*?)${what}/s;
737             }
738             elsif( $opts->{include} )
739             {
740 41 100       749 $re = $opts->{capture} ? qr/((?:.*?)(?<__reader_delimiter>${what}))/s : qr/((?:.*?)${what})/s;
741             }
742             else
743             {
744 1         29 $re = qr/(.*?)(?=${what})/s;
745             }
746 42   50     382 my $chunk_size = $opts->{chunk_size} // 2048;
747 42         274 my $max = $self->max_read_buffer;
748 42         32951 my $buff = '';
749             # Make an initial read to get whatever is in the internal buffer
750             # Maybe that is sufficient to satisfy the regular expression need
751 42 100       222 if( my $buff_len = $self->buffer->length )
752             {
753 39         1415070 my $bytes = $self->read( $buff, $buff_len );
754 39 50       5286 return( $self->pass_error ) if( !defined( $bytes ) );
755             }
756              
757 42         113187 while( $buff !~ /$re/ )
758             {
759 3         19 my $n = $self->read( $buff, $chunk_size, CORE::length( $buff ) );
760 3 50       15 return( $self->pass_error ) if( !defined( $n ) );
761 3 100       13 return( '' ) if( !$n );
762            
763 2 50 33     121 if( $max && CORE::length( $buff ) > $max )
764             {
765 0         0 $self->unread( $buff );
766 0         0 return( $self->error({ code => 413, message => "Maximum read buffer limit ($max) reached." }) );
767             }
768             }
769 41 50       3821 if( $buff =~ s/^$re// )
770             {
771 41         194 my $match = $1;
772 41 100       597 if( exists( $+{__reader_delimiter} ) )
773             {
774 5         44 $self->last_delimiter( $+{__reader_delimiter} );
775             }
776             else
777             {
778 36         602 $self->last_delimiter->reset;
779             }
780 41         25672 $self->unread( $buff );
781 41         294 return( $match );
782             }
783             else
784             {
785             }
786 0         0 $self->unread( $buff );
787 0         0 return( '' );
788             }
789              
790             # NOTE: request parameter
791 0     0 1 0 sub ssl_opts { return( shift->_set_get_hash_as_mix_object( 'ssl_opts', @_ ) ); }
792              
793 209     209 1 17144 sub stop_if { return( shift->_set_get_code( 'stop_if', @_ ) ); }
794              
795             # sub timeout { return( shift->_set_get_number_as_scalar( 'timeout', @_ ) ); }
796             sub timeout
797             {
798 355     355 1 612 my $self = shift( @_ );
799 355 50       797 $self->{timeout} = shift( @_ ) if( @_ );
800 355         771 return( $self->{timeout} );
801             }
802              
803             sub unread
804             {
805 61     61 1 227 my $self = shift( @_ );
806 61         296 my $buff = $self->buffer;
807 61 100       50110 if( $buff->is_empty )
808             {
809 55         601 $buff->set( shift( @_ ) );
810             }
811             else
812             {
813 6         122 $buff->prepend( shift( @_ ) );
814             }
815 61         1148 return( $self );
816             }
817              
818             # returns (positive) number of bytes written, or undef if the filehandle is to be closed
819             sub write
820             {
821 237     237 1 393 my $self = $_[0];
822 237 50 33     1118 return( $self->error( "Invalid number of arguments. Usage: \$self->write( \$buffer, \$length, \$offset )" ) ) unless( @_ > 1 && @_ < 6 );
823             # Buffer is #1
824 237 50       563 my $len = @_ > 2 ? $_[2] : length( $_[1] );
825 237 50       430 my $off = @_ > 3 ? $_[3] : 0;
826 237 50       628 my $timeout = @_ > 4 ? $_[4] : $self->timeout;
827 237   50     580 my $fh = $self->filehandle || return( $self->error( "No filehandle set to read from." ) );
828 237 50       179028 my $is_object = $self->_can( $fh => 'syswrite' ) ? 1 : 0;
829 237         4786 while(1)
830             {
831 237 50       840 my $bytes = $is_object
832             ? $fh->syswrite( $_[1], $len, $off )
833             : syswrite( $fh, $_[1], $len, $off );
834 237 50       32758 if( defined( $bytes ) )
835             {
836 237         1511 return( $bytes );
837             }
838 0 0 0     0 if( $! == EAGAIN || $! == EWOULDBLOCK || ( $IS_WIN32 && $! == EISCONN ) )
    0 0        
      0        
839             {
840             # passthru
841             }
842             # Could not write because of an interruption
843             elsif( $! == EINTR )
844             {
845 0 0       0 return( $self->error({ code => ERROR_EINTR, message => "Interruption prevented writing to filehandle '$fh': $!" }) ) if( $self->stop_if->() );
846             # otherwise passthru
847             }
848             else
849             {
850 0         0 return( $self->error( "Error writing ${len} bytes at offset ${off} from buffer (size: ", length( $_[2] ), " bytes) to filehandle '$fh': $!" ) );
851             }
852 0         0 my $rv = $self->make_select_timeout( write => 1, timeout => $timeout );
853 0 0       0 return( $self->pass_error ) if( !defined( $rv ) );
854 0 0       0 return( $self->error( "Unable to select the filehandle." ) ) if( !$rv );
855             }
856             }
857              
858             sub write_all
859             {
860 0     0 1 0 my $self = $_[0];
861 0 0 0     0 return( $self->error( "Invalid number of arguments. Usage: \$self->_write_all( \$buffer )" ) ) unless( @_ > 1 && @_ < 4 );
862             # Buffer is #1
863 0 0       0 my $timeout = @_ > 2 ? $_[2] : $self->timeout;
864 0         0 my $off = 0;
865 0         0 while( my $len = length( $_[1] ) - $off )
866             {
867 0         0 my $bytes = $self->write( $_[1], $len, $off, $timeout );
868 0 0       0 return( $self->pass_error ) if( !defined( $bytes ) );
869 0 0       0 return( $bytes ) if( !$bytes );
870 0         0 $off += $bytes;
871             # Should never happen
872 0 0       0 last if( $len < 0 );
873             }
874             # Return total bytes sent
875 0         0 return( $off );
876             }
877              
878             sub _set_sockopts
879             {
880 0     0   0 my $self = shift( @_ );
881 0   0     0 my $sock = shift( @_ ) ||
882             return( $self->error( "No socket was provided." ) );
883              
884 0 0       0 setsockopt( $sock, IPPROTO_TCP, TCP_NODELAY, 1 ) or
885             return( $self->error( "Failed to setsockopt(TCP_NODELAY): $!" ) );
886 0 0       0 if( $IS_WIN32 )
887             {
888 0 0       0 if( ref( $sock ) ne 'IO::Socket::SSL' )
889             {
890 0         0 my $tmp = 1;
891 0 0       0 ioctl( $sock, 0x8004667E, \$tmp ) or
892             return( $self->error( "Cannot set flags for the socket: $!" ) );
893             }
894             }
895             else
896             {
897 0 0       0 my $flags = fcntl( $sock, F_GETFL, 0 ) or
898             return( $self->error( "Cannot get flags for the socket: $!" ) );
899 0 0       0 $flags = fcntl( $sock, F_SETFL, $flags | O_NONBLOCK ) or
900             return( $self->error( "Cannot set flags for the socket: $!" ) );
901             }
902              
903             {
904             # no buffering
905 0         0 my $orig = select();
  0         0  
906 0         0 select( $sock ); $| = 1;
  0         0  
907 0         0 select( $orig );
908             }
909 0         0 binmode( $sock );
910 0         0 return( $sock );
911             }
912              
913             sub _ssl_opts
914             {
915 0     0   0 my $self = shift( @_ );
916 0         0 my $ssl_opts = $self->ssl_opts;
917 0 0       0 unless( exists( $ssl_opts->{SSL_verify_mode} ) )
918             {
919             # set SSL_VERIFY_PEER as default.
920 0         0 $ssl_opts->{SSL_verify_mode} = IO::Socket::SSL::SSL_VERIFY_PEER();
921 0 0       0 unless( exists( $ssl_opts->{SSL_verifycn_scheme} ) )
922             {
923 0         0 $ssl_opts->{SSL_verifycn_scheme} = 'www'
924             }
925             }
926 0 0       0 if( $ssl_opts->{SSL_verify_mode} )
927             {
928 0 0 0     0 unless( exists( $ssl_opts->{SSL_ca_file} ) || exists( $ssl_opts->{SSL_ca_path} ) )
929             {
930 0 0       0 $self->_load_class( 'Mozilla::CA' ) || return( $self->pass_error );
931 0         0 $ssl_opts->{SSL_ca_file} = Mozilla::CA::SSL_ca_file();
932             }
933             }
934 0         0 return( $ssl_opts );
935             }
936              
937             sub FREEZE
938             {
939 1     1 0 9 my $self = CORE::shift( @_ );
940 1   50     10 my $serialiser = CORE::shift( @_ ) // '';
941 1         14 my $class = CORE::ref( $self );
942 1         38 my %hash = %$self;
943 1         9 CORE::delete( @hash{ qw( _fh ) } );
944 1 50 33     44 if( CORE::exists( $hash{stop_if} ) &&
      33        
945             CORE::defined( $hash{stop_if} ) &&
946             CORE::ref( $hash{stop_if} ) )
947             {
948 1         20 require B::Deparse;
949 1         529 my $deparse = B::Deparse->new( '-p', '-sC' );
950 1         1447 my $code = $deparse->coderef2text( CORE::delete( $hash{stop_if} ) );
951 1         11 $hash{stop_if_code} = $code;
952             }
953             # Return an array reference rather than a list so this works with Sereal and CBOR
954 1 50 33     17 CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
955             # But Storable want a list with the first element being the serialised element
956 1         156 CORE::return( $class, \%hash );
957             }
958              
959 1     1 0 162 sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
960              
961 1     1 0 108 sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
962              
963             sub THAW
964             {
965 1     1 0 11 my( $self, undef, @args ) = @_;
966 1 50 33     15 my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
967 1 50 33     31 my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
      0        
968 1 50       11 my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
969 1         7 my $new;
970             # Storable pattern requires to modify the object it created rather than returning a new one
971 1 50       12 if( CORE::ref( $self ) )
972             {
973 1         10 foreach( CORE::keys( %$hash ) )
974             {
975 20         36 $self->{ $_ } = CORE::delete( $hash->{ $_ } );
976             }
977 1         25 $new = $self;
978             }
979             else
980             {
981 0         0 $new = bless( $hash => $class );
982             }
983 1 0 33     17 if( CORE::exists( $hash->{stop_if_code} ) &&
      33        
984             CORE::defined( $hash->{stop_if_code} ) &&
985             CORE::length( $hash->{stop_if_code} ) )
986             {
987 0         0 my $code = CORE::delete( $hash->{stop_if_code} );
988 0         0 my $saved = $@;
989             # "if you want to eval the result, you should prepend "sub subname ", or "sub " for an anonymous function constructor."
990             # <https://metacpan.org/pod/B::Deparse#coderef2text>
991 0         0 my $ref;
992             {
993 12     12   65713 no strict;
  12         71  
  12         1661  
  0         0  
994 0         0 $ref = eval( "sub{ $code }" );
995             }
996 0 0       0 if( $@ )
997             {
998 0         0 $@ =~ s/ at .*\n//;
999 0         0 die( $@ );
1000             }
1001 0         0 $@ = $saved;
1002 0         0 $new->{stop_if} = $ref;
1003             }
1004 1         13 CORE::return( $new );
1005             }
1006              
1007             1;
1008             # NOTE: POD
1009             __END__
1010              
1011             =encoding utf-8
1012              
1013             =head1 NAME
1014              
1015             HTTP::Promise::IO - I/O Handling Class for HTTP::Promise
1016              
1017             =head1 SYNOPSIS
1018              
1019             use HTTP::Promise::IO;
1020             my $this = HTTP::Promise::IO->new( $fh ) ||
1021             die( HTTP::Promise::IO->error, "\n" );
1022              
1023             =head1 VERSION
1024              
1025             v0.1.0
1026              
1027             =head1 DESCRIPTION
1028              
1029             This class implements a filehandle reader and writer with a twist.
1030              
1031             First off, it does not rely on lines, since data stream or in general data from HTTP requests and responses do not necessarily always contain lines. Binary data are sent without necessarily any line at all.
1032              
1033             Second, it is easy on memory by implementing L</read>, which uses a shared L</buffer>, and you can use L</unread> to return data to it (they would be prepended).
1034              
1035             Last, but not least, it implements 2 methods to read in chunks of data from the filehandle until some string pattern specified is found: L</read_until> and L</read_until_in_memory>
1036              
1037             =head1 CONSTRUCTOR
1038              
1039             =head2 new
1040              
1041             This takes a proper filehandle and will ensure the C<O_NONBLOCK> bit is set, so that it can timeout if there is no more data streamed from the filehandle.
1042              
1043             It returns the newly instantiated object upon success, and upon error, sets an L<error|Module::Generic/error> and return C<undef>
1044              
1045             Possible optional parameters are:
1046              
1047             =over 4
1048              
1049             =item C<buffer>
1050              
1051             You can pass some data that will set the initial read buffer, from which other methods in this class access before reading from the filehandle.
1052              
1053             =item C<max_read_buffer>
1054              
1055             An integer. You can set this a default value for the maximum size of the read buffer.
1056              
1057             This is used by L</getline> and L</read_until_in_memory> to limit how much data can be read into the buffer until it returns an error. Hopefully a line or a match specified with C<read_until> would be found and returned before this limit is reached.
1058              
1059             If this is greater than 0 and the amount of data loaded exceeds this limit, and error is returned.
1060              
1061             =item C<timeout>
1062              
1063             AN integer. This is the read timeout. It defaults to 10.
1064              
1065             =back
1066              
1067             =head1 METHODS
1068              
1069             =head2 buffer
1070              
1071             Sets or gets the buffer.
1072              
1073             This is used by those class methods to get leftover data from the buffer, if any, or from the filehandle if necessary.
1074              
1075             This returns a L<scalar object|Module::Generic::Scalar>
1076              
1077             =head2 can_read
1078              
1079             Returns true if it can read from the filehandle or false otherwise.
1080              
1081             It takes an optional hash or hash reference of options, of which, C<timeout> is the only one.
1082              
1083             =head2 close
1084              
1085             Close the filehandle and destroys the current object.
1086              
1087             =head2 connect
1088              
1089             Provided with an hash or hash reference of options and this will connect to the remote server.
1090              
1091             It returns a new L<HTTP::Promise::IO> object, or upon error, it sets an L<error|Module::Generic/error> and returns C<undef>
1092              
1093             Supported options are:
1094              
1095             All the options used for object instantiation. See L</CONSTRUCTOR> and the following ones:
1096              
1097             =over 4
1098              
1099             =item * C<debug>
1100              
1101             Integer representing the level of debug.
1102              
1103             =item * C<host>
1104              
1105             The remote host to connect to.
1106              
1107             =item * C<port>
1108              
1109             An integer representing the remote port to connect to.
1110              
1111             =item * C<stop_if>
1112              
1113             A code reference that serves as a callback and that is called where there is an C<EINTR> error. If the callback returns true, the connection attempts stop there and returns an error. This default to return false.
1114              
1115             =item * C<timeout>
1116              
1117             An integer or a decimal representing a timeout to be used when resolving the host, or when making remote connection.
1118              
1119             =back
1120              
1121             =head2 connect_ssl
1122              
1123             This takes the same options has L</connect>, but performs an SSL connection.
1124              
1125             Like L</connect>, this returns a new L<HTTP::Promise::IO> object, or upon error, it sets an L<error|Module::Generic/error> and returns C<undef>
1126              
1127             =head2 connect_ssl_over_proxy
1128              
1129             Provided with an hash or hash reference of options and this will connect to the remote server.
1130              
1131             It returns a new L<HTTP::Promise::IO> object, or upon error, it sets an L<error|Module::Generic/error> and returns C<undef>
1132              
1133             Supported options are:
1134              
1135             All the options used for object instantiation. See L</CONSTRUCTOR> and the following ones:
1136              
1137             =over 4
1138              
1139             =item * C<debug>
1140              
1141             Integer representing the level of debug.
1142              
1143             =item * C<host>
1144              
1145             The remote host to connect to.
1146              
1147             =item * C<port>
1148              
1149             An integer representing the remote port to connect to.
1150              
1151             =item * C<proxy_authorization>
1152              
1153             The proxy authorisation string to use for authentication.
1154              
1155             =item * C<proxy_host>
1156              
1157             The remote proxy host to connect to.
1158              
1159             =item * C<proxy_port>
1160              
1161             An integer representing the remote proxy port to connect to.
1162              
1163             =item * C<stop_if>
1164              
1165             A code reference that serves as a callback and that is called where there is an C<EINTR> error. If the callback returns true, the connection attempts stop there and returns an error. This default to return false.
1166              
1167             =item * C<timeout>
1168              
1169             An integer or a decimal representing a timeout to be used when resolving the host, or when making remote connection.
1170              
1171             =back
1172              
1173             =head2 filehandle
1174              
1175             Sets or gets the filehandle being used. This is the same filehandle that was passed upon object instantiation.
1176              
1177             =head2 getline
1178              
1179             Reads from the buffer, if there is enough data left over, or from the filehandle and returns the first line found.
1180              
1181             A line is a string that ends with C<\012> which is portable and universal. This would be the equivalent of C<\n>.
1182              
1183             It returns the line found, if any, or C<undef> if there was an error that you can retrieve with L<error|Module::Generic/error>.
1184              
1185             it takes an optional hash or hash reference of options:
1186              
1187             =over 4
1188              
1189             =item C<chomp>
1190              
1191             If true, this will chomp any trailing sequence of C<\012> possibly preceded by C<\015>
1192              
1193             =item C<max_read_buffer>
1194              
1195             An integer that limits how much cumulative data can be read until it exceeds this allowed maximum. When that happens, an error is returned.
1196              
1197             =back
1198              
1199             =head2 inactivity_timeout
1200              
1201             Integer representing the amount of second to wait until a connection is deemed idle and closed.
1202              
1203             =head2 last_delimiter
1204              
1205             Sets or gets the last delimiter found. A delimiter is some pattern that is provided to L</read_until> and L</read_until_in_memory> with the option C<capture> set to a true value.
1206              
1207             This returns the last delimited found as a L<scalar object|Module::Generic::Scalar>
1208              
1209             =head2 make_select
1210              
1211             Provided with an hash or hash reference of options and this L<perlfunc/select> the filehandle or socket using the C<timeout> provided.
1212              
1213             It returns a positive integer upon success, and upon error, this sets an L<error|Module::Generic/error> and returns C<undef>.
1214              
1215             Supported options are:
1216              
1217             =over 4
1218              
1219             =item * C<timeout>
1220              
1221             Integer representing the timeout.
1222              
1223             =item * C<write>
1224              
1225             Boolean. When true, this will check the filehandle or socket for write capability, or if false for read capability.
1226              
1227             =back
1228              
1229             =head2 make_select_timeout
1230              
1231             This takes the same options as L</make_select>, and it will retry selecting the filehandle or socket until success or a timeout occurs. If an C<EINTR> error occurs, it will query the callback provided with L</stop_if>. If the callback returns true, it will return an error, or keep trying otherwise.
1232              
1233             Returns true upon success, and upon error, this sets an L<error|Module::Generic/error> and returns C<undef>.
1234              
1235             =head2 max_read_buffer
1236              
1237             Sets or gets the maximum bytes amount of the read buffer.
1238              
1239             This is used by L</getline> and L</read_until_in_memory> to limit how much data can be read into the buffer until it returns an error. Hopefully a line or a match specified with C<read_until> would be found and returned before this limit is reached.
1240              
1241             If this is greater than 0 and the amount of data loaded exceeds this limit, and error is returned.
1242              
1243             =head2 print
1244              
1245             Provided with some data to print to the underlying filehandle or socket, and this will call L</write> and return true upon success, or false otherwise.
1246              
1247             =head2 read
1248              
1249             my $bytes = $r->read( $buffer, $length );
1250             my $bytes = $r->read( $buffer, $length, $offset );
1251              
1252             This reads C<$length> bytes from either the internal buffer if there are leftover data, or the filehandle, or even both if the internal buffer is not big enough to meet the C<$length> requirement.
1253              
1254             It returns how many bytes actually were loaded into the caller's C<$buffer>. It returns C<undef> after having set an L<error|Module::Generic/error> if an error occurred.
1255              
1256             Just like the perl core L<perlfunc/read> function, this one too will pad with C<\0> the caller's buffer if the offset specified is greater than the actual size of the caller's buffer.
1257              
1258             Note that there is no guarantee that you can read from the filehandle the desired amount of bytes in just one time, especially if the filehandle is a socket, so you may need to do:
1259              
1260             my $bytes;
1261             my $total_to_read = 102400;
1262             my $total_bytes;
1263             while( $bytes = $r->read( $buffer, $chunk_size ) )
1264             {
1265             $out-print( $buffer ) || die( $! );
1266             # If you want to make sure you do not read more than necessary, otherwise, you can discard this line
1267             $chunk_size = ( $total_to_read - $total_bytes ) if( ( $total_bytes < $total_to_read ) && ( ( $total_bytes + $chunk_size ) > $total_to_read ) );
1268             $total_bytes += $bytes;
1269             last if( $total_bytes == $total_to_read );
1270             }
1271             # Check if something bad happened
1272             die( "Something wrong happened: ", $r->error ) if( !defined( $bytes ) );
1273              
1274             =head2 read_until
1275              
1276             my $bytes = $r->read_until( $buffer, $length, $options_hashref );
1277             my $bytes = $r->read_until( $buffer, $length, $offset, $options_hashref );
1278              
1279             This is similar to L</read>, but will read data from either the buffer, the filehandle or a combination of both until the specified C<string>, passed as an option, is found.
1280              
1281             It loads data in chunks specified with the option C<chunk_size> or by default 2048 bytes. If the specified string is not found within that buffer, it returns how many bytes where read and sets the caller's buffer with the data collected.
1282              
1283             Upon the last call when the C<string> is finally found, this will return the number of bytes read, but as a negative number. This will tell you it has found the match. You can consider the number is negative because those are the last n bytes.
1284              
1285             When no more data at all can be read, this will return 0.
1286              
1287             If an error occurred, this will set an L<error|Module::Generic/error> and return C<undef>
1288              
1289             The possible options that can be passed as an hash reference B<only> are:
1290              
1291             =over 4
1292              
1293             =item C<capture>
1294              
1295             Boolean. When set to true, this will capture the match specified with C<string>. The resulting would then be retrievable using L</last_delimiter>
1296              
1297             =item C<chunk_size>
1298              
1299             An integer. This is the maximum bytes this will read per each iteration.
1300              
1301             =item C<exclude>
1302              
1303             Boolean. If this is true, this will exclude the C<string> sought from the buffer allocation.
1304              
1305             =item C<include>
1306              
1307             Boolean. If this is true, this will set the buffer including the C<string> sought after.
1308              
1309             =item C<string>
1310              
1311             This is the C<string> to read data until it is found. The C<string> can be a simple string, or a regular expression.
1312              
1313             =back
1314              
1315             =head2 read_until_in_memory
1316              
1317             my $data = $r->read_until_in_memory( $string );
1318             my $data = $r->read_until_in_memory( $string, $options_hash_or_hashref );
1319             die( "Error: ", $r->error ) if( !defined( $data ) );
1320              
1321             Provided with a C<string> to be found, this will load data from the internal buffer, the filehandle, or a combination of both into memory until the specified C<string> is found.
1322              
1323             Upon success, it returns the data read, which could be an empty string if nothing matched.
1324              
1325             If an error occurred, this will set an L<error|Module::Generic/error> and return C<undef>.
1326              
1327             It takes the following possible options, either as an hash or hash reference:
1328              
1329             =over
1330              
1331             =item C<capture>
1332              
1333             Boolean. When set to true, this will capture the match specified with C<string>. The resulting would then be retrievable using L</last_delimiter>
1334              
1335             =item C<chunk_size>
1336              
1337             An integer. This is the maximum bytes this will read per each iteration.
1338              
1339             =item C<exclude>
1340              
1341             Boolean. If this is true, this will exclude the C<string> sought from the buffer allocation.
1342              
1343             =item C<include>
1344              
1345             Boolean. If this is true, this will set the buffer including the C<string> sought after.
1346              
1347             =back
1348              
1349             =head2 ssl_opts
1350              
1351             Sets or gets an hash reference of ssl options to be used with L<IO::Socket::SSL/start_SSL>
1352              
1353             =head2 stop_if
1354              
1355             Sets or gets a code reference acting as a callback when an error C<EINTR> if encountered. If the callback returns true, the method using it, will stop and return an error, otherwise, it will keep trying.
1356              
1357             =head2 timeout
1358              
1359             Sets or gets the timeout threshold. This returns a L<number object|Module::Generic::Number>
1360              
1361             =head2 unread
1362              
1363             Provided with some data and this will put it back into the internal buffer, at its beginning.
1364              
1365             This returns the current object for chaining.
1366              
1367             =head2 write
1368              
1369             This write to the filehandle set, and takes a buffer to write, an optional length, an optional offset, and an optional timeout value.
1370              
1371             If no length is provided, this default to the length of the buffer.
1372              
1373             If no offset is provided, this default to C<0>.
1374              
1375             If no timeout is provided, this default to the value set with L</timeout>
1376              
1377             It returns the number of bytes written or, upon error, sets an L<error|Module::Generic/error> and returns C<undef>
1378              
1379             =head2 write_all
1380              
1381             Provided with some data an an optional timeout, and this will write the data to the filehandle set.
1382              
1383             It returns the number of bytes written or, upon error, sets an L<error|Module::Generic/error> and returns C<undef>
1384              
1385             =head1 AUTHOR
1386              
1387             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
1388              
1389             =head1 SEE ALSO
1390              
1391             L<HTTP::Promise>, L<HTTP::Promise::Request>, L<HTTP::Promise::Response>, L<HTTP::Promise::Message>, L<HTTP::Promise::Entity>, L<HTTP::Promise::Headers>, L<HTTP::Promise::Body>, L<HTTP::Promise::Body::Form>, L<HTTP::Promise::Body::Form::Data>, L<HTTP::Promise::Body::Form::Field>, L<HTTP::Promise::Status>, L<HTTP::Promise::MIME>, L<HTTP::Promise::Parser>, L<HTTP::Promise::IO>, L<HTTP::Promise::Stream>, L<HTTP::Promise::Exception>
1392              
1393             =head1 COPYRIGHT & LICENSE
1394              
1395             Copyright(c) 2022 DEGUEST Pte. Ltd.
1396              
1397             All rights reserved.
1398              
1399             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
1400              
1401             =cut