File Coverage

blib/lib/Net/HTTP/NB.pm
Criterion Covered Total %
statement 39 47 82.9
branch 3 8 37.5
condition 1 2 50.0
subroutine 7 7 100.0
pod 2 4 50.0
total 52 68 76.4


line stmt bran cond sub pod time code
1             package Net::HTTP::NB;
2             our $VERSION = '6.21';
3 1     1   1166 use strict;
  1         1  
  1         25  
4 1     1   4 use warnings;
  1         2  
  1         24  
5              
6 1     1   4 use base 'Net::HTTP';
  1         2  
  1         394  
7              
8             sub can_read {
9 3     3 0 8 return 1;
10             }
11              
12             sub sysread {
13 3     3 0 5 my $self = $_[0];
14 3 50       3 if (${*$self}{'httpnb_read_count'}++) {
  3         9  
15 0         0 ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
  0         0  
  0         0  
16 0         0 die "Multi-read\n";
17             }
18 3         5 my $buf;
19 3   50     9 my $offset = $_[3] || 0;
20 3         31 my $n = sysread($self, $_[1], $_[2], $offset);
21 3         6 ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
  3         12  
22 3         10 return $n;
23             }
24              
25             sub read_response_headers {
26 1     1 1 2097 my $self = shift;
27 1         2 ${*$self}{'httpnb_read_count'} = 0;
  1         3  
28 1         3 ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
  1         3  
  1         2  
29 1         2 my @h = eval { $self->SUPER::read_response_headers(@_) };
  1         12  
30 1 50       3 if ($@) {
31 0 0       0 return if $@ eq "Multi-read\n";
32 0         0 die;
33             }
34 1         4 return @h;
35             }
36              
37             sub read_entity_body {
38 3     3 1 1741 my $self = shift;
39 3         3 ${*$self}{'httpnb_read_count'} = 0;
  3         10  
40 3         4 ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
  3         6  
  3         4  
41             # XXX I'm not so sure this does the correct thing in case of
42             # transfer-encoding transforms
43 3         4 my $n = eval { $self->SUPER::read_entity_body(@_); };
  3         17  
44 3 50       7 if ($@) {
45 0         0 $_[0] = "";
46 0         0 return -1;
47             }
48 3         9 return $n;
49             }
50              
51             1;
52              
53             =pod
54              
55             =encoding UTF-8
56              
57             =head1 NAME
58              
59             Net::HTTP::NB - Non-blocking HTTP client
60              
61             =head1 VERSION
62              
63             version 6.21
64              
65             =head1 SYNOPSIS
66              
67             use Net::HTTP::NB;
68             my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
69             $s->write_request(GET => "/");
70              
71             use IO::Select;
72             my $sel = IO::Select->new($s);
73              
74             READ_HEADER: {
75             die "Header timeout" unless $sel->can_read(10);
76             my($code, $mess, %h) = $s->read_response_headers;
77             redo READ_HEADER unless $code;
78             }
79              
80             while (1) {
81             die "Body timeout" unless $sel->can_read(10);
82             my $buf;
83             my $n = $s->read_entity_body($buf, 1024);
84             last unless $n;
85             print $buf;
86             }
87              
88             =head1 DESCRIPTION
89              
90             Same interface as C but it will never try multiple reads
91             when the read_response_headers() or read_entity_body() methods are
92             invoked. This make it possible to multiplex multiple Net::HTTP::NB
93             using select without risk blocking.
94              
95             If read_response_headers() did not see enough data to complete the
96             headers an empty list is returned.
97              
98             If read_entity_body() did not see new entity data in its read
99             the value -1 is returned.
100              
101             =head1 SEE ALSO
102              
103             L
104              
105             =head1 AUTHOR
106              
107             Gisle Aas
108              
109             =head1 COPYRIGHT AND LICENSE
110              
111             This software is copyright (c) 2001-2017 by Gisle Aas.
112              
113             This is free software; you can redistribute it and/or modify it under
114             the same terms as the Perl 5 programming language system itself.
115              
116             =cut
117              
118             __END__