File Coverage

blib/lib/Net/HTTPS/NB.pm
Criterion Covered Total %
statement 39 113 34.5
branch 11 30 36.6
condition 4 20 20.0
subroutine 10 14 71.4
pod 7 7 100.0
total 71 184 38.5


line stmt bran cond sub pod time code
1             package Net::HTTPS::NB;
2              
3 3     3   62145 use strict;
  3         6  
  3         78  
4 3     3   2208 use Net::HTTP;
  3         1192239  
  3         36  
5 3     3   6858 use IO::Socket::SSL 0.98;
  3         7562418  
  3         39  
6 3     3   942 use Exporter;
  3         6  
  3         186  
7 3     3   21 use Errno qw(EWOULDBLOCK EAGAIN);
  3         6  
  3         228  
8 3     3   24 use vars qw($VERSION @ISA @EXPORT $HTTPS_ERROR);
  3         9  
  3         603  
9              
10             $VERSION = 0.14;
11              
12             =head1 NAME
13              
14             Net::HTTPS::NB - Non-blocking HTTPS client
15              
16             =head1 SYNOPSIS
17              
18             =over
19              
20             =item Example of sending request and receiving response
21              
22             use strict;
23             use Net::HTTPS::NB;
24             use IO::Select;
25             use Errno qw/EAGAIN EWOULDBLOCK/;
26            
27             my $s = Net::HTTPS::NB->new(Host => "pause.perl.org") || die $@;
28             $s->write_request(GET => "/");
29            
30             my $sel = IO::Select->new($s);
31            
32             READ_HEADER: {
33             die "Header timeout" unless $sel->can_read(10);
34             my($code, $mess, %h) = $s->read_response_headers;
35             redo READ_HEADER unless $code;
36             }
37            
38             # Net::HTTPS::NB uses internal buffer for reading
39             # so we should check it before socket check by calling read_entity_body()
40             # it is error to wait data on socket before read_entity_body() will return undef
41             # with $! set to EAGAIN or EWOULDBLOCK
42             # make socket non-blocking, so read_entity_body() will not block
43             $s->blocking(0);
44            
45             while (1) {
46             my $buf;
47             my $n;
48             # try to read until error or all data received
49             while (1) {
50             my $tmp_buf;
51             $n = $s->read_entity_body($tmp_buf, 1024);
52             if ($n == -1 || (!defined($n) && ($! == EWOULDBLOCK || $! == EAGAIN))) {
53             last; # no data available this time
54             }
55             elsif ($n) {
56             $buf .= $tmp_buf; # data received
57             }
58             elsif (defined $n) {
59             last; # $n == 0, all readed
60             }
61             else {
62             die "Read error occured: ", $!; # $n == undef
63             }
64             }
65            
66             print $buf if length $buf;
67             last if defined $n && $n == 0; # all readed
68             die "Body timeout" unless $sel->can_read(10); # wait for new data
69             }
70              
71             =item Example of non-blocking connect
72              
73             use strict;
74             use Net::HTTPS::NB;
75             use IO::Select;
76              
77             my $sock = Net::HTTPS::NB->new(Host => 'encrypted.google.com', Blocking => 0);
78             my $sele = IO::Select->new($sock);
79              
80             until ($sock->connected) {
81             if ($HTTPS_ERROR == HTTPS_WANT_READ) {
82             $sele->can_read();
83             }
84             elsif($HTTPS_ERROR == HTTPS_WANT_WRITE) {
85             $sele->can_write();
86             }
87             else {
88             die 'Unknown error: ', $HTTPS_ERROR;
89             }
90             }
91              
92             =back
93              
94             See `examples' subdirectory for more examples.
95              
96             =head1 DESCRIPTION
97              
98             Same interface as Net::HTTPS but it will never try multiple reads when the
99             read_response_headers() or read_entity_body() methods are invoked. In addition
100             allows non-blocking connect.
101              
102             =over
103              
104             =item If read_response_headers() did not see enough data to complete the headers an empty list is returned.
105              
106             =item If read_entity_body() did not see new entity data in its read the value -1 is returned.
107              
108             =back
109              
110             =cut
111              
112             # we only supports IO::Socket::SSL now
113             # use it force
114             $Net::HTTPS::SSL_SOCKET_CLASS = 'IO::Socket::SSL';
115             require Net::HTTPS;
116              
117             # make aliases to IO::Socket::SSL variables and constants
118             use constant {
119 3         4626 HTTPS_WANT_READ => SSL_WANT_READ,
120             HTTPS_WANT_WRITE => SSL_WANT_WRITE,
121 3     3   24 };
  3         15  
122             *HTTPS_ERROR = \$SSL_ERROR;
123              
124             =head1 PACKAGE CONSTANTS
125              
126             Imported by default
127              
128             HTTPS_WANT_READ
129             HTTPS_WANT_WRITE
130              
131             =head1 PACKAGE VARIABLES
132              
133             Imported by default
134              
135             $HTTPS_ERROR
136              
137             =cut
138              
139             # need export some stuff for error handling
140             @EXPORT = qw($HTTPS_ERROR HTTPS_WANT_READ HTTPS_WANT_WRITE);
141             @ISA = qw(Net::HTTPS Exporter);
142              
143             =head1 METHODS
144              
145             =head2 new(%cfg)
146              
147             Same as Net::HTTPS::new, but in addition allows `Blocking' parameter. By setting
148             this parameter to 0 you can perform non-blocking connect. See connected() to
149             determine when connection completed.
150              
151             =cut
152              
153             sub new {
154 3     3 1 8186 my ($class, %args) = @_;
155            
156 3         37 my %ssl_opts;
157 3         103 while (my $name = each %args) {
158 7 50       85 if (substr($name, 0, 4) eq 'SSL_') {
159 0         0 $ssl_opts{$name} = delete $args{$name};
160             }
161             }
162            
163 3 50       31 unless (exists $args{PeerPort}) {
164 0         0 $args{PeerPort} = 443;
165             }
166            
167             # create plain socket first
168 3 50       137 my $self = Net::HTTP->new(%args)
169             or return;
170            
171             # and upgrade it to SSL then
172 3 50       671502 $class->start_SSL($self, %ssl_opts, SSL_startHandshake => 0)
173             or return;
174            
175 3 100 66     338823 if (!exists($args{Blocking}) || $args{Blocking}) {
176             # blocking connect
177 2 50       14 $self->connected()
178             or return;
179             }
180             # non-blocking handshake will be started after plain socket connected
181            
182 1         21 return $self;
183             }
184              
185             =head2 connected()
186              
187             Returns true value when connection completed (https handshake done). Otherwise
188             returns false. In this case you can check $HTTPS_ERROR to determine what handshake
189             need for, read or write. $HTTPS_ERROR could be HTTPS_WANT_READ or HTTPS_WANT_WRITE
190             respectively. See L.
191              
192             =cut
193              
194             sub connected {
195 3     3 1 1489 my $self = shift;
196            
197 3 50       8 if (exists ${*$self}{httpsnb_connected}) {
  3         49  
198             # already connected or disconnected
199 0   0     0 return ${*$self}{httpsnb_connected} && getpeername($self);
200             }
201            
202 3 50 66     53 if ($self->connect_SSL()) {
    100          
203 0         0 return ${*$self}{httpsnb_connected} = 1;
  0         0  
204             }
205             elsif ($! != EWOULDBLOCK && $! != EAGAIN) {
206 2         894 $HTTPS_ERROR = $!;
207             }
208 3         680 return 0;
209             }
210              
211             sub close {
212 0     0 1 0 my $self = shift;
213             # need some cleanup
214 0         0 ${*$self}{httpsnb_connected} = 0;
  0         0  
215 0         0 return $self->SUPER::close();
216             }
217              
218             =head2 blocking($flag)
219              
220             As opposed to Net::HTTPS where blocking method consciously broken you
221             can set socket blocking. For example you can return socket to blocking state
222             after non-blocking connect.
223              
224             =cut
225              
226             sub blocking {
227             # blocking() is breaked in Net::HTTPS
228             # restore it here
229 2     2 1 4995828 my $self = shift;
230 2         20 $self->IO::Socket::blocking(@_);
231             }
232              
233             # code below copied from Net::HTTP::NB with some modifications
234             # Author: Gisle Aas
235              
236             sub sysread {
237 0     0 1   my $self = shift;
238 0 0         unless (${*$self}{'httpsnb_reading'}) {
  0            
239             # allow reading without restrictions when called
240             # not from our methods
241 0           return $self->SUPER::sysread(@_);
242             }
243            
244 0 0         if (${*$self}{'httpsnb_read_count'}++) {
  0            
245 0           ${*$self}{'http_buf'} = ${*$self}{'httpsnb_save'};
  0            
  0            
246 0           die "Multi-read\n";
247             }
248            
249 0   0       my $offset = $_[2] || 0;
250 0           my $n = $self->SUPER::sysread($_[0], $_[1], $offset);
251 0           ${*$self}{'httpsnb_save'} .= substr($_[0], $offset);
  0            
252 0           return $n;
253             }
254              
255             sub read_response_headers {
256 0     0 1   my $self = shift;
257 0           ${*$self}{'httpsnb_reading'} = 1;
  0            
258 0           ${*$self}{'httpsnb_read_count'} = 0;
  0            
259 0           ${*$self}{'httpsnb_save'} = ${*$self}{'http_buf'};
  0            
  0            
260 0           my @h = eval { $self->SUPER::read_response_headers(@_) };
  0            
261 0           ${*$self}{'httpsnb_reading'} = 0;
  0            
262 0 0         if ($@) {
263 0 0 0       return if $@ eq "Multi-read\n" || $HTTPS_ERROR == HTTPS_WANT_READ;
264 0           die;
265             }
266 0           return @h;
267             }
268              
269             sub read_entity_body {
270 0     0 1   my $self = shift;
271 0           ${*$self}{'httpsnb_reading'} = 1;
  0            
272 0           ${*$self}{'httpsnb_read_count'} = 0;
  0            
273 0           ${*$self}{'httpsnb_save'} = ${*$self}{'http_buf'};
  0            
  0            
274            
275 0           my $chunked = ${*$self}{'http_chunked'};
  0            
276 0           my $bytes = ${*$self}{'http_bytes'};
  0            
277 0           my $first_body = ${*$self}{'http_first_body'};
  0            
278 0           my @request_method = @{${*$self}{'http_request_method'}};
  0            
  0            
279            
280             # XXX I'm not so sure this does the correct thing in case of
281             # transfer-encoding tranforms
282 0           my $n = eval { $self->SUPER::read_entity_body(@_) };
  0            
283 0           ${*$self}{'httpsnb_reading'} = 0;
  0            
284 0 0 0       if ($@ || (!defined($n) && $HTTPS_ERROR == HTTPS_WANT_READ)) {
      0        
285 0 0         if ($@ eq "Multi-read\n") {
286             # Reset some internals of Net::HTTP::Methods
287 0           ${*$self}{'http_chunked'} = $chunked;
  0            
288 0           ${*$self}{'http_bytes'} = $bytes;
  0            
289 0           ${*$self}{'http_first_body'} = $first_body;
  0            
290 0           ${*$self}{'http_request_method'} = \@request_method;
  0            
291             }
292 0           $_[0] = "";
293 0           return -1;
294             }
295 0           return $n;
296             }
297              
298             1;
299              
300             =head1 SEE ALSO
301              
302             L, L, L
303              
304             =head1 COPYRIGHT
305              
306             Copyright 2011-2015 Oleg G .
307              
308             This library is free software; you can redistribute it and/or
309             modify it under the same terms as Perl itself.
310              
311             =cut